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 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.
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 (mod index (length vector))l
86 ;; Current probe-depth needed in the cache.
88 ;; Maximum allowed probe-depth before the cache needs to expand.
89 (limit 0 :type index))
91 ;;; The smallest power of two that is equal to or greater then X.
92 (declaim (inline power-of-two-ceiling))
93 (defun power-of-two-ceiling (x)
94 (ash 1 (integer-length (1- x))))
96 (defun cache-statistics (cache)
97 (let* ((vector (cache-vector cache))
98 (size (length vector))
99 (line-size (cache-line-size cache))
100 (total-lines (/ size line-size))
101 (free-lines (loop for i from 0 by line-size below size
102 unless (eq (svref vector i) '..empty..)
104 (values (- total-lines free-lines) total-lines
105 (cache-depth cache) (cache-limit cache))))
107 ;;; Don't allocate insanely huge caches.
108 (defconstant +cache-vector-max-length+ (expt 2 14))
110 ;;; Compute the maximum allowed probe depth as a function of cache size.
111 ;;; Cache size refers to number of cache lines, not the length of the
114 ;;; FIXME: It would be nice to take the generic function optimization
115 ;;; policy into account here (speed vs. space.)
116 (declaim (inline compute-limit))
117 (defun compute-limit (size)
118 (ceiling (sqrt size) 2))
120 ;;; Returns VALUE if it is not ..EMPTY.., otherwise executes ELSE:
121 (defmacro non-empty-or (value else)
122 (with-unique-names (n-value)
123 `(let ((,n-value ,value))
124 (if (eq ,n-value '..empty..)
128 ;;; Fast way to check if a thing found at the position of a cache key is one:
129 ;;; it is always either a wrapper, or the ..EMPTY.. symbol.
130 (declaim (inline cache-key-p))
131 (defun cache-key-p (thing)
132 (not (symbolp thing)))
134 (eval-when (:compile-toplevel :load-toplevel :execute)
135 (sb-kernel:define-structure-slot-compare-and-swap compare-and-swap-cache-depth
139 ;;; Utility macro for atomic updates without locking... doesn't
140 ;;; do much right now, and it would be nice to make this more magical.
141 (defmacro compare-and-swap (place old new)
142 (unless (consp place)
143 (error "Don't know how to compare and swap ~S." place))
146 `(simple-vector-compare-and-swap ,@(cdr place) ,old ,new))
148 `(compare-and-swap-cache-depth ,@(cdr place) ,old ,new))))
150 ;;; Atomically update the current probe depth of a cache.
151 (defun note-cache-depth (cache depth)
152 (loop for old = (cache-depth cache)
153 while (and (< old depth)
154 (not (eq old (compare-and-swap (cache-depth cache)
157 ;;; Compute the starting index of the next cache line in the cache vector.
158 (declaim (inline next-cache-index))
159 (defun next-cache-index (mask index line-size)
160 (logand mask (+ index line-size)))
162 ;;; Returns the hash-value for layout, or executes ELSE if the layout
164 (defmacro hash-layout-or (layout else)
165 (with-unique-names (n-hash)
166 `(let ((,n-hash (layout-clos-hash ,layout)))
171 ;;; Compute cache index for the cache and a list of layouts.
172 (declaim (inline compute-cache-index))
173 (defun compute-cache-index (cache layouts)
174 (let ((index (hash-layout-or (car layouts)
175 (return-from compute-cache-index nil))))
176 (dolist (layout (cdr layouts))
177 (mixf index (hash-layout-or layout (return-from compute-cache-index nil))))
178 ;; align with cache lines
179 (logand (* (cache-line-size cache) index) (cache-mask cache))))
181 ;;; Emit code that does lookup in cache bound to CACHE-VAR using
182 ;;; layouts bound to LAYOUT-VARS. Go to MISS-TAG on event of a miss or
183 ;;; invalid layout. Otherwise, if VALUE-VAR is non-nil, set it to the
184 ;;; value found. (VALUE-VAR is non-nil only when CACHE-VALUE is true.)
186 ;;; In other words, produces inlined code for COMPUTE-CACHE-INDEX when
187 ;;; number of keys and presence of values in the cache is known
189 (defun emit-cache-lookup (cache-var layout-vars miss-tag value-var)
190 (let ((line-size (power-of-two-ceiling (+ (length layout-vars)
191 (if value-var 1 0)))))
192 (with-unique-names (n-index n-vector n-depth n-pointer n-mask
193 MATCH-WRAPPERS EXIT-WITH-HIT)
194 `(let* ((,n-index (hash-layout-or ,(car layout-vars) (go ,miss-tag)))
195 (,n-vector (cache-vector ,cache-var)))
196 (declare (index ,n-index))
197 ,@(mapcar (lambda (layout-var)
198 `(mixf ,n-index (hash-layout-or ,layout-var (go ,miss-tag))))
200 ;; align with cache lines
201 (setf ,n-index (logand (the fixnum (* ,n-index ,line-size))
202 (cache-mask ,cache-var)))
203 (let ((,n-depth (cache-depth ,cache-var))
204 (,n-pointer ,n-index)
205 (,n-mask (cache-mask ,cache-var)))
206 (declare (index ,n-depth ,n-pointer))
212 (eq ,layout-var (svref ,n-vector ,n-pointer))
216 `((setf ,value-var (non-empty-or (svref ,n-vector ,n-pointer)
222 (setf ,n-index (next-cache-index ,n-mask ,n-index ,line-size)
227 ;;; Probes CACHE for LAYOUTS.
229 ;;; Returns two values: a boolean indicating a hit or a miss, and a secondary
230 ;;; value that is the value that was stored in the cache if any.
231 (defun probe-cache (cache layouts)
232 (unless (consp layouts)
233 (setf layouts (list layouts)))
234 (let ((vector (cache-vector cache))
235 (key-count (cache-key-count cache))
236 (line-size (cache-line-size cache))
237 (mask (cache-mask cache)))
238 (flet ((probe-line (base)
240 (loop for offset from 0 below key-count
241 for layout in layouts do
242 (unless (eq layout (svref vector (+ base offset)))
245 ;; all layouts match!
246 (let ((value (when (cache-value cache)
247 (non-empty-or (svref vector (+ base key-count))
249 (return-from probe-cache (values t value)))
251 (return-from probe-line (next-cache-index mask base line-size)))))
252 (let ((index (compute-cache-index cache layouts)))
254 (loop repeat (1+ (cache-depth cache)) do
255 (setf index (probe-line index)))))))
258 ;;; Tries to write LAYOUTS and VALUE at the cache line starting at
259 ;;; the index BASE. Returns true on success, and false on failure.
260 (defun try-update-cache-line (cache base layouts value)
261 (declare (index base))
262 (let ((vector (cache-vector cache))
264 ;; If we unwind from here, we will be left with an incomplete
265 ;; cache line, but that is OK: next write using the same layouts
266 ;; will fill it, and reads will treat an incomplete line as a
267 ;; miss -- causing it to be filled.
268 (loop for old = (compare-and-swap (svref vector base) '..empty.. new) do
269 (when (and (cache-key-p old) (not (eq old new)))
270 ;; The place was already taken, and doesn't match our key.
271 (return-from try-update-cache-line nil))
273 ;; All keys match or succesfully saved, save our value --
274 ;; just smash it in. Until the first time it is written
275 ;; there is ..EMPTY.. here, which probes look for, so we
276 ;; don't get bogus hits. This is necessary because we want
277 ;; to be able store arbitrary values here for use with
278 ;; constant-value dispatch functions.
279 (when (cache-value cache)
280 (setf (svref vector (1+ base)) value))
281 (return-from try-update-cache-line t))
282 (setf new (pop layouts))
285 ;;; Tries to write LAYOUTS and VALUE somewhere in the cache. Returns
286 ;;; true on success and false on failure, meaning the cache is too
288 (defun try-update-cache (cache layouts value)
289 (let ((vector (cache-vector cache))
290 (index (or (compute-cache-index cache layouts)
291 ;; At least one of the layouts was invalid: just
292 ;; pretend we updated the cache, and let the next
293 ;; read pick up the mess.
294 (return-from try-update-cache t)))
295 (line-size (cache-line-size cache))
296 (mask (cache-mask cache)))
297 (declare (index index))
298 (loop for depth from 0 upto (cache-limit cache) do
299 (when (try-update-cache-line cache index layouts value)
300 (note-cache-depth cache depth)
301 (return-from try-update-cache t))
302 (setf index (next-cache-index mask index line-size)))))
304 ;;; Constructs a new cache.
305 (defun make-cache (&key (key-count (missing-arg)) (value (missing-arg))
307 (let* ((line-size (power-of-two-ceiling (+ key-count (if value 1 0))))
308 (adjusted-size (power-of-two-ceiling size))
309 (length (* adjusted-size line-size)))
310 (if (<= length +cache-vector-max-length+)
311 (%make-cache :key-count key-count
313 :vector (make-array length :initial-element '..empty..)
316 :limit (compute-limit adjusted-size))
317 ;; Make a smaller one, then
318 (make-cache :key-count key-count :value value :size (ceiling size 2)))))
320 ;;;; Copies and expands the cache, dropping any invalidated or
321 ;;;; incomplete lines.
322 (defun copy-and-expand-cache (cache)
323 (let ((copy (%copy-cache cache))
324 (length (length (cache-vector cache))))
325 (when (< length +cache-vector-max-length+)
326 (setf length (* 2 length)))
329 (setf (cache-vector copy) (make-array length :initial-element '..empty..)
331 (cache-mask copy) (1- length)
332 (cache-limit copy) (compute-limit (/ length (cache-line-size cache))))
333 (map-cache (lambda (layouts value)
334 (unless (try-update-cache copy layouts value)
335 ;; If the cache would grow too much we drop the
336 ;; remaining the entries that don't fit. FIXME:
337 ;; It would be better to drop random entries to
338 ;; avoid getting into a rut here (best done by
339 ;; making MAP-CACHE map in a random order?), and
340 ;; possibly to downsize the cache more
341 ;; aggressively (on the assumption that most
342 ;; entries aren't getting used at the moment.)
343 (when (< length +cache-vector-max-length+)
344 (setf length (* 2 length))
349 (defun cache-has-invalid-entries-p (cache)
350 (and (find-if (lambda (elt)
351 (and (typep elt 'layout)
352 (zerop (layout-clos-hash elt))))
353 (cache-vector cache))
356 (defun hash-table-to-cache (table &key value key-count)
357 (let ((cache (make-cache :key-count key-count :value value
358 :size (hash-table-count table))))
359 (maphash (lambda (class value)
360 (setq cache (fill-cache cache (class-wrapper class) value)))
364 ;;; Inserts VALUE to CACHE keyd by LAYOUTS. Expands the cache if
365 ;;; necessary, and returns the new cache.
366 (defun fill-cache (cache layouts value)
368 ((%fill-cache (cache layouts value)
369 (cond ((try-update-cache cache layouts value)
371 ((cache-has-invalid-entries-p cache)
372 ;; Don't expand yet: maybe there will be enough space if
373 ;; we just drop the invalid entries.
374 (%fill-cache (copy-cache cache) layouts value))
376 (%fill-cache (copy-and-expand-cache cache) layouts value)))))
378 (%fill-cache cache layouts value)
379 (%fill-cache cache (list layouts) value))))
381 ;;; Calls FUNCTION with all layouts and values in cache.
382 (defun map-cache (function cache)
383 (let* ((vector (cache-vector cache))
384 (key-count (cache-key-count cache))
385 (valuep (cache-value cache))
386 (line-size (cache-line-size cache))
387 (mask (cache-mask cache))
388 (fun (if (functionp function)
390 (fdefinition function)))
396 (loop for offset from 0 below key-count
397 collect (non-empty-or (svref vector (+ offset index))
399 (let ((value (when valuep
400 (non-empty-or (svref vector (+ index key-count))
402 ;; Let the callee worry about invalid layouts
403 (funcall fun layouts value)))
405 (setf index (next-cache-index mask index line-size))
406 (unless (zerop index)
410 ;;; Copying a cache without expanding it is very much like mapping it:
411 ;;; we need to be carefull because there may be updates while we are
412 ;;; copying it, and we don't want to copy incomplete entries or invalid
414 (defun copy-cache (cache)
415 (let* ((vector (cache-vector cache))
416 (copy (make-array (length vector) :initial-element '..empty..))
417 (line-size (cache-line-size cache))
418 (key-count (cache-key-count cache))
419 (valuep (cache-value cache))
420 (size (/ (length vector) line-size))
421 (mask (cache-mask cache))
427 (let ((layouts (loop for offset from 0 below key-count
428 collect (non-empty-or (svref vector (+ index offset))
430 ;; Check validity & compute primary index.
431 (let ((primary (or (compute-cache-index cache layouts)
433 ;; Check & copy value.
435 (setf (svref copy (+ index key-count))
436 (non-empty-or (svref vector (+ index key-count))
439 (loop for offset from 0 below key-count do
440 (setf (svref copy (+ index offset)) (pop layouts)))
441 ;; Update probe depth.
442 (let ((distance (/ (- index primary) line-size)))
443 (setf depth (max depth (if (minusp distance)
444 ;; account for wrap-around
448 (setf index (next-cache-index mask index line-size))
449 (unless (zerop index)
451 (%make-cache :vector copy
453 :key-count (cache-key-count cache)
456 :mask (cache-mask cache)
457 :limit (cache-limit cache))))