Merged sbcl-1.0.14 with the sb-simd 1.3 patches
[sbcl/simd.git] / src / pcl / cache.lisp
blob0ff03d99a3e59fd5116962b402fb96226f48ff6f
1 ;;;; the basics of the PCL wrapper cache mechanism
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
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.
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.
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.
31 (in-package "SB-PCL")
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.
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
85 ;; (mod (* line-size line-hash) (length vector))).
86 (mask 0 :type fixnum)
87 ;; Current probe-depth needed in the cache.
88 (depth 0 :type index)
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 ;;; The smallest power of two that is equal to or greater then X.
108 (declaim (inline power-of-two-ceiling))
109 (defun power-of-two-ceiling (x)
110 (ash 1 (integer-length (1- x))))
112 (defun cache-statistics (cache)
113 (let* ((vector (cache-vector cache))
114 (size (length vector))
115 (line-size (cache-line-size cache))
116 (total-lines (/ size line-size))
117 (free-lines (loop for i from 0 by line-size below size
118 unless (eq (svref vector i) '..empty..)
119 count t)))
120 (values (- total-lines free-lines) total-lines
121 (cache-depth cache) (cache-limit cache))))
123 ;;; Don't allocate insanely huge caches: this is 4096 lines for a
124 ;;; value cache with 8-15 keys -- probably "big enough for anyone",
125 ;;; and 16384 lines for a commonplace 2-key value cache.
126 (defconstant +cache-vector-max-length+ (expt 2 16))
128 ;;; Compute the maximum allowed probe depth as a function of cache size.
129 ;;; Cache size refers to number of cache lines, not the length of the
130 ;;; cache vector.
132 ;;; FIXME: It would be nice to take the generic function optimization
133 ;;; policy into account here (speed vs. space.)
134 (declaim (inline compute-limit))
135 (defun compute-limit (size)
136 (ceiling (sqrt (sqrt size))))
138 ;;; Returns VALUE if it is not ..EMPTY.., otherwise executes ELSE:
139 (defmacro non-empty-or (value else)
140 (with-unique-names (n-value)
141 `(let ((,n-value ,value))
142 (if (eq ,n-value '..empty..)
143 ,else
144 ,n-value))))
146 ;;; Fast way to check if a thing found at the position of a cache key is one:
147 ;;; it is always either a wrapper, or the ..EMPTY.. symbol.
148 (declaim (inline cache-key-p))
149 (defun cache-key-p (thing)
150 (not (symbolp thing)))
152 ;;; Atomically update the current probe depth of a cache.
153 (defun note-cache-depth (cache depth)
154 (loop for old = (cache-depth cache)
155 while (and (< old depth)
156 (not (eq old (compare-and-swap (cache-depth cache)
157 old depth))))))
159 ;;; Compute the starting index of the next cache line in the cache vector.
160 (declaim (inline next-cache-index))
161 (defun next-cache-index (mask index line-size)
162 (declare (type (unsigned-byte #.sb-vm:n-word-bits) index line-size mask))
163 (logand mask (+ index line-size)))
165 ;;; Returns the hash-value for layout, or executes ELSE if the layout
166 ;;; is invalid.
167 (defmacro hash-layout-or (layout else)
168 (with-unique-names (n-hash)
169 `(let ((,n-hash (layout-clos-hash ,layout)))
170 (if (zerop ,n-hash)
171 ,else
172 ,n-hash))))
174 ;;; Compute cache index for the cache and a list of layouts.
175 (declaim (inline compute-cache-index))
176 (defun compute-cache-index (cache layouts)
177 (let ((index (hash-layout-or (car layouts)
178 (return-from compute-cache-index nil))))
179 (declare (fixnum index))
180 (dolist (layout (cdr layouts))
181 (mixf index (hash-layout-or layout (return-from compute-cache-index nil))))
182 ;; align with cache lines
183 (logand index (cache-mask cache))))
185 ;;; Emit code that does lookup in cache bound to CACHE-VAR using
186 ;;; layouts bound to LAYOUT-VARS. Go to MISS-TAG on event of a miss or
187 ;;; invalid layout. Otherwise, if VALUE-VAR is non-nil, set it to the
188 ;;; value found. (VALUE-VAR is non-nil only when CACHE-VALUE is true.)
190 ;;; In other words, produces inlined code for COMPUTE-CACHE-INDEX when
191 ;;; number of keys and presence of values in the cache is known
192 ;;; beforehand.
193 (defun emit-cache-lookup (cache-var layout-vars miss-tag value-var)
194 (let ((line-size (power-of-two-ceiling (+ (length layout-vars)
195 (if value-var 1 0)))))
196 (with-unique-names (n-index n-vector n-depth n-pointer n-mask
197 MATCH-WRAPPERS EXIT-WITH-HIT)
198 `(let* ((,n-index (hash-layout-or ,(car layout-vars) (go ,miss-tag)))
199 (,n-vector (cache-vector ,cache-var))
200 (,n-mask (cache-mask ,cache-var)))
201 (declare (index ,n-index))
202 ,@(mapcar (lambda (layout-var)
203 `(mixf ,n-index (hash-layout-or ,layout-var (go ,miss-tag))))
204 (cdr layout-vars))
205 ;; align with cache lines
206 (setf ,n-index (logand ,n-index ,n-mask))
207 (let ((,n-depth (cache-depth ,cache-var))
208 (,n-pointer ,n-index))
209 (declare (index ,n-depth ,n-pointer))
210 (tagbody
211 ,MATCH-WRAPPERS
212 (when (and ,@(mapcar
213 (lambda (layout-var)
214 `(prog1
215 (eq ,layout-var (svref ,n-vector ,n-pointer))
216 (incf ,n-pointer)))
217 layout-vars))
218 ,@(when value-var
219 `((setf ,value-var (non-empty-or (svref ,n-vector ,n-pointer)
220 (go ,miss-tag)))))
221 (go ,EXIT-WITH-HIT))
222 (if (zerop ,n-depth)
223 (go ,miss-tag)
224 (decf ,n-depth))
225 (setf ,n-index (next-cache-index ,n-mask ,n-index ,line-size)
226 ,n-pointer ,n-index)
227 (go ,MATCH-WRAPPERS)
228 ,EXIT-WITH-HIT))))))
230 ;;; Probes CACHE for LAYOUTS.
232 ;;; Returns two values: a boolean indicating a hit or a miss, and a secondary
233 ;;; value that is the value that was stored in the cache if any.
234 (defun probe-cache (cache layouts)
235 (declare (optimize speed))
236 (unless (consp layouts)
237 (setf layouts (list layouts)))
238 (let ((vector (cache-vector cache))
239 (key-count (cache-key-count cache))
240 (line-size (cache-line-size cache))
241 (mask (cache-mask cache)))
242 (flet ((probe-line (base)
243 (declare (optimize (sb-c::type-check 0)))
244 (tagbody
245 (loop for offset of-type index from 0 below key-count
246 for layout in layouts do
247 (unless (eq layout (svref vector (+ base offset)))
248 ;; missed
249 (go :miss)))
250 ;; all layouts match!
251 (let ((value (when (cache-value cache)
252 (non-empty-or (svref vector (+ base key-count))
253 (go :miss)))))
254 (return-from probe-cache (values t value)))
255 :miss
256 (return-from probe-line (next-cache-index mask base line-size)))))
257 (declare (ftype (function (index) (values index &optional)) probe-line))
258 (let ((index (compute-cache-index cache layouts)))
259 (when index
260 (loop repeat (1+ (cache-depth cache))
261 do (setf index (probe-line index)))))))
262 (values nil nil))
264 ;;; Tries to write LAYOUTS and VALUE at the cache line starting at
265 ;;; the index BASE. Returns true on success, and false on failure.
266 (defun try-update-cache-line (cache base layouts value)
267 (declare (index base))
268 (let ((vector (cache-vector cache))
269 (new (pop layouts)))
270 ;; If we unwind from here, we will be left with an incomplete
271 ;; cache line, but that is OK: next write using the same layouts
272 ;; will fill it, and reads will treat an incomplete line as a
273 ;; miss -- causing it to be filled.
274 (loop for old = (compare-and-swap (svref vector base) '..empty.. new) do
275 (when (and (cache-key-p old) (not (eq old new)))
276 ;; The place was already taken, and doesn't match our key.
277 (return-from try-update-cache-line nil))
278 (unless layouts
279 ;; All keys match or succesfully saved, save our value --
280 ;; just smash it in. Until the first time it is written
281 ;; there is ..EMPTY.. here, which probes look for, so we
282 ;; don't get bogus hits. This is necessary because we want
283 ;; to be able store arbitrary values here for use with
284 ;; constant-value dispatch functions.
285 (when (cache-value cache)
286 (setf (svref vector (1+ base)) value))
287 (return-from try-update-cache-line t))
288 (setf new (pop layouts))
289 (incf base))))
291 ;;; Tries to write LAYOUTS and VALUE somewhere in the cache. Returns
292 ;;; true on success and false on failure, meaning the cache is too
293 ;;; full.
294 (defun try-update-cache (cache layouts value)
295 (let ((index (or (compute-cache-index cache layouts)
296 ;; At least one of the layouts was invalid: just
297 ;; pretend we updated the cache, and let the next
298 ;; read pick up the mess.
299 (return-from try-update-cache t)))
300 (line-size (cache-line-size cache))
301 (mask (cache-mask cache)))
302 (declare (index index))
303 (loop for depth from 0 upto (cache-limit cache) do
304 (when (try-update-cache-line cache index layouts value)
305 (note-cache-depth cache depth)
306 (return-from try-update-cache t))
307 (setf index (next-cache-index mask index line-size)))))
309 ;;; Constructs a new cache.
310 (defun make-cache (&key (key-count (missing-arg)) (value (missing-arg))
311 (size 1))
312 (let* ((line-size (power-of-two-ceiling (+ key-count (if value 1 0))))
313 (adjusted-size (power-of-two-ceiling size))
314 (length (* adjusted-size line-size)))
315 (if (<= length +cache-vector-max-length+)
316 (%make-cache :key-count key-count
317 :line-size line-size
318 :vector (make-array length :initial-element '..empty..)
319 :value value
320 :mask (compute-cache-mask length line-size)
321 :limit (compute-limit adjusted-size))
322 ;; Make a smaller one, then
323 (make-cache :key-count key-count :value value :size (ceiling size 2)))))
325 ;;;; Copies and expands the cache, dropping any invalidated or
326 ;;;; incomplete lines.
327 (defun copy-and-expand-cache (cache layouts value)
328 (let ((copy (%copy-cache cache))
329 (length (length (cache-vector cache))))
330 (declare (index length))
331 (when (< length +cache-vector-max-length+)
332 (setf length (* 2 length)))
333 (tagbody
334 :again
335 ;; Blow way the old vector first, so a GC potentially triggered by
336 ;; MAKE-ARRAY can collect it.
337 (setf (cache-vector copy) #()
338 (cache-vector copy) (make-array length :initial-element '..empty..)
339 (cache-depth copy) 0
340 (cache-mask copy) (compute-cache-mask length (cache-line-size cache))
341 (cache-limit copy) (compute-limit (/ length (cache-line-size cache))))
342 ;; First insert the new one -- if we don't do this first and
343 ;; the cache has reached it's maximum size we may end up
344 ;; looping in FILL-CACHE.
345 (unless (try-update-cache copy layouts value)
346 (bug "Could not insert ~S:~S to supposedly empty ~S." layouts value cache))
347 (map-cache (lambda (layouts value)
348 (unless (try-update-cache copy layouts value)
349 ;; If the cache would grow too much we drop the
350 ;; remaining the entries that don't fit. FIXME:
351 ;; It would be better to drop random entries to
352 ;; avoid getting into a rut here (best done by
353 ;; making MAP-CACHE map in a random order?), and
354 ;; possibly to downsize the cache more
355 ;; aggressively (on the assumption that most
356 ;; entries aren't getting used at the moment.)
357 (when (< length +cache-vector-max-length+)
358 (setf length (* 2 length))
359 (go :again))))
360 cache))
361 copy))
363 (defun cache-has-invalid-entries-p (cache)
364 (let ((vector (cache-vector cache))
365 (line-size (cache-line-size cache))
366 (key-count (cache-key-count cache))
367 (mask (cache-mask cache))
368 (index 0))
369 (loop
370 ;; Check if the line is in use, and check validity of the keys.
371 (let ((key1 (svref vector index)))
372 (when (cache-key-p key1)
373 (if (zerop (layout-clos-hash key1))
374 ;; First key invalid.
375 (return-from cache-has-invalid-entries-p t)
376 ;; Line is in use and the first key is valid: check the rest.
377 (loop for offset from 1 below key-count
378 do (let ((thing (svref vector (+ index offset))))
379 (when (or (not (cache-key-p thing))
380 (zerop (layout-clos-hash thing)))
381 ;; Incomplete line or invalid layout.
382 (return-from cache-has-invalid-entries-p t)))))))
383 ;; Line empty of valid, onwards.
384 (setf index (next-cache-index mask index line-size))
385 (when (zerop index)
386 ;; wrapped around
387 (return-from cache-has-invalid-entries-p nil)))))
389 (defun hash-table-to-cache (table &key value key-count)
390 (let ((cache (make-cache :key-count key-count :value value
391 :size (hash-table-count table))))
392 (maphash (lambda (class value)
393 (setq cache (fill-cache cache (class-wrapper class) value)))
394 table)
395 cache))
397 ;;; Inserts VALUE to CACHE keyd by LAYOUTS. Expands the cache if
398 ;;; necessary, and returns the new cache.
399 (defun fill-cache (cache layouts value)
400 (labels
401 ((%fill-cache (cache layouts value)
402 (cond ((try-update-cache cache layouts value)
403 cache)
404 ((cache-has-invalid-entries-p cache)
405 ;; Don't expand yet: maybe there will be enough space if
406 ;; we just drop the invalid entries.
407 (%fill-cache (copy-cache cache) layouts value))
409 (copy-and-expand-cache cache layouts value)))))
410 (if (listp layouts)
411 (%fill-cache cache layouts value)
412 (%fill-cache cache (list layouts) value))))
414 ;;; Calls FUNCTION with all layouts and values in cache.
415 (defun map-cache (function cache)
416 (let* ((vector (cache-vector cache))
417 (key-count (cache-key-count cache))
418 (valuep (cache-value cache))
419 (line-size (cache-line-size cache))
420 (mask (cache-mask cache))
421 (fun (if (functionp function)
422 function
423 (fdefinition function)))
424 (index 0))
425 (tagbody
426 :map
427 (let ((layouts
428 (loop for offset from 0 below key-count
429 collect (non-empty-or (svref vector (+ offset index))
430 (go :next)))))
431 (let ((value (when valuep
432 (non-empty-or (svref vector (+ index key-count))
433 (go :next)))))
434 ;; Let the callee worry about invalid layouts
435 (funcall fun layouts value)))
436 :next
437 (setf index (next-cache-index mask index line-size))
438 (unless (zerop index)
439 (go :map))))
440 cache)
442 ;;; Copying a cache without expanding it is very much like mapping it:
443 ;;; we need to be carefull because there may be updates while we are
444 ;;; copying it, and we don't want to copy incomplete entries or invalid
445 ;;; ones.
446 (defun copy-cache (cache)
447 (let* ((vector (cache-vector cache))
448 (copy (make-array (length vector) :initial-element '..empty..))
449 (line-size (cache-line-size cache))
450 (key-count (cache-key-count cache))
451 (valuep (cache-value cache))
452 (mask (cache-mask cache))
453 (size (/ (length vector) line-size))
454 (index 0)
455 (depth 0))
456 (tagbody
457 :copy
458 (let ((layouts (loop for offset from 0 below key-count
459 collect (non-empty-or (svref vector (+ index offset))
460 (go :next)))))
461 ;; Check validity & compute primary index.
462 (let ((primary (or (compute-cache-index cache layouts)
463 (go :next))))
464 ;; Check & copy value.
465 (when valuep
466 (setf (svref copy (+ index key-count))
467 (non-empty-or (svref vector (+ index key-count))
468 (go :next))))
469 ;; Copy layouts.
470 (loop for offset from 0 below key-count do
471 (setf (svref copy (+ index offset)) (pop layouts)))
472 ;; Update probe depth.
473 (let ((distance (/ (- index primary) line-size)))
474 (setf depth (max depth (if (minusp distance)
475 ;; account for wrap-around
476 (+ distance size)
477 distance))))))
478 :next
479 (setf index (next-cache-index mask index line-size))
480 (unless (zerop index)
481 (go :copy)))
482 (%make-cache :vector copy
483 :depth depth
484 :key-count (cache-key-count cache)
485 :line-size line-size
486 :value valuep
487 :mask mask
488 :limit (cache-limit cache))))
490 ;;;; For debugging & collecting statistics.
492 (defun map-all-caches (function)
493 (dolist (p (list-all-packages))
494 (do-symbols (s p)
495 (when (eq p (symbol-package s))
496 (dolist (name (list s
497 `(setf ,s)
498 (slot-reader-name s)
499 (slot-writer-name s)
500 (slot-boundp-name s)))
501 (when (fboundp name)
502 (let ((fun (fdefinition name)))
503 (when (typep fun 'generic-function)
504 (let ((cache (gf-dfun-cache fun)))
505 (when cache
506 (funcall function name cache)))))))))))
508 (defun check-cache-consistency (cache)
509 (let ((table (make-hash-table :test 'equal)))
510 (map-cache (lambda (layouts value)
511 (declare (ignore value))
512 (if (gethash layouts table)
513 (cerror "Check futher."
514 "Multiple appearances of ~S." layouts)
515 (setf (gethash layouts table) t)))
516 cache)))