c559b6199347b0ab7fe31e2fbbeeacdf8bc7aa83
[sbcl.git] / src / pcl / cache.lisp
1 ;;;; the basics of the PCL wrapper cache mechanism
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5
6 ;;;; This software is derived from software originally released by Xerox
7 ;;;; Corporation. Copyright and release statements follow. Later modifications
8 ;;;; to the software are in the public domain and are provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
10 ;;;; information.
11
12 ;;;; copyright information from original PCL sources:
13 ;;;;
14 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
15 ;;;; All rights reserved.
16 ;;;;
17 ;;;; Use and copying of this software and preparation of derivative works based
18 ;;;; upon this software are permitted. Any distribution of this software or
19 ;;;; derivative works must comply with all applicable United States export
20 ;;;; control laws.
21 ;;;;
22 ;;;; This software is made available AS IS, and Xerox Corporation makes no
23 ;;;; warranty about the software, its performance or its conformity to any
24 ;;;; specification.
25
26 ;;;; Note: as of SBCL 1.0.6.3 it is questionable if cache.lisp can
27 ;;;; anymore be considered to be "derived from software originally
28 ;;;; released by Xerox Corporation", as at that time the whole cache
29 ;;;; implementation was essentially redone from scratch.
30
31 (in-package "SB-PCL")
32
33 ;;;; Public API:
34 ;;;;
35 ;;;;   fill-cache
36 ;;;;   probe-cache
37 ;;;;   make-cache
38 ;;;;   map-cache
39 ;;;;   emit-cache-lookup
40 ;;;;   copy-cache
41 ;;;;   hash-table-to-cache
42 ;;;;
43 ;;;; This is a thread and interrupt safe reimplementation loosely
44 ;;;; based on the original PCL cache by Kickzales and Rodrigues,
45 ;;;; as described in "Efficient Method Dispatch in PCL".
46 ;;;;
47 ;;;; * Writes to cache are made atomic using compare-and-swap on
48 ;;;;   wrappers. Wrappers are never moved or deleted after they have
49 ;;;;   been written: to clean them out the cache need to be copied.
50 ;;;;
51 ;;;; * Copying or expanding the cache drops out incomplete and invalid
52 ;;;;   lines.
53 ;;;;
54 ;;;; * Since the cache is used for memoization only we don't need to
55 ;;;;   worry about which of simultaneous replacements (when expanding
56 ;;;;   the cache) takes place: the loosing one will have its work
57 ;;;;   redone later. This also allows us to drop entries when the
58 ;;;;   cache is about to grow insanely huge.
59 ;;;;
60 ;;;; The cache is essentially a specialized hash-table for layouts, used
61 ;;;; for memoization of effective methods, slot locations, and constant
62 ;;;; return values.
63 ;;;;
64 ;;;; Subsequences of the cache vector are called cache lines.
65 ;;;;
66 ;;;; The cache vector uses the symbol SB-PCL::..EMPTY.. as a sentinel
67 ;;;; value, to allow storing NILs in the vector as well.
68
69 (defstruct (cache (:constructor %make-cache)
70                   (:copier %copy-cache))
71   ;; Number of keys the cache uses.
72   (key-count 1 :type (integer 1 (#.call-arguments-limit)))
73   ;; True if we store values in the cache.
74   (value)
75   ;; Number of vector elements a single cache line uses in the vector.
76   ;; This is always a power of two, so that the vector length can be both
77   ;; an exact multiple of this and a power of two.
78   (line-size 1 :type (integer 1 #.most-positive-fixnum))
79   ;; Cache vector, its length is always both a multiple of line-size
80   ;; and a power of two. This is so that we can calculate
81   ;;   (mod index (length vector))
82   ;; using a bitmask.
83   (vector #() :type simple-vector)
84   ;; The bitmask used to calculate (mod (* line-size line-hash) (length vector))).
85   (mask 0 :type fixnum)
86   ;; Current probe-depth needed in the cache.
87   (depth 0 :type index)
88   ;; Maximum allowed probe-depth before the cache needs to expand.
89   (limit 0 :type index))
90
91 (defun compute-cache-mask (vector-length line-size)
92   ;; Since both vector-length and line-size are powers of two, we
93   ;; can compute a bitmask such that
94   ;;
95   ;;  (logand <mask> <combined-layout-hash>)
96   ;;
97   ;; is "morally equal" to
98   ;;
99   ;;  (mod (* <line-size> <combined-layout-hash>) <vector-length>)
100   ;;
101   ;; This is it: (1- vector-length) is #b111... of the approriate size
102   ;; to get the MOD, and (- line-size) gives right the number of zero
103   ;; bits at the low end.
104   (logand (1- vector-length) (- line-size)))
105
106 ;;; The smallest power of two that is equal to or greater then X.
107 (declaim (inline power-of-two-ceiling))
108 (defun power-of-two-ceiling (x)
109   (ash 1 (integer-length (1- x))))
110
111 (defun cache-statistics (cache)
112   (let* ((vector (cache-vector cache))
113          (size (length vector))
114          (line-size (cache-line-size cache))
115          (total-lines (/ size line-size))
116          (free-lines (loop for i from 0 by line-size below size
117                            unless (eq (svref vector i) '..empty..)
118                            count t)))
119     (values (- total-lines free-lines) total-lines
120             (cache-depth cache) (cache-limit cache))))
121
122 ;;; Don't allocate insanely huge caches: this is 4096 lines for a
123 ;;; value cache with 8-15 keys -- probably "big enough for anyone",
124 ;;; and 16384 lines for a commonplace 2-key value cache.
125 (defconstant +cache-vector-max-length+ (expt 2 16))
126
127 ;;; Compute the maximum allowed probe depth as a function of cache size.
128 ;;; Cache size refers to number of cache lines, not the length of the
129 ;;; cache vector.
130 ;;;
131 ;;; FIXME: It would be nice to take the generic function optimization
132 ;;; policy into account here (speed vs. space.)
133 (declaim (inline compute-limit))
134 (defun compute-limit (size)
135   (ceiling (sqrt (sqrt size))))
136
137 ;;; Returns VALUE if it is not ..EMPTY.., otherwise executes ELSE:
138 (defmacro non-empty-or (value else)
139   (with-unique-names (n-value)
140     `(let ((,n-value ,value))
141        (if (eq ,n-value '..empty..)
142            ,else
143            ,n-value))))
144
145 ;;; Fast way to check if a thing found at the position of a cache key is one:
146 ;;; it is always either a wrapper, or the ..EMPTY.. symbol.
147 (declaim (inline cache-key-p))
148 (defun cache-key-p (thing)
149   (not (symbolp thing)))
150
151 (eval-when (:compile-toplevel :load-toplevel :execute)
152   (sb-kernel:define-structure-slot-compare-and-swap compare-and-swap-cache-depth
153       :structure cache
154       :slot depth))
155
156 ;;; Utility macro for atomic updates without locking... doesn't
157 ;;; do much right now, and it would be nice to make this more magical.
158 (defmacro compare-and-swap (place old new)
159   (unless (consp place)
160     (error "Don't know how to compare and swap ~S." place))
161   (ecase (car place)
162     (svref
163      `(simple-vector-compare-and-swap ,@(cdr place) ,old ,new))
164     (cache-depth
165      `(compare-and-swap-cache-depth ,@(cdr place) ,old ,new))))
166
167 ;;; Atomically update the current probe depth of a cache.
168 (defun note-cache-depth (cache depth)
169   (loop for old = (cache-depth cache)
170         while (and (< old depth)
171                    (not (eq old (compare-and-swap (cache-depth cache)
172                                                   old depth))))))
173
174 ;;; Compute the starting index of the next cache line in the cache vector.
175 (declaim (inline next-cache-index))
176 (defun next-cache-index (mask index line-size)
177   (logand mask (+ index line-size)))
178
179 ;;; Returns the hash-value for layout, or executes ELSE if the layout
180 ;;; is invalid.
181 (defmacro hash-layout-or (layout else)
182   (with-unique-names (n-hash)
183     `(let ((,n-hash (layout-clos-hash ,layout)))
184        (if (zerop ,n-hash)
185            ,else
186            ,n-hash))))
187
188 ;;; Compute cache index for the cache and a list of layouts.
189 (declaim (inline compute-cache-index))
190 (defun compute-cache-index (cache layouts)
191   (let ((index (hash-layout-or (car layouts)
192                                (return-from compute-cache-index nil))))
193     (declare (fixnum index))
194     (dolist (layout (cdr layouts))
195       (mixf index (hash-layout-or layout (return-from compute-cache-index nil))))
196     ;; align with cache lines
197     (logand index (cache-mask cache))))
198
199 ;;; Emit code that does lookup in cache bound to CACHE-VAR using
200 ;;; layouts bound to LAYOUT-VARS. Go to MISS-TAG on event of a miss or
201 ;;; invalid layout. Otherwise, if VALUE-VAR is non-nil, set it to the
202 ;;; value found. (VALUE-VAR is non-nil only when CACHE-VALUE is true.)
203 ;;;
204 ;;; In other words, produces inlined code for COMPUTE-CACHE-INDEX when
205 ;;; number of keys and presence of values in the cache is known
206 ;;; beforehand.
207 (defun emit-cache-lookup (cache-var layout-vars miss-tag value-var)
208   (let ((line-size (power-of-two-ceiling (+ (length layout-vars)
209                                             (if value-var 1 0)))))
210     (with-unique-names (n-index n-vector n-depth n-pointer n-mask
211                        MATCH-WRAPPERS EXIT-WITH-HIT)
212       `(let* ((,n-index (hash-layout-or ,(car layout-vars) (go ,miss-tag)))
213               (,n-vector (cache-vector ,cache-var))
214               (,n-mask (cache-mask ,cache-var)))
215          (declare (index ,n-index))
216          ,@(mapcar (lambda (layout-var)
217                      `(mixf ,n-index (hash-layout-or ,layout-var (go ,miss-tag))))
218                    (cdr layout-vars))
219          ;; align with cache lines
220          (setf ,n-index (logand ,n-index ,n-mask))
221          (let ((,n-depth (cache-depth ,cache-var))
222                (,n-pointer ,n-index))
223            (declare (index ,n-depth ,n-pointer))
224            (tagbody
225             ,MATCH-WRAPPERS
226               (when (and ,@(mapcar
227                             (lambda (layout-var)
228                               `(prog1
229                                    (eq ,layout-var (svref ,n-vector ,n-pointer))
230                                  (incf ,n-pointer)))
231                             layout-vars))
232                 ,@(when value-var
233                     `((setf ,value-var (non-empty-or (svref ,n-vector ,n-pointer)
234                                                      (go ,miss-tag)))))
235                 (go ,EXIT-WITH-HIT))
236               (if (zerop ,n-depth)
237                   (go ,miss-tag)
238                   (decf ,n-depth))
239               (setf ,n-index (next-cache-index ,n-mask ,n-index ,line-size)
240                     ,n-pointer ,n-index)
241               (go ,MATCH-WRAPPERS)
242             ,EXIT-WITH-HIT))))))
243
244 ;;; Probes CACHE for LAYOUTS.
245 ;;;
246 ;;; Returns two values: a boolean indicating a hit or a miss, and a secondary
247 ;;; value that is the value that was stored in the cache if any.
248 (defun probe-cache (cache layouts)
249   (unless (consp layouts)
250     (setf layouts (list layouts)))
251   (let ((vector (cache-vector cache))
252         (key-count (cache-key-count cache))
253         (line-size (cache-line-size cache))
254         (mask (cache-mask cache)))
255     (flet ((probe-line (base)
256              (tagbody
257                 (loop for offset from 0 below key-count
258                       for layout in layouts do
259                       (unless (eq layout (svref vector (+ base offset)))
260                         ;; missed
261                         (go :miss)))
262                 ;; all layouts match!
263                 (let ((value (when (cache-value cache)
264                                (non-empty-or (svref vector (+ base key-count))
265                                              (go :miss)))))
266                   (return-from probe-cache (values t value)))
267               :miss
268                 (return-from probe-line (next-cache-index mask base line-size)))))
269       (let ((index (compute-cache-index cache layouts)))
270         (when index
271           (loop repeat (1+ (cache-depth cache)) do
272                 (setf index (probe-line index)))))))
273   (values nil nil))
274
275 ;;; Tries to write LAYOUTS and VALUE at the cache line starting at
276 ;;; the index BASE. Returns true on success, and false on failure.
277 (defun try-update-cache-line (cache base layouts value)
278   (declare (index base))
279   (let ((vector (cache-vector cache))
280         (new (pop layouts)))
281     ;; If we unwind from here, we will be left with an incomplete
282     ;; cache line, but that is OK: next write using the same layouts
283     ;; will fill it, and reads will treat an incomplete line as a
284     ;; miss -- causing it to be filled.
285     (loop for old = (compare-and-swap (svref vector base) '..empty.. new)  do
286           (when (and (cache-key-p old) (not (eq old new)))
287             ;; The place was already taken, and doesn't match our key.
288             (return-from try-update-cache-line nil))
289           (unless layouts
290             ;; All keys match or succesfully saved, save our value --
291             ;; just smash it in. Until the first time it is written
292             ;; there is ..EMPTY.. here, which probes look for, so we
293             ;; don't get bogus hits. This is necessary because we want
294             ;; to be able store arbitrary values here for use with
295             ;; constant-value dispatch functions.
296             (when (cache-value cache)
297               (setf (svref vector (1+ base)) value))
298             (return-from try-update-cache-line t))
299           (setf new (pop layouts))
300           (incf base))))
301
302 ;;; Tries to write LAYOUTS and VALUE somewhere in the cache. Returns
303 ;;; true on success and false on failure, meaning the cache is too
304 ;;; full.
305 (defun try-update-cache (cache layouts value)
306   (let ((vector (cache-vector cache))
307         (index (or (compute-cache-index cache layouts)
308                    ;; At least one of the layouts was invalid: just
309                    ;; pretend we updated the cache, and let the next
310                    ;; read pick up the mess.
311                    (return-from try-update-cache t)))
312         (line-size (cache-line-size cache))
313         (mask (cache-mask cache)))
314     (declare (index index))
315     (loop for depth from 0 upto (cache-limit cache) do
316           (when (try-update-cache-line cache index layouts value)
317             (note-cache-depth cache depth)
318             (return-from try-update-cache t))
319           (setf index (next-cache-index mask index line-size)))))
320
321 ;;; Constructs a new cache.
322 (defun make-cache (&key (key-count (missing-arg)) (value (missing-arg))
323                    (size 1))
324   (let* ((line-size (power-of-two-ceiling (+ key-count (if value 1 0))))
325          (adjusted-size (power-of-two-ceiling size))
326          (length (* adjusted-size line-size)))
327     (if (<= length +cache-vector-max-length+)
328         (%make-cache :key-count key-count
329                      :line-size line-size
330                      :vector (make-array length :initial-element '..empty..)
331                      :value value
332                      :mask (compute-cache-mask length line-size)
333                      :limit (compute-limit adjusted-size))
334         ;; Make a smaller one, then
335         (make-cache :key-count key-count :value value :size (ceiling size 2)))))
336
337 ;;;; Copies and expands the cache, dropping any invalidated or
338 ;;;; incomplete lines.
339 (defun copy-and-expand-cache (cache)
340   (let ((copy (%copy-cache cache))
341         (length (length (cache-vector cache))))
342     (when (< length +cache-vector-max-length+)
343       (setf length (* 2 length)))
344     (tagbody
345      :again
346        ;; Blow way the old vector first, so a GC potentially triggered by
347        ;; MAKE-ARRAY can collect it.
348        (setf (cache-vector copy) #()
349              (cache-vector copy) (make-array length :initial-element '..empty..)
350              (cache-depth copy) 0
351              (cache-mask copy) (compute-cache-mask length (cache-line-size cache))
352              (cache-limit copy) (compute-limit (/ length (cache-line-size cache))))
353        (map-cache (lambda (layouts value)
354                     (unless (try-update-cache copy layouts value)
355                       ;; If the cache would grow too much we drop the
356                       ;; remaining the entries that don't fit. FIXME:
357                       ;; It would be better to drop random entries to
358                       ;; avoid getting into a rut here (best done by
359                       ;; making MAP-CACHE map in a random order?), and
360                       ;; possibly to downsize the cache more
361                       ;; aggressively (on the assumption that most
362                       ;; entries aren't getting used at the moment.)
363                       (when (< length +cache-vector-max-length+)
364                         (setf length (* 2 length))
365                         (go :again))))
366                   cache))
367     copy))
368
369 (defun cache-has-invalid-entries-p (cache)
370   (let ((vector (cache-vector cache))
371         (line-size (cache-line-size cache))
372         (key-count (cache-key-count cache))
373         (mask (cache-mask cache))
374         (index 0))
375     (loop
376       ;; Check if the line is in use, and check validity of the keys.
377       (let ((key1 (svref vector index)))
378         (when (cache-key-p key1)
379           (if (zerop (layout-clos-hash key1))
380               ;; First key invalid.
381               (return-from cache-has-invalid-entries-p t)
382               ;; Line is in use and the first key is valid: check the rest.
383               (loop for offset from 1 below key-count
384                     do (let ((thing (svref vector (+ index offset))))
385                          (when (or (not (cache-key-p thing))
386                                    (zerop (layout-clos-hash thing)))
387                            ;; Incomplete line or invalid layout.
388                            (return-from cache-has-invalid-entries-p t)))))))
389       ;; Line empty of valid, onwards.
390       (setf index (next-cache-index mask index line-size))
391       (when (zerop index)
392         ;; wrapped around
393         (return-from cache-has-invalid-entries-p nil)))))
394
395 (defun hash-table-to-cache (table &key value key-count)
396   (let ((cache (make-cache :key-count key-count :value value
397                            :size (hash-table-count table))))
398     (maphash (lambda (class value)
399                (setq cache (fill-cache cache (class-wrapper class) value)))
400              table)
401     cache))
402
403 ;;; Inserts VALUE to CACHE keyd by LAYOUTS. Expands the cache if
404 ;;; necessary, and returns the new cache.
405 (defun fill-cache (cache layouts value)
406   (labels
407       ((%fill-cache (cache layouts value)
408          (cond ((try-update-cache cache layouts value)
409                 cache)
410                ((cache-has-invalid-entries-p cache)
411                 ;; Don't expand yet: maybe there will be enough space if
412                 ;; we just drop the invalid entries.
413                 (%fill-cache (copy-cache cache) layouts value))
414                (t
415                 (%fill-cache (copy-and-expand-cache cache) layouts value)))))
416     (if (listp layouts)
417         (%fill-cache cache layouts value)
418         (%fill-cache cache (list layouts) value))))
419
420 ;;; Calls FUNCTION with all layouts and values in cache.
421 (defun map-cache (function cache)
422   (let* ((vector (cache-vector cache))
423          (key-count (cache-key-count cache))
424          (valuep (cache-value cache))
425          (line-size (cache-line-size cache))
426          (mask (cache-mask cache))
427          (fun (if (functionp function)
428                   function
429                   (fdefinition function)))
430          (index 0)
431          (key nil))
432     (tagbody
433      :map
434        (let ((layouts
435               (loop for offset from 0 below key-count
436                     collect (non-empty-or (svref vector (+ offset index))
437                                           (go :next)))))
438          (let ((value (when valuep
439                         (non-empty-or (svref vector (+ index key-count))
440                                       (go :next)))))
441            ;; Let the callee worry about invalid layouts
442            (funcall fun layouts value)))
443      :next
444        (setf index (next-cache-index mask index line-size))
445        (unless (zerop index)
446          (go :map))))
447   cache)
448
449 ;;; Copying a cache without expanding it is very much like mapping it:
450 ;;; we need to be carefull because there may be updates while we are
451 ;;; copying it, and we don't want to copy incomplete entries or invalid
452 ;;; ones.
453 (defun copy-cache (cache)
454   (let* ((vector (cache-vector cache))
455          (copy (make-array (length vector) :initial-element '..empty..))
456          (line-size (cache-line-size cache))
457          (key-count (cache-key-count cache))
458          (valuep (cache-value cache))
459          (mask (cache-mask cache))
460          (size (/ (length vector) line-size))
461          (index 0)
462          (elt nil)
463          (depth 0))
464     (tagbody
465      :copy
466        (let ((layouts (loop for offset from 0 below key-count
467                             collect (non-empty-or (svref vector (+ index offset))
468                                                   (go :next)))))
469          ;; Check validity & compute primary index.
470          (let ((primary (or (compute-cache-index cache layouts)
471                             (go :next))))
472            ;; Check & copy value.
473            (when valuep
474              (setf (svref copy (+ index key-count))
475                    (non-empty-or (svref vector (+ index key-count))
476                                  (go :next))))
477            ;; Copy layouts.
478            (loop for offset from 0 below key-count do
479                  (setf (svref copy (+ index offset)) (pop layouts)))
480            ;; Update probe depth.
481            (let ((distance (/ (- index primary) line-size)))
482              (setf depth (max depth (if (minusp distance)
483                                         ;; account for wrap-around
484                                         (+ distance size)
485                                         distance))))))
486      :next
487        (setf index (next-cache-index mask index line-size))
488        (unless (zerop index)
489          (go :copy)))
490     (%make-cache :vector copy
491                  :depth depth
492                  :key-count (cache-key-count cache)
493                  :line-size line-size
494                  :value valuep
495                  :mask mask
496                  :limit (cache-limit cache))))
497
498 ;;;; For debugging & collecting statistics.
499
500 (defun map-all-caches (function)
501   (dolist (p (list-all-packages))
502     (do-symbols (s p)
503       (when (eq p (symbol-package s))
504         (dolist (name (list s
505                             `(setf ,s)
506                             (slot-reader-name s)
507                             (slot-writer-name s)
508                             (slot-boundp-name s)))
509           (when (fboundp name)
510             (let ((fun (fdefinition name)))
511               (when (typep fun 'generic-function)
512                 (let ((cache (gf-dfun-cache fun)))
513                   (when cache
514                     (funcall function name cache)))))))))))
515
516 (defun check-cache-consistency (cache)
517   (let ((table (make-hash-table :test 'equal)))
518     (map-cache (lambda (layouts value)
519                  (declare (ignore value))
520                  (if (gethash layouts table)
521                      (cerror "Check futher."
522                              "Multiple appearances of ~S." layouts)
523                      (setf (gethash layouts table) t)))
524                cache)))