smalltalk-tng
view r1/oo.scm @ 323:454c18798969
merger
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Tue Feb 07 11:34:20 2012 -0500 (3 months ago) |
| parents | |
| children |
line source
1 (require 'srfi-1)
3 ;---------------------------------------------------------------------------
5 (define-record-type slot
6 (make-slot* name index roles delegating? kind)
7 slot?
8 (name slot-name) ;; symbol
9 (index slot-index set-slot-index!) ;; #f, or integer offset into object-slots vector
10 (roles slot-roles set-slot-roles!) ;; list of roles
11 (delegating? slot-delegating?) ;; boolean
12 (kind slot-kind)) ;; 'method, 'immutable, or 'mutable
14 (define-record-type object
15 (make-object* layout slots)
16 object?
17 (layout object-layout set-object-layout!)
18 (slots object-slots set-object-slots!))
20 (define-record-type role
21 (make-role* positions requirements method)
22 role?
23 (positions role-positions set-role-positions!)
24 (requirements role-requirements)
25 (method role-method set-role-method!))
27 (define-record-type layout
28 (make-layout** hash map)
29 layout?
30 (hash layout-hash)
31 (map layout-map))
33 (define layout-hash-factory
34 (let ((counter 0))
35 (lambda ()
36 (let ((v counter))
37 (set! counter (bitwise-and (+ counter 1) #xFFFFFF)) ;; some arbitrary wraparound
38 v))))
40 (define (make-layout*)
41 (make-layout** (layout-hash-factory)
42 (make-hash-table eq?)))
44 (define (layout-ref layout slot-name def)
45 (hash-table-ref (layout-map layout) slot-name def))
47 (define (layout-set! layout slot-name value)
48 (hash-table-set! (layout-map layout) slot-name value))
50 (define (layout-for-each layout fn)
51 (hash-table-for-each fn (layout-map layout)))
53 (define (layout-remove! layout slot-name)
54 (hash-table-remove! (layout-map layout) slot-name))
56 ;---------------------------------------------------------------------------
58 (define *literal-objects* 'uninitialised-literal-objects)
60 (define (flush-literal-objects-table!)
61 (set! *literal-objects* (make-hash-table eq?)))
63 (define (object-for-literal! x)
64 (or (hash-table-ref *literal-objects* x #f)
65 (let* ((ob (make-object* (make-layout*) (vector)))
66 (t (traits-for-primitive x)))
67 (add-slot! ob 'traits (traits-for-primitive x) #t 'immutable)
68 (hash-table-set! *literal-objects* x ob)
69 ob)))
71 (define (install-object-for-literal! x ob)
72 (unless (hash-table-ref *literal-objects* x #f)
73 (hash-table-set! *literal-objects* x ob)))
75 (define (for-each-literal-object fn)
76 (hash-table-for-each fn *literal-objects*))
78 (define (ensure-object! x)
79 (if (object? x)
80 x
81 (object-for-literal! x)))
83 (define (object-or-false x)
84 (if (object? x)
85 x
86 (hash-table-ref *literal-objects* x #f)))
88 (define-syntax ensure-object-var/create!
89 (syntax-rules ()
90 ((_ var)
91 (begin
92 (unless (object? var)
93 (set! var (object-for-literal! var)))))))
95 (define-syntax ensure-object-var/traits
96 (syntax-rules ()
97 ((_ var)
98 (begin
99 (unless (object? var)
100 (set! var (or (hash-table-ref *literal-objects* var #f)
101 (traits-for-primitive var))))))))
103 ;---------------------------------------------------------------------------
105 (define (clone-object o)
106 (let* ((o-slots (object-slots o))
107 (new-slots (make-vector (vector-length o-slots))))
108 (vector-copy! o-slots new-slots)
109 (make-object* (object-layout o)
110 new-slots)))
112 (define (clone-layout layout)
113 (let ((new-layout (make-layout*)))
114 (layout-for-each layout
115 (lambda (slot-name slot)
116 (layout-set! new-layout slot-name slot)))
117 new-layout))
119 (define (clone-slot slot)
120 (make-slot* (slot-name slot)
121 (slot-index slot)
122 (slot-roles slot)
123 (slot-delegating? slot)
124 (slot-kind slot)))
126 (define (merge-slot-kinds current new)
127 (if (kind-is-non-slot? current)
128 new
129 current))
131 (define (kind-is-slot? kind)
132 (not (eq? kind 'method)))
134 (define (kind-is-non-slot? kind)
135 (eq? kind 'method))
137 (define (add-slot! o name value delegating? kind . should-add-accessors)
138 (ensure-object-var/create! o)
139 (debug 1 "Add-slot: "o" "name" "value" "delegating?" "kind" "should-add-accessors)
140 (let* ((layout (clone-layout (object-layout o)))
141 (old-slot (layout-ref layout name #f))
142 (slot (if old-slot
143 (make-slot* name
144 (slot-index old-slot)
145 (slot-roles old-slot)
146 (or (slot-delegating? old-slot) delegating?)
147 (merge-slot-kinds (slot-kind old-slot) kind))
148 (make-slot* name
149 #f
150 '()
151 delegating?
152 kind))))
153 (layout-set! layout name slot)
154 (set-object-layout! o layout)
155 (let ((index (slot-index slot)))
156 (if (not index)
157 (let* ((new-index (vector-length (object-slots o)))
158 (new-slots (make-vector (+ new-index 1))))
159 (vector-copy! (object-slots o) new-slots)
160 (vector-set! new-slots new-index value)
161 (set-slot-index! slot new-index)
162 (set-object-slots! o new-slots))
163 (vector-set! (object-slots o) index value)))
164 (when (and (or (null? should-add-accessors) (car should-add-accessors))
165 (kind-is-slot? kind)
166 (or (not old-slot)
167 (kind-is-non-slot? (slot-kind old-slot))))
168 (add-accessors! o name (eq? kind 'immutable)))
169 o))
171 (define (mutator-name-for name)
172 (string->symbol (string-append (symbol->string name) ":")))
174 (define (add-accessors! o name immutable?)
175 (debug 2 "Adding getter for "name" on "o)
176 (add-roles!* name #f (make-getter-method-for name) (list o))
177 (if (not immutable?)
178 (let ((mutator-name (mutator-name-for name)))
179 (debug 2 "Adding setter for "name" ("mutator-name") on "o)
180 (add-roles!* mutator-name #f (make-setter-method-for name mutator-name)
181 ;; You'd think we'd need a two-element list here,
182 ;; but we don't. This is because of the sparse
183 ;; encoding of roles. Essentially, setter methods
184 ;; only have a constraint on their first
185 ;; argument, so we don't have to bother about the
186 ;; second argument at all.
187 (list o))))
188 o)
190 (define (collect-bitset filter specialisers)
191 (fold-left/index (lambda (index specialiser acc)
192 (if (filter specialiser)
193 (set-bit acc index)
194 acc))
195 *empty-bitset* specialisers))
197 (define (not-no-role? specialiser)
198 (not (eq? specialiser *no-role*)))
200 (define (add-roles!* name clone-existing-slot? method specialisers)
201 (let ((requirements (collect-bitset not-no-role? specialisers)))
202 (for-each/index
203 (lambda (index specialiser)
204 (when (not-no-role? specialiser)
205 (add-role! specialiser name clone-existing-slot? index requirements method)))
206 specialisers)))
208 (define (add-role! o name clone-existing-slot? index requirements method)
209 (ensure-object-var/create! o)
210 (let* ((layout (clone-layout (object-layout o)))
211 (old-slot (layout-ref layout name #f))
212 (slot (if old-slot
213 (if clone-existing-slot? (clone-slot old-slot) old-slot)
214 (make-slot* name
215 #f
216 '()
217 #f
218 'method))))
219 (layout-set! layout name slot)
220 (set-object-layout! o layout)
221 (let update-roles ((roles (slot-roles slot)))
222 (if (null? roles)
223 (set-slot-roles! slot
224 (cons (make-role* (set-bit *empty-bitset* index) requirements method)
225 (slot-roles slot)))
226 (let ((role (car roles)))
227 (if (eq? (role-method role) method)
228 (set-role-positions! role (set-bit (role-positions role) index))
229 (update-roles (cdr roles))))))
230 (invalidate-method-cache!)
231 o))
233 (define remove-slot!
234 (let ()
235 (define (splice-out-slot-value! o removed-index)
236 (let* ((old-slots (object-slots o))
237 (old-slots-length (vector-length old-slots))
238 (new-slots (make-vector (- old-slots-length 1))))
239 (do ((i 0 (+ i 1)))
240 ((= i removed-index))
241 (vector-set! new-slots i (vector-ref old-slots i)))
242 (do ((i (+ removed-index 1) (+ i 1)))
243 ((= i old-slots-length))
244 (vector-set! new-slots (- i 1) (vector-ref old-slots i)))
245 (set-object-slots! o new-slots)
246 (vector-ref old-slots removed-index)))
248 (define (fixup-other-slot-indices! layout removed-index)
249 (layout-for-each layout
250 (lambda (slot-name slot)
251 (if (> (slot-index slot) removed-index)
252 (set-slot-index! slot (- (slot-index slot) 1))))))
254 (define (remove-mutator-role! layout name)
255 (let* ((mutator-name (mutator-name-for name))
256 (mutator-slot (layout-ref layout mutator-name #f)))
257 (if mutator-slot
258 (let* ((new-slot (clone-slot mutator-slot)))
259 (set-slot-roles! new-slot
260 ;; Ought this to just remove *one*? Can there ever be more than one?
261 (filter (lambda (role)
262 (not (eq? (get-slot (role-method role) 'accessor) name)))
263 (slot-roles new-slot)))
264 (if (null? (slot-roles new-slot))
265 (layout-remove! layout mutator-name)
266 (layout-set! layout mutator-name new-slot))))))
268 (lambda (o name)
269 (and-let* ((o (object-or-false o)))
270 (let* ((layout (clone-layout (object-layout o)))
271 (removed-slot (layout-ref layout name #f))
272 (removed-index (slot-index removed-slot)))
273 (set-object-layout! o layout)
274 (let ((old-value (splice-out-slot-value! o removed-index)))
275 (fixup-other-slot-indices! layout removed-index)
276 (layout-remove! layout name)
277 (if (eq? (slot-kind removed-slot) 'mutable)
278 (remove-mutator-role! layout name))
279 (invalidate-method-cache!)
280 old-value))))))
282 (define replace-method!
283 (let ()
284 (define (find-specific-method name specialisers)
285 (let ((requirements (collect-bitset not-no-role? specialisers)))
286 (let loop ((found-methods #f)
287 (specialisers specialisers)
288 (index 0))
289 (cond
290 ((null? found-methods) #f)
291 ((null? specialisers)
292 (cond
293 ((not found-methods) #f)
294 ((pair? (cdr found-methods))
295 (error 'too-many-matches-candidates (list name specialisers)))
296 (else (car found-methods))))
297 (else
298 (and-let* ((specialiser (object-or-false (car specialisers))))
299 (if (not-no-role? specialiser)
300 (and-let* ((slot (layout-ref (object-layout specialiser) name #f)))
301 (let ((new-methods (map role-method
302 (filter (lambda (role)
303 (and (bit-set? (role-positions role)
304 index)
305 (bitset=? (role-requirements role)
306 requirements)))
307 (slot-roles slot)))))
308 (loop (if found-methods
309 (lset-intersection eq? found-methods new-methods)
310 new-methods)
311 (cdr specialisers)
312 (+ index 1))))
313 (loop found-methods (cdr specialisers) (+ index 1)))))))))
315 (lambda (name specialisers new-method)
316 (and-let* ((found-method (find-specific-method name specialisers)))
317 (for-each (lambda (specialiser)
318 (let ((specialiser (object-or-false specialiser)))
319 (when (not-no-role? specialiser)
320 (let* ((slot (clone-slot (layout-ref (object-layout specialiser)
321 name #f))))
322 (layout-set! (object-layout specialiser) slot)
323 (for-each (lambda (role)
324 (if (eq? (role-method role) found-method)
325 (set-role-method! role new-method)))
326 (slot-roles slot))))))
327 specialisers)
328 found-method))))
330 (define (has-slot? object-or-primitive name)
331 (let ((o (object-or-false object-or-primitive)))
332 (if o
333 (layout-ref (object-layout o) name #f)
334 (eq? name 'traits))))
336 (define (get-slot object-or-primitive name)
337 (let ((o (object-or-false object-or-primitive)))
338 (if o
339 (and-let* ((slot (layout-ref (object-layout o) name #f))
340 (index (slot-index slot)))
341 (vector-ref (object-slots o) index))
342 (and (eq? name 'traits)
343 (traits-for-primitive object-or-primitive)))))
345 (define (set-slot! object-or-primitive name value)
346 (and-let* ((o (object-or-false object-or-primitive))
347 (slot (layout-ref (object-layout o) name #f))
348 (index (slot-index slot)))
349 (let* ((slots (object-slots o))
350 (old-value (vector-ref slots index)))
351 (vector-set! slots index value)
352 old-value)))
354 (define (add-roles! name method specialisers)
355 (if (replace-method! name specialisers method)
356 method
357 (let ((requirements (collect-bitset not-no-role? specialisers)))
358 (for-each/index (lambda (index specialiser)
359 (when (not-no-role? specialiser)
360 (add-role! specialiser name #f index requirements method)))
361 specialisers))))
363 ;; (define-method! (union symbol string)
364 ;; (list-of symbol)
365 ;; (list-of object) - use *no-role* in this list if needed
366 ;; procedure)
367 ;; -> method
368 ;;
369 (define (define-method! name formal-names formal-specialisers body)
370 (let* ((selector (if (string? name) (string->symbol name) name))
371 (method (make-method* selector formal-names body)))
372 (add-roles!* selector #t method formal-specialisers)
373 (invalidate-method-cache!)
374 method))
376 ;---------------------------------------------------------------------------
378 (define-record-type method-cache-entry
379 (make-method-cache-entry selector layouts method)
380 method-cache-entry?
381 (selector method-cache-entry-selector)
382 (layouts method-cache-entry-layouts)
383 (method method-cache-entry-method))
385 (define *method-cache-length* 512)
387 (define *method-cache* 'uninitialised-method-cache)
388 (define (invalidate-method-cache!)
389 (set! *method-cache* (make-vector *method-cache-length* '())))
390 (invalidate-method-cache!)
392 (define (object-layout-for-cache x)
393 (object-layout (cond
394 ((object? x) x)
395 ((hash-table-ref *literal-objects* x #f))
396 (else (traits-for-primitive x)))))
398 (define (object-layout-hash-for-cache x)
399 (layout-hash (object-layout-for-cache x)))
401 (define (probe-for-cache selector args)
402 (bitwise-and (bitwise-xor (hash selector *method-cache-length*)
403 (object-layout-hash-for-cache (vector-ref args 0)))
404 (- *method-cache-length* 1)))
406 (define (check-method-cache selector args)
407 (let* ((probe (probe-for-cache selector args))
408 (entry (vector-ref *method-cache* probe)))
409 (and (method-cache-entry? entry)
410 (eq? (method-cache-entry-selector entry) selector)
411 (let ((n (vector-length args))
412 (layouts (method-cache-entry-layouts entry)))
413 (and (= n (vector-length layouts))
414 (let loop ((i 0))
415 (cond
416 ((= i n) (method-cache-entry-method entry))
417 ((eq? (object-layout-for-cache (vector-ref args i)) (vector-ref layouts i))
418 (loop (+ i 1)))
419 (else #f))))))))
421 (define (cache-method! method selector args)
422 (let* ((n (vector-length args))
423 (layouts (make-vector n))
424 (probe (probe-for-cache selector args)))
425 (do ((i 0 (+ i 1)))
426 ((= i n))
427 (vector-set! layouts i (object-layout-for-cache (vector-ref args i))))
428 (vector-set! *method-cache* probe (make-method-cache-entry selector
429 layouts
430 method))))
432 ;---------------------------------------------------------------------------
434 (define-record-type bitset
435 (make-bitset* bits)
436 bitset?
437 (bits bitset-bits))
439 (define *bitset-capacity* 31)
441 (define-record-printer (bitset b out)
442 (for-each (lambda (x) (display x out))
443 (list "#<bitset "(bitset->list b)">")))
445 (define (bit-set? bitset n)
446 (if (>= n *bitset-capacity*) (error 'bitset-capacity-exceeded-in-bit-set?))
447 (not (zero? (bitwise-and (bitset-bits bitset) (arithmetic-shift 1 n)))))
449 (define (set-bit bitset n)
450 (if (>= n *bitset-capacity*) (error 'bitset-capacity-exceeded-in-set-bit))
451 (make-bitset* (bitwise-ior (bitset-bits bitset) (arithmetic-shift 1 n))))
453 (define (clear-bit bitset n)
454 (if (>= n *bitset-capacity*) (error 'bitset-capacity-exceeded-in-clear-bit))
455 (make-bitset* (bitwise-and (bitset-bits bitset) (bitwise-not (arithmetic-shift 1 n)))))
457 (define (bitset=? b1 b2)
458 (= (bitset-bits b1)
459 (bitset-bits b2)))
461 (define (bitset->list b)
462 (filter (lambda (n) (bit-set? b n))
463 (iota *bitset-capacity*)))
465 (define (list->bitset l)
466 (fold (lambda (bit acc) (set-bit acc bit))
467 *empty-bitset*
468 l))
470 (define *empty-bitset* (make-bitset* 0))
472 ;---------------------------------------------------------------------------
473 ;; Rank vectors.
474 ;;
475 ;; Representation: bitfield, 28 bits wide; bits numbered >= 28 must be zero.
476 ;; - room for 7 arguments numbered 0 through 6, inclusive
477 ;; - bits [4n, 4n+3] are the delegation-depth at the (6-n)th argument
478 ;; Thus:
479 ;; 33222222222211111111110000000000
480 ;; 10987654321098765432109876543210
481 ;; --------------------------------
482 ;; xxxx0000111122223333444455556666
484 (define *illegal-rank-vector-bits* (arithmetic-shift -1 (* 4 7)))
485 (define *max-rank-vector* (bitwise-not *illegal-rank-vector-bits*))
487 (define (rank-vector-update rv delegation-depth arg-index)
488 (let ((result (if (or (> delegation-depth 15)
489 (> arg-index 6))
490 (error 'out-of-range-in-rank-vector-update (list delegation-depth arg-index))
491 (let ((offset (* 4 (- 6 arg-index))))
492 (bitwise-ior (bitwise-and rv
493 *max-rank-vector*
494 (bitwise-not (arithmetic-shift #xF offset)))
495 (arithmetic-shift delegation-depth offset))))))
496 (debug 4 "rank-vector-update "(number->string rv 16)" "delegation-depth" "arg-index
497 " --> "(number->string result 16))
498 (if (not (zero? (bitwise-and rv *illegal-rank-vector-bits*)))
499 (error "Illegal rank vector"))
500 result))
502 (define rank-vector<?
503 (lambda (a b)
504 (let ((result (< a b)))
505 (debug 4 "rank-vector<? "(number->string a 16)" "(number->string b 16)" --> "result)
506 result)))
507 (define rank-vector>?
508 (lambda (a b)
509 (let ((result (> a b)))
510 (debug 4 "rank-vector>? "(number->string a 16)" "(number->string b 16)" --> "result)
511 result)))
513 ;---------------------------------------------------------------------------
515 (define (role-active-at-position? role position)
516 (bit-set? (role-positions role) position))
518 (define (role-requirements-filled? role positions)
519 (bitset=? positions (role-requirements role)))
521 ;---------------------------------------------------------------------------
523 (define (dispatch ignored-method selector args)
524 (or (and (not ignored-method)
525 (check-method-cache selector args))
526 (if ignored-method
527 (dispatch* ignored-method selector args)
528 (and-let* ((method (dispatch* ignored-method selector args)))
529 (cache-method! method selector args)
530 method))))
532 (define (dispatch* ignored-method selector args)
533 (debug 3 --> 0 "Dispatch "selector" "(vector-length args))
534 (let* ((num-args (vector-length args))
535 (most-specific-method #f)
536 ; (DEBUG-ids (make-hash-table eq?))
537 ; (DEBUG-counter 10000)
538 ; (DEBUG-id (lambda (x) (or (hash-table-ref DEBUG-ids x)
539 ; (let ((c DEBUG-counter))
540 ; (set! DEBUG-counter (+ c 1))
541 ; (hash-table-set! DEBUG-ids x c)
542 ; c))))
543 (accessor-target #f)
544 (candidate-status (make-hash-table eq?))
545 (delegations-seen (make-hash-table eq?))
546 (rank-table (make-hash-table eq?))
547 (rank-vector-for (lambda (method deft) (hash-table-ref rank-table method deft))))
548 (do ((arg-index 0 (+ arg-index 1)))
549 ((= arg-index num-args))
550 (let search-delegates ((delegates (list (vector-ref args arg-index)))
551 (delegation-depth 0))
552 (unless (null? delegates)
553 (let* ((maybe-primitive-delegate (car delegates))
554 (delegate (let ((d maybe-primitive-delegate))
555 (ensure-object-var/traits d)
556 d))
557 (remaining-delegates (cdr delegates))
558 (delegate-layout (object-layout delegate))
559 (selected-slot (layout-ref delegate-layout selector #f)))
560 ; (debug 1 --> 0 "Inspecting "maybe-primitive-delegate" resolving to "delegate)
561 ; (debug 6 --> 0 "Inspecting "(DEBUG-id delegate)
562 ; " slot "selected-slot" depth "delegation-depth" arg index "arg-index)
563 (when selected-slot
564 (for-each (lambda (role)
565 (when (role-active-at-position? role arg-index)
566 (let* ((method (role-method role))
567 (rankvec0 (rank-vector-for method *max-rank-vector*))
568 (rankvec (rank-vector-update
569 rankvec0 delegation-depth arg-index))
570 (positions0 (hash-table-ref
571 candidate-status method *empty-bitset*))
572 (positions (set-bit positions0 arg-index)))
573 (hash-table-set! rank-table method rankvec)
574 (hash-table-set! candidate-status method positions)
575 (when (and (role-requirements-filled? role positions)
576 (or (not ignored-method)
577 (rank-vector>? rankvec
578 (rank-vector-for ignored-method -1)))
579 (or (not most-specific-method)
580 (rank-vector<? rankvec
581 (rank-vector-for
582 most-specific-method -1))))
583 (cond
584 ((eq? (get-slot method 'accessor) *nil*)
585 (set! accessor-target #f))
586 ((= arg-index 0)
587 (set! accessor-target maybe-primitive-delegate)))
588 (set! most-specific-method method)))))
589 (slot-roles selected-slot)))
590 (layout-for-each delegate-layout
591 (lambda (slot-name slot)
592 (and-let* ((_ (slot-delegating? slot))
593 (new-delegate (vector-ref (object-slots delegate) (slot-index slot)))
594 (_ (not (eq? new-delegate *nil*)))
595 (seen-in-positions (hash-table-ref delegations-seen new-delegate
596 *empty-bitset*))
597 (_ (not (bit-set? seen-in-positions arg-index))))
598 (hash-table-set! delegations-seen new-delegate
599 (set-bit seen-in-positions arg-index))
600 ; (debug 6 --> 0 "Delegating via "slot-name" of "(DEBUG-id delegate)
601 ; " to "(DEBUG-id new-delegate) " at level "delegation-depth" pos "arg-index)
602 (set! remaining-delegates (cons new-delegate remaining-delegates)))))
603 (search-delegates remaining-delegates (+ delegation-depth 1))))))
604 (if most-specific-method
605 (begin
606 (when accessor-target
607 (vector-set! args 0 accessor-target))
608 most-specific-method)
609 #f)))