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