1 2(library (clos private fast-method-cache) 3 4 (export invalidate-method-caches! 5 make-cached-dispatch) 6 7 (import (ikarus) 8 (ikarus system $pairs) 9 (ikarus system $vectors) 10 (ikarus system $fx) 11 (clos introspection) 12 (clos bootstrap standard-classes)) 13 14 (define *cache-token* (list 'token)) 15 16 (define (invalidate-method-caches!) 17 (set! *cache-token* (list 'token))) 18 19 (define *min-cache-size* 64) 20 21 (define (max-specializer-count generic) 22 (apply max (map (lambda (method) 23 (length (method-specializers method))) 24 (generic-methods generic)))) 25 26 (define (compute-start-index class) 27 ($fxlogand (pointer-value class) ($fx- *min-cache-size* 1))) 28 29 (define (make-cached-dispatch generic handle-cache-miss) 30 (let* ((spec-count (max-specializer-count generic)) 31 (table-size (+ *min-cache-size* spec-count 1)) 32 (table (make-vector table-size #f))) 33 (lambda (args) 34 (if (or (null? args) 35 ($fx= spec-count 0)) 36 (let ((token ($vector-ref table 0)) 37 (proc ($vector-ref table 1))) 38 (or (and (eq? token *cache-token*) (procedure? proc) proc) 39 (let ((proc (handle-cache-miss args))) 40 ($vector-set! table 0 *cache-token*) 41 ($vector-set! table 1 proc) 42 proc))) 43 (let* ((class (class-of ($car args))) 44 (start (compute-start-index class))) 45 (or (and (eq? ($vector-ref table start) *cache-token*) 46 (let loop ((table table) 47 (limit ($fx+ start spec-count)) 48 (index ($fx+ start 1)) 49 (class class) 50 (tail (cdr args))) 51 (and (eq? ($vector-ref table index) class) 52 (if (or ($fx= index limit) 53 (null? tail)) 54 (let ((proc 55 (vector-ref table ($fx+ index 1)))) 56 (and (procedure? proc) proc)) 57 (loop table 58 limit 59 ($fx+ index 1) 60 (class-of ($car tail)) 61 ($cdr tail)))))) 62 (let ((proc (handle-cache-miss args))) 63 (fix-table! table start ($fx+ start spec-count) args proc) 64 proc))))))) 65 66 (define (fix-table! table start limit args proc) 67 (let loop ((table table) 68 (index start) 69 (limit limit) 70 (proc proc) 71 (value *cache-token*) 72 (args args)) 73 ($vector-set! table index value) 74 (if (or (null? args) 75 ($fx= index limit)) 76 ($vector-set! table ($fx+ index 1) proc) 77 (loop table 78 ($fx+ index 1) 79 limit 80 proc 81 (class-of ($car args)) 82 ($cdr args))))) 83 84 ) ;; (clos private fast-method-cache) 85