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 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. 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 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)) 91 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 95 ;; 96 ;; (logand <mask> <combined-layout-hash>) 97 ;; 98 ;; is "morally equal" to 99 ;; 100 ;; (mod (* <line-size> <combined-layout-hash>) <vector-length>) 101 ;; 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))) 106 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)))) 115 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)) 120 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 123;;; cache vector. 124;;; 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)))) 130 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..) 136 ,else 137 ,n-value)))) 138 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))) 144 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) 150 old depth)))))) 151 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))) 157 158;;; Returns the hash-value for layout, or executes ELSE if the layout 159;;; is invalid. 160(defmacro hash-layout-or (layout else) 161 (with-unique-names (n-hash) 162 `(let ((,n-hash (layout-clos-hash ,layout))) 163 (if (zerop ,n-hash) 164 ,else 165 ,n-hash)))) 166 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)))) 177 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.) 182;;; 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 185;;; beforehand. 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)) 191 (pointer 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. 195 #-(or x86 x86-64) 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)))) 203 (cdr layout-vars)) 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)))) 210 (tagbody 211 ,MATCH-WRAPPERS 212 (when (and ,@(loop for layout-var in layout-vars 213 for i from 0 214 collect 215 (if pointer 216 `(prog1 (eq ,layout-var 217 (svref ,n-vector ,pointer)) 218 (incf ,pointer)) 219 `(eq ,layout-var 220 (svref ,n-vector 221 (the index (+ ,probe ,i))))))) 222 ,@(when value-var 223 `((setf ,value-var 224 (non-empty-or (svref ,n-vector 225 ,(or pointer 226 `(the index 227 (+ ,probe ,num-keys)))) 228 (go ,miss-tag))))) 229 (go ,EXIT-WITH-HIT)) 230 (when (zerop ,n-depth) (go ,miss-tag)) 231 (decf ,n-depth) 232 (setf ,probe (next-cache-index ,n-mask ,probe ,line-size)) 233 ,@(if pointer `((setf ,pointer ,probe))) 234 (go ,MATCH-WRAPPERS) 235 ,EXIT-WITH-HIT)))))) 236 237;;; Probes CACHE for LAYOUTS. 238;;; 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))) 249 (tagbody 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)) 256 then (pop layouts) 257 unless (eq layout (svref vector (truly-the index (+ base offset)))) 258 do (go :miss)) 259 ;; all layouts match! 260 (let ((value (when (cache-value cache) 261 (non-empty-or (svref vector (truly-the index (+ base key-count))) 262 (go :miss))))) 263 (return-from probe-cache (values t value))) 264 :miss 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)))) 271 (when index 272 (loop repeat (1+ (cache-depth cache)) 273 do (setf index (probe-line index))))))) 274 (values nil nil)) 275 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)) 281 (new (pop layouts))) 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)) 290 (unless layouts 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)) 301 (incf base)))) 302 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 305;;; full. 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))))) 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 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))) 346 (tagbody 347 :again 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..) 352 (cache-depth copy) 0 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 357 ;; in FILL-CACHE. 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 374 ;; analysis... 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)) 384 (go :again)))) 385 cache)) 386 copy)) 387 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)) 393 (index 0)) 394 (loop 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)) 410 (when (zerop index) 411 ;; wrapped around 412 (return-from cache-has-invalid-entries-p nil))))) 413 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))) 419 table) 420 cache)) 421 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) 425 (labels 426 ((%fill-cache (cache layouts value expand) 427 (cond ((try-update-cache cache layouts value) 428 cache) 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)) 433 (t 434 (copy-and-expand-cache cache layouts value))))) 435 (%fill-cache cache (ensure-list layouts) value nil))) 436 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) 445 function 446 (fdefinition function))) 447 (index 0)) 448 (tagbody 449 :map 450 (let ((layouts 451 (loop for offset from 0 below key-count 452 collect (non-empty-or (svref vector (+ offset index)) 453 (go :next))))) 454 (let ((value (when valuep 455 (non-empty-or (svref vector (+ index key-count)) 456 (go :next))))) 457 ;; Let the callee worry about invalid layouts 458 (funcall fun layouts value))) 459 :next 460 (setf index (next-cache-index mask index line-size)) 461 (unless (zerop index) 462 (go :map)))) 463 cache) 464 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 468;;; ones. 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)) 477 (index 0) 478 (depth 0)) 479 (tagbody 480 :copy 481 (let ((layouts (loop for offset from 0 below key-count 482 collect (non-empty-or (svref vector (+ index offset)) 483 (go :next))))) 484 ;; Check validity & compute primary index. 485 (let ((primary (or (compute-cache-index cache layouts) 486 (go :next)))) 487 ;; Check & copy value. 488 (when valuep 489 (setf (svref copy (+ index key-count)) 490 (non-empty-or (svref vector (+ index key-count)) 491 (go :next)))) 492 ;; Copy layouts. 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 499 (+ distance size) 500 distance)))))) 501 :next 502 (setf index (next-cache-index mask index line-size)) 503 (unless (zerop index) 504 (go :copy))) 505 (%make-cache :vector copy 506 :depth depth 507 :key-count (cache-key-count cache) 508 :line-size line-size 509 :value valuep 510 :mask mask 511 :limit (cache-limit cache)))) 512 513;;;; For debugging & collecting statistics. 514 515(defun map-all-caches (function) 516 (dolist (p (list-all-packages)) 517 (do-symbols (s p) 518 (when (eq p (symbol-package s)) 519 (dolist (name (list s 520 `(setf ,s) 521 (slot-reader-name s) 522 (slot-writer-name s) 523 (slot-boundp-name s))) 524 (when (fboundp name) 525 (let ((fun (fdefinition name))) 526 (when (typep fun 'generic-function) 527 (let ((cache (gf-dfun-cache fun))) 528 (when cache 529 (funcall function name cache))))))))))) 530 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))) 539 cache))) 540