1 ;;;; the basics of the PCL wrapper cache mechanism
3 ;;;; This software is part of the SBCL system. See the README file for
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
12 ;;;; copyright information from original PCL sources:
14 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
15 ;;;; All rights reserved.
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
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
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.
39 ;;;; emit-cache-lookup
41 ;;;; hash-table-to-cache
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".
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.
51 ;;;; * Copying or expanding the cache drops out incomplete and invalid
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 losing 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.
60 ;;;; The cache is essentially a specialized hash-table for layouts, used
61 ;;;; for memoization of effective methods, slot locations, and constant
64 ;;;; Subsequences of the cache vector are called cache lines.
66 ;;;; The cache vector uses the symbol SB-PCL::..EMPTY.. as a sentinel
67 ;;;; value, to allow storing NILs in the vector as well.
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.
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))
83 (vector #() :type simple-vector
)
84 ;; The bitmask used to calculate
85 ;; (mod (* line-size line-hash) (length vector))).
87 ;; Current probe-depth needed in the cache.
89 ;; Maximum allowed probe-depth before the cache needs to expand.
90 (limit 0 :type index
))
92 (defun compute-cache-mask (vector-length line-size
)
93 ;; Since both vector-length and line-size are powers of two, we
94 ;; can compute a bitmask such that
96 ;; (logand <mask> <combined-layout-hash>)
98 ;; is "morally equal" to
100 ;; (mod (* <line-size> <combined-layout-hash>) <vector-length>)
102 ;; This is it: (1- vector-length) is #b111... of the approriate size
103 ;; to get the MOD, and (- line-size) gives right the number of zero
104 ;; bits at the low end.
105 (logand (1- vector-length
) (- line-size
)))
107 (defun cache-statistics (cache)
108 (let* ((vector (cache-vector cache
))
109 (size (length vector
))
110 (line-size (cache-line-size cache
))
111 (total-lines (/ size line-size
)))
112 (values (loop for i from
0 by line-size below size
113 count
(neq (svref vector i
) '..empty..
))
114 total-lines
(cache-depth cache
) (cache-limit cache
))))
116 ;;; Don't allocate insanely huge caches: this is 4096 lines for a
117 ;;; value cache with 8-15 keys -- probably "big enough for anyone",
118 ;;; and 16384 lines for a commonplace 2-key value cache.
119 (defconstant +cache-vector-max-length
+ (expt 2 16))
121 ;;; Compute the maximum allowed probe depth as a function of cache size.
122 ;;; Cache size refers to number of cache lines, not the length of the
125 ;;; FIXME: It would be nice to take the generic function optimization
126 ;;; policy into account here (speed vs. space.)
127 (declaim (inline compute-limit
))
128 (defun compute-limit (size)
129 (ceiling (sqrt (sqrt size
))))
131 ;;; Returns VALUE if it is not ..EMPTY.., otherwise executes ELSE:
132 (defmacro non-empty-or
(value else
)
133 (with-unique-names (n-value)
134 `(let ((,n-value
,value
))
135 (if (eq ,n-value
'..empty..
)
139 ;;; Fast way to check if a thing found at the position of a cache key is one:
140 ;;; it is always either a wrapper, or the ..EMPTY.. symbol.
141 (declaim (inline cache-key-p
))
142 (defun cache-key-p (thing)
143 (not (symbolp thing
)))
145 ;;; Atomically update the current probe depth of a cache.
146 (defun note-cache-depth (cache depth
)
147 (loop for old
= (cache-depth cache
)
148 while
(and (< old depth
)
149 (not (eq old
(compare-and-swap (cache-depth cache
)
152 ;;; Compute the starting index of the next cache line in the cache vector.
153 (declaim (inline next-cache-index
))
154 (defun next-cache-index (mask index line-size
)
155 (declare (type (unsigned-byte #.sb-vm
:n-word-bits
) index line-size mask
))
156 (logand mask
(+ index line-size
)))
158 ;;; Returns the hash-value for layout, or executes ELSE if the layout
160 (defmacro hash-layout-or
(layout else
)
161 (with-unique-names (n-hash)
162 `(let ((,n-hash
(layout-clos-hash ,layout
)))
167 ;;; Compute cache index for the cache and a list of layouts.
168 (declaim (inline compute-cache-index
))
169 (defun compute-cache-index (cache layouts
)
170 (let ((index (hash-layout-or (car layouts
)
171 (return-from compute-cache-index nil
))))
172 (declare (fixnum index
))
173 (dolist (layout (cdr layouts
))
174 (mixf index
(hash-layout-or layout
(return-from compute-cache-index nil
))))
175 ;; align with cache lines
176 (logand index
(cache-mask cache
))))
178 ;;; Emit code that does lookup in cache bound to CACHE-VAR using
179 ;;; layouts bound to LAYOUT-VARS. Go to MISS-TAG on event of a miss or
180 ;;; invalid layout. Otherwise, if VALUE-VAR is non-nil, set it to the
181 ;;; value found. (VALUE-VAR is non-nil only when CACHE-VALUE is true.)
183 ;;; In other words, produces inlined code for COMPUTE-CACHE-INDEX when
184 ;;; number of keys and presence of values in the cache is known
186 (defun emit-cache-lookup (cache-var layout-vars miss-tag value-var
)
187 (declare (muffle-conditions code-deletion-note
))
188 (with-unique-names (probe n-vector n-depth n-mask
189 MATCH-WRAPPERS EXIT-WITH-HIT
)
190 (let* ((num-keys (length layout-vars
))
192 ;; We don't need POINTER if the cache has 1 key and no value,
193 ;; or if FOLD-INDEX-ADDRESSING is supported, in which case adding
194 ;; a constant to the base index for each cell-ref yields better code.
196 (when (or (> num-keys
1) value-var
) (make-symbol "PTR")))
197 (line-size (power-of-two-ceiling (+ num-keys
(if value-var
1 0)))))
198 `(let ((,n-mask
(cache-mask ,cache-var
))
199 (,probe
(hash-layout-or ,(car layout-vars
) (go ,miss-tag
))))
200 (declare (index ,probe
))
201 ,@(mapcar (lambda (layout-var)
202 `(mixf ,probe
(hash-layout-or ,layout-var
(go ,miss-tag
))))
204 ;; align with cache lines
205 (setf ,probe
(logand ,probe
,n-mask
))
206 (let ((,n-depth
(cache-depth ,cache-var
))
207 (,n-vector
(cache-vector ,cache-var
))
208 ,@(when pointer
`((,pointer
,probe
))))
209 (declare (index ,n-depth
,@(when pointer
(list pointer
))))
212 (when (and ,@(loop for layout-var in layout-vars
216 `(prog1 (eq ,layout-var
217 (svref ,n-vector
,pointer
))
221 (the index
(+ ,probe
,i
)))))))
224 (non-empty-or (svref ,n-vector
227 (+ ,probe
,num-keys
))))
230 (when (zerop ,n-depth
) (go ,miss-tag
))
232 (setf ,probe
(next-cache-index ,n-mask
,probe
,line-size
))
233 ,@(if pointer
`((setf ,pointer
,probe
)))
237 ;;; Probes CACHE for LAYOUTS.
239 ;;; Returns two values: a boolean indicating a hit or a miss, and a secondary
240 ;;; value that is the value that was stored in the cache if any.
241 (defun probe-cache (cache layouts
)
242 (declare (optimize speed
))
243 (let ((vector (cache-vector cache
))
244 (key-count (cache-key-count cache
))
245 (line-size (cache-line-size cache
))
246 (mask (cache-mask cache
)))
247 (flet ((probe-line (base)
248 (declare (optimize (sb-c::type-check
0)))
250 ;; LAYOUTS can't be the empty list, because COMPUTE-CACHE-INDEX
251 ;; takes its CAR, and would have borked if that weren't a LAYOUT.
252 ;; But perhaps we should figure out when LAYOUTS get passed
253 ;; as an atom, and make it so that doesn't happen?
254 (loop for offset of-type index from
0 below key-count
255 for layout
= (if (listp layouts
) (pop layouts
) (shiftf layouts nil
))
257 unless
(eq layout
(svref vector
(truly-the index
(+ base offset
))))
259 ;; all layouts match!
260 (let ((value (when (cache-value cache
)
261 (non-empty-or (svref vector
(truly-the index
(+ base key-count
)))
263 (return-from probe-cache
(values t value
)))
265 (return-from probe-line
(next-cache-index mask base line-size
)))))
266 (declare (ftype (sfunction (index) index
) probe-line
))
267 (let ((index (if (not (listp layouts
))
268 (let ((hash (layout-clos-hash layouts
)))
269 (unless (zerop hash
) (logand hash mask
)))
270 (compute-cache-index cache layouts
))))
272 (loop repeat
(1+ (cache-depth cache
))
273 do
(setf index
(probe-line index
)))))))
276 ;;; Tries to write LAYOUTS and VALUE at the cache line starting at
277 ;;; the index BASE. Returns true on success, and false on failure.
278 (defun try-update-cache-line (cache base layouts value
)
279 (declare (index base
))
280 (let ((vector (cache-vector cache
))
282 ;; If we unwind from here, we will be left with an incomplete
283 ;; cache line, but that is OK: next write using the same layouts
284 ;; will fill it, and reads will treat an incomplete line as a
285 ;; miss -- causing it to be filled.
286 (loop for old
= (compare-and-swap (svref vector base
) '..empty.. new
) do
287 (when (and (cache-key-p old
) (not (eq old new
)))
288 ;; The place was already taken, and doesn't match our key.
289 (return-from try-update-cache-line nil
))
291 ;; All keys match or successfully saved, save our value --
292 ;; just smash it in. Until the first time it is written
293 ;; there is ..EMPTY.. here, which probes look for, so we
294 ;; don't get bogus hits. This is necessary because we want
295 ;; to be able store arbitrary values here for use with
296 ;; constant-value dispatch functions.
297 (when (cache-value cache
)
298 (setf (svref vector
(1+ base
)) value
))
299 (return-from try-update-cache-line t
))
300 (setf new
(pop layouts
))
303 ;;; Tries to write LAYOUTS and VALUE somewhere in the cache. Returns
304 ;;; true on success and false on failure, meaning the cache is too
306 (defun try-update-cache (cache layouts value
)
307 (let ((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
)))))
321 ;;; Constructs a new cache.
322 (defun make-cache (&key
(key-count (missing-arg)) (value (missing-arg))
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
330 :vector
(make-array length
:initial-element
'..empty..
)
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)))))
337 ;;;; Copies and expands the cache, dropping any invalidated or
338 ;;;; incomplete lines.
339 (defun copy-and-expand-cache (cache layouts value
)
340 (let ((copy (%copy-cache cache
))
341 (length (length (cache-vector cache
)))
342 (drop-random-entries nil
))
343 (declare (index length
))
344 (when (< length
+cache-vector-max-length
+)
345 (setf length
(* 2 length
)))
348 ;; Blow way the old vector first, so a GC potentially triggered by
349 ;; MAKE-ARRAY can collect it.
350 (setf (cache-vector copy
) #()
351 (cache-vector copy
) (make-array length
:initial-element
'..empty..
)
353 (cache-mask copy
) (compute-cache-mask length
(cache-line-size cache
))
354 (cache-limit copy
) (compute-limit (/ length
(cache-line-size cache
))))
355 ;; First insert the new one -- if we don't do this first and
356 ;; the cache has reached its maximum size we may end up looping
358 (unless (try-update-cache copy layouts value
)
359 (bug "Could not insert ~S:~S to supposedly empty ~S." layouts value copy
))
360 (map-cache (if drop-random-entries
361 ;; The cache is at maximum size, and all entries
362 ;; do not fit in. Drop a random ~50% of entries,
363 ;; to make space for new ones. This needs to be
364 ;; random, since otherwise we might get in a
365 ;; rut: add A causing B to drop, then add B
366 ;; causing A to drop... repeat ad nauseam,
367 ;; spending most of the time here instead of
368 ;; doing real work. 50% because if we drop too
369 ;; few we need to do this almost right away
370 ;; again, and if we drop too many, we need to
371 ;; recompute more than we'd like.
372 ;; _Experimentally_ 50% seems to perform the
373 ;; best, but it would be nice to have a proper
375 (randomly-punting-lambda (layouts value
)
376 (try-update-cache copy layouts value
))
377 (lambda (layouts value
)
378 (unless (try-update-cache copy layouts value
)
379 ;; Didn't fit -- expand the cache, or drop
380 ;; a few unlucky ones.
381 (if (< length
+cache-vector-max-length
+)
382 (setf length
(* 2 length
))
383 (setf drop-random-entries t
))
388 (defun cache-has-invalid-entries-p (cache)
389 (let ((vector (cache-vector cache
))
390 (line-size (cache-line-size cache
))
391 (key-count (cache-key-count cache
))
392 (mask (cache-mask cache
))
395 ;; Check if the line is in use, and check validity of the keys.
396 (let ((key1 (svref vector index
)))
397 (when (cache-key-p key1
)
398 (if (zerop (layout-clos-hash key1
))
399 ;; First key invalid.
400 (return-from cache-has-invalid-entries-p t
)
401 ;; Line is in use and the first key is valid: check the rest.
402 (loop for offset from
1 below key-count
403 do
(let ((thing (svref vector
(+ index offset
))))
404 (when (or (not (cache-key-p thing
))
405 (zerop (layout-clos-hash thing
)))
406 ;; Incomplete line or invalid layout.
407 (return-from cache-has-invalid-entries-p t
)))))))
408 ;; Line empty of valid, onwards.
409 (setf index
(next-cache-index mask index line-size
))
412 (return-from cache-has-invalid-entries-p nil
)))))
414 (defun hash-table-to-cache (table &key value key-count
)
415 (let ((cache (make-cache :key-count key-count
:value value
416 :size
(hash-table-count table
))))
417 (maphash (lambda (class value
)
418 (setq cache
(fill-cache cache
(class-wrapper class
) value
)))
422 ;;; Inserts VALUE to CACHE keyd by LAYOUTS. Expands the cache if
423 ;;; necessary, and returns the new cache.
424 (defun fill-cache (cache layouts value
)
426 ((%fill-cache
(cache layouts value expand
)
427 (cond ((try-update-cache cache layouts value
)
429 ((and (not expand
) (cache-has-invalid-entries-p cache
))
430 ;; Don't expand yet: maybe there will be enough space if
431 ;; we just drop the invalid entries.
432 (%fill-cache
(copy-cache cache
) layouts value t
))
434 (copy-and-expand-cache cache layouts value
)))))
435 (%fill-cache cache
(ensure-list layouts
) value nil
)))
437 ;;; Calls FUNCTION with all layouts and values in cache.
438 (defun map-cache (function cache
)
439 (let* ((vector (cache-vector cache
))
440 (key-count (cache-key-count cache
))
441 (valuep (cache-value cache
))
442 (line-size (cache-line-size cache
))
443 (mask (cache-mask cache
))
444 (fun (if (functionp function
)
446 (fdefinition function
)))
451 (loop for offset from
0 below key-count
452 collect
(non-empty-or (svref vector
(+ offset index
))
454 (let ((value (when valuep
455 (non-empty-or (svref vector
(+ index key-count
))
457 ;; Let the callee worry about invalid layouts
458 (funcall fun layouts value
)))
460 (setf index
(next-cache-index mask index line-size
))
461 (unless (zerop index
)
465 ;;; Copying a cache without expanding it is very much like mapping it:
466 ;;; we need to be carefull because there may be updates while we are
467 ;;; copying it, and we don't want to copy incomplete entries or invalid
469 (defun copy-cache (cache)
470 (let* ((vector (cache-vector cache
))
471 (copy (make-array (length vector
) :initial-element
'..empty..
))
472 (line-size (cache-line-size cache
))
473 (key-count (cache-key-count cache
))
474 (valuep (cache-value cache
))
475 (mask (cache-mask cache
))
476 (size (/ (length vector
) line-size
))
481 (let ((layouts (loop for offset from
0 below key-count
482 collect
(non-empty-or (svref vector
(+ index offset
))
484 ;; Check validity & compute primary index.
485 (let ((primary (or (compute-cache-index cache layouts
)
487 ;; Check & copy value.
489 (setf (svref copy
(+ index key-count
))
490 (non-empty-or (svref vector
(+ index key-count
))
493 (loop for offset from
0 below key-count do
494 (setf (svref copy
(+ index offset
)) (pop layouts
)))
495 ;; Update probe depth.
496 (let ((distance (/ (- index primary
) line-size
)))
497 (setf depth
(max depth
(if (minusp distance
)
498 ;; account for wrap-around
502 (setf index
(next-cache-index mask index line-size
))
503 (unless (zerop index
)
505 (%make-cache
:vector copy
507 :key-count
(cache-key-count cache
)
511 :limit
(cache-limit cache
))))
513 ;;;; For debugging & collecting statistics.
515 (defun map-all-caches (function)
516 (dolist (p (list-all-packages))
518 (when (eq p
(symbol-package s
))
519 (dolist (name (list s
523 (slot-boundp-name s
)))
525 (let ((fun (fdefinition name
)))
526 (when (typep fun
'generic-function
)
527 (let ((cache (gf-dfun-cache fun
)))
529 (funcall function name cache
)))))))))))
531 (defun check-cache-consistency (cache)
532 (let ((table (make-hash-table :test
'equal
)))
533 (map-cache (lambda (layouts value
)
534 (declare (ignore value
))
535 (if (gethash layouts table
)
536 (cerror "Check futher."
537 "Multiple appearances of ~S." layouts
)
538 (setf (gethash layouts table
) t
)))