1 ;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006 Free Software Foundation, Inc.
3 ;;;; This library is free software; you can redistribute it and/or
4 ;;;; modify it under the terms of the GNU Lesser General Public
5 ;;;; License as published by the Free Software Foundation; either
6 ;;;; version 2.1 of the License, or (at your option) any later version.
8 ;;;; This library is distributed in the hope that it will be useful,
9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 ;;;; Lesser General Public License for more details.
13 ;;;; You should have received a copy of the GNU Lesser General Public
14 ;;;; License along with this library; if not, write to the Free Software
15 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19 ;; There are circularities here; you can't import (oop goops compile)
20 ;; before (oop goops). So when compiling, make sure that things are
22 (eval-when (compile) (resolve-module '(oop goops)))
24 (define-module (oop goops dispatch)
25 :use-module (oop goops)
26 :use-module (oop goops util)
27 :use-module (oop goops compile)
28 :export (memoize-method!)
33 ;;; This file implements method memoization. It will finally be
34 ;;; implemented on C level in order to obtain fast generic function
35 ;;; application also during the first pass through the code.
43 (define hashset-index 6)
45 (define hash-threshold 3)
46 (define initial-hash-size 4) ;must be a power of 2 and >= hash-threshold
48 (define initial-hash-size-1 (- initial-hash-size 1))
50 (define the-list-of-no-method '(no-method))
56 ;; (#@dispatch args N-SPECIALIZED #((TYPE1 ... ENV FORMALS FORM1 ...) ...) GF)
57 ;; (#@dispatch args N-SPECIALIZED HASHSET MASK
58 ;; #((TYPE1 ... ENV FORMALS FORM1 ...) ...)
65 (define method-cache-entries cadddr)
67 (define (set-method-cache-entries! mcache entries)
68 (set-car! (cdddr mcache) entries))
70 (define (method-cache-n-methods exp)
71 (n-cache-methods (method-cache-entries exp)))
73 (define (method-cache-methods exp)
74 (cache-methods (method-cache-entries exp)))
78 (define (set-hashed-method-cache-hashset! exp hashset)
79 (set-car! (cdddr exp) hashset))
81 (define (set-hashed-method-cache-mask! exp mask)
82 (set-car! (cddddr exp) mask))
84 (define (hashed-method-cache-entries exp)
87 (define (set-hashed-method-cache-entries! exp entries)
88 (set-car! (list-cdr-ref exp 5) entries))
92 (define (method-cache-generic-function exp)
93 (list-ref exp (if (method-cache-hashed? exp) 6 4)))
97 (define (method-cache-hashed? x)
98 (integer? (cadddr x)))
100 (define max-non-hashed-index (- hash-threshold 2))
102 (define (passed-hash-threshold? exp)
103 (and (> (vector-length (method-cache-entries exp)) max-non-hashed-index)
104 (struct? (car (vector-ref (method-cache-entries exp)
105 max-non-hashed-index)))))
107 ;;; Converting a method cache to hashed form
109 (define (method-cache->hashed! exp)
110 (set-cdr! (cddr exp) (cons 0 (cons initial-hash-size-1 (cdddr exp))))
117 (define (n-cache-methods entries)
118 (do ((i (- (vector-length entries) 1) (- i 1)))
119 ((or (< i 0) (struct? (car (vector-ref entries i))))
122 (define (cache-methods entries)
123 (do ((i (- (vector-length entries) 1) (- i 1))
124 (methods '() (let ((entry (vector-ref entries i)))
125 (if (or (not (pair? entry)) (struct? (car entry)))
134 (define (method-cache-insert! exp entry)
135 (let* ((entries (method-cache-entries exp))
136 (n (n-cache-methods entries)))
137 (if (>= n (vector-length entries))
139 (let ((new-entries (make-vector (* 2 (vector-length entries))
140 the-list-of-no-method)))
143 (vector-set! new-entries i (vector-ref entries i)))
144 (vector-set! new-entries n entry)
145 (set-method-cache-entries! exp new-entries))
146 (vector-set! entries n entry))))
148 (define (hashed-method-cache-insert! exp entry)
149 (let* ((cache (hashed-method-cache-entries exp))
150 (size (vector-length cache)))
151 (let* ((entries (cons entry (cache-methods cache)))
152 (size (if (<= (length entries) size)
154 ;; larger size required
155 (let ((new-size (* 2 size)))
156 (set-hashed-method-cache-mask! exp (- new-size 1))
160 (do ((hashset 0 (+ 1 hashset)))
161 ((= hashset hashsets))
162 (let* ((test-cache (make-vector size the-list-of-no-method))
163 (misses (cache-try-hash! min-misses hashset test-cache entries)))
164 (cond ((zero? misses)
167 (set! cache test-cache)
168 (set! hashset (- hashsets 1)))
169 ((< misses min-misses)
170 (set! min-misses misses)
172 (set! cache test-cache)))))
173 (set-hashed-method-cache-hashset! exp best)
174 (set-hashed-method-cache-entries! exp cache))))
180 (define (cache-hashval hashset entry)
181 (let ((hashset-index (+ hashset-index hashset)))
183 (classes entry (cdr classes)))
184 ((not (and (pair? classes) (struct? (car classes))))
186 (set! sum (+ sum (struct-ref (car classes) hashset-index))))))
188 ;;; FIXME: the throw probably is expensive, given that this function
189 ;;; might be called an average of 3 or 4 times per rehash...
190 (define (cache-try-hash! min-misses hashset cache entries)
192 (mask (- (vector-length cache) 1)))
195 (do ((ls entries (cdr ls))
197 ((null? ls) max-misses)
198 (do ((i (logand mask (cache-hashval hashset (car ls)))
199 (logand mask (+ i 1))))
200 ((and (pair? (vector-ref cache i))
201 (eq? (car (vector-ref cache i)) 'no-method))
202 (vector-set! cache i (car ls)))
203 (set! misses (+ 1 misses))
204 (if (>= misses min-misses)
205 (throw 'misses misses)))
206 (if (> misses max-misses)
207 (set! max-misses misses))))
215 ;; Backward compatibility
216 (if (not (defined? 'lookup-create-cmethod))
217 (define (lookup-create-cmethod gf args)
218 (no-applicable-method (car args) (cadr args))))
220 (define (memoize-method! gf args exp)
221 (if (not (slot-ref gf 'used-by))
222 (slot-set! gf 'used-by '()))
223 (let ((applicable ((if (eq? gf compute-applicable-methods)
224 %compute-applicable-methods
225 compute-applicable-methods)
228 ;; *fixme* dispatch.scm needs rewriting Since the current
229 ;; code mutates the method cache, we have to work on a
230 ;; copy. Otherwise we might disturb another thread
231 ;; currently dispatching on the cache. (No need to copy
233 (let* ((new (list-copy exp))
235 (cond ((method-cache-hashed? new)
236 (method-cache-install! hashed-method-cache-insert!
237 new args applicable))
238 ((passed-hash-threshold? new)
239 (method-cache-install! hashed-method-cache-insert!
240 (method-cache->hashed! new)
244 (method-cache-install! method-cache-insert!
245 new args applicable)))))
246 (set-cdr! (cdr exp) (cddr new))
249 (lookup-create-cmethod no-applicable-method (list gf '())))
251 ;; Mutate arglist to fit no-applicable-method
252 (set-cdr! args (list (cons (car args) (cdr args))))
254 (lookup-create-cmethod no-applicable-method args)))))
256 (set-procedure-property! memoize-method! 'system-procedure #t)
258 (define method-cache-install!
261 (if (or (zero? n) (null? ls))
263 (cons (car ls) (first-n (cdr ls) (- n 1)))))))
264 (lambda (insert! exp args applicable)
265 (let* ((specializers (method-specializers (car applicable)))
267 (if (list? specializers)
268 (length specializers)
269 (+ 1 (slot-ref (method-cache-generic-function exp)
271 (let* ((types (map class-of (first-n args n-specializers)))
272 (cmethod (compute-cmethod applicable types)))
273 (insert! exp (append types cmethod)) ; entry = types + cmethod
274 cmethod))))) ; cmethod