diff options
-rw-r--r-- | module/oop/goops/dispatch.scm | 34 |
1 files changed, 15 insertions, 19 deletions
diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm index 93fdf98af..a54044729 100644 --- a/module/oop/goops/dispatch.scm +++ b/module/oop/goops/dispatch.scm @@ -185,28 +185,24 @@ sum) (set! sum (+ sum (struct-ref (car classes) hashset-index)))))) -;;; FIXME: the throw probably is expensive, given that this function -;;; might be called an average of 3 or 4 times per rehash... (define (cache-try-hash! min-misses hashset cache entries) (let ((max-misses 0) (mask (- (vector-length cache) 1))) - (catch 'misses - (lambda () - (do ((ls entries (cdr ls)) - (misses 0 0)) - ((null? ls) max-misses) - (do ((i (logand mask (cache-hashval hashset (car ls))) - (logand mask (+ i 1)))) - ((and (pair? (vector-ref cache i)) - (eq? (car (vector-ref cache i)) 'no-method)) - (vector-set! cache i (car ls))) - (set! misses (+ 1 misses)) - (if (>= misses min-misses) - (throw 'misses misses))) - (if (> misses max-misses) - (set! max-misses misses)))) - (lambda (key misses) - misses)))) + (let outer ((in entries) (max-misses 0)) + (if (null? in) + max-misses + (let inner ((i (logand mask (cache-hashval hashset (car in)))) + (misses 0)) + (cond + ((and (pair? (vector-ref cache i)) + (eq? (car (vector-ref cache i)) 'no-method)) + (vector-set! cache i (car in)) + (outer (cdr in) (if (> misses max-misses) misses max-misses))) + (else + (let ((misses (+ 1 misses))) + (if (>= misses min-misses) + misses ;; this is a return, yo. + (inner (logand mask (+ i 1)) misses)))))))))) ;;; ;;; Memoization |