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
  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 ;;; 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))))
 111
 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))))
 122
 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))
 127
 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.
 131 ;;;
 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))))
 137
 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))))
 145
 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)))
 151
 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))))))
 158
 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)))
 164
 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))))
 173
 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))))
 184
 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.)
 189 ;;;
 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))))))
 229
 230 ;;; Probes CACHE for LAYOUTS.
 231 ;;;
 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))
 263
 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))))
 290
 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)))))
 308
 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)))))
 324
 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         (drop-random-entries nil))
 331     (declare (index length))
 332     (when (< length +cache-vector-max-length+)
 333       (setf length (* 2 length)))
 334     (tagbody
 335      :again
 336        ;; Blow way the old vector first, so a GC potentially triggered by
 337        ;; MAKE-ARRAY can collect it.
 338        (setf (cache-vector copy) #()
 339              (cache-vector copy) (make-array length :initial-element '..empty..)
 340              (cache-depth copy) 0
 341              (cache-mask copy) (compute-cache-mask length (cache-line-size cache))
 342              (cache-limit copy) (compute-limit (/ length (cache-line-size cache))))
 343        ;; First insert the new one -- if we don't do this first and
 344        ;; the cache has reached it's maximum size we may end up
 345        ;; looping in FILL-CACHE.
 346        (unless (try-update-cache copy layouts value)
 347          (bug "Could not insert ~S:~S to supposedly empty ~S." layouts value copy))
 348        (map-cache (if drop-random-entries
 349                       ;; The cache is at maximum size, and all entries
 350                       ;; do not fit in. Drop a random ~50% of entries,
 351                       ;; to make space for new ones. This needs to be
 352                       ;; random, since otherwise we might get in a
 353                       ;; rut: add A causing B to drop, then add B
 354                       ;; causing A to drop... repeat ad nauseam,
 355                       ;; spending most of the time here instead of
 356                       ;; doing real work. 50% because if we drop to
 357                       ;; few we need to do this almost right away
 358                       ;; again, and if we drop to many, we need to
 359                       ;; recompute more then we'd like.
 360                       ;; _Experimentally_ 50% seems to perform the
 361                       ;; best, but it would be nice to have a proper
 362                       ;; analysis...
 363                       (flet ((random-fixnum ()
 364                                (random (1+ most-positive-fixnum))))
 365                         (let ((drops (random-fixnum)))
 366                           (declare (fixnum drops))
 367                           (lambda (layouts value)
 368                             (when (logbitp 0 drops)
 369                               (try-update-cache copy layouts value))
 370                             (when (zerop (ash drops -1))
 371                               (setf drops (random-fixnum))))))
 372                       (lambda (layouts value)
 373                         (unless (try-update-cache copy layouts value)
 374                           ;; Didn't fit -- expand the cache, or drop
 375                           ;; a few unlucky ones.
 376                           (if (< length +cache-vector-max-length+)
 377                               (setf length (* 2 length))
 378                               (setf drop-random-entries t))
 379                           (go :again))))
 380                   cache))
 381     copy))
 382
 383 (defun cache-has-invalid-entries-p (cache)
 384   (let ((vector (cache-vector cache))
 385         (line-size (cache-line-size cache))
 386         (key-count (cache-key-count cache))
 387         (mask (cache-mask cache))
 388         (index 0))
 389     (loop
 390       ;; Check if the line is in use, and check validity of the keys.
 391       (let ((key1 (svref vector index)))
 392         (when (cache-key-p key1)
 393           (if (zerop (layout-clos-hash key1))
 394               ;; First key invalid.
 395               (return-from cache-has-invalid-entries-p t)
 396               ;; Line is in use and the first key is valid: check the rest.
 397               (loop for offset from 1 below key-count
 398                     do (let ((thing (svref vector (+ index offset))))
 399                          (when (or (not (cache-key-p thing))
 400                                    (zerop (layout-clos-hash thing)))
 401                            ;; Incomplete line or invalid layout.
 402                            (return-from cache-has-invalid-entries-p t)))))))
 403       ;; Line empty of valid, onwards.
 404       (setf index (next-cache-index mask index line-size))
 405       (when (zerop index)
 406         ;; wrapped around
 407         (return-from cache-has-invalid-entries-p nil)))))
 408
 409 (defun hash-table-to-cache (table &key value key-count)
 410   (let ((cache (make-cache :key-count key-count :value value
 411                            :size (hash-table-count table))))
 412     (maphash (lambda (class value)
 413                (setq cache (fill-cache cache (class-wrapper class) value)))
 414              table)
 415     cache))
 416
 417 ;;; Inserts VALUE to CACHE keyd by LAYOUTS. Expands the cache if
 418 ;;; necessary, and returns the new cache.
 419 (defun fill-cache (cache layouts value)
 420   (labels
 421       ((%fill-cache (cache layouts value expand)
 422          (cond ((try-update-cache cache layouts value)
 423                 cache)
 424                ((and (not expand) (cache-has-invalid-entries-p cache))
 425                 ;; Don't expand yet: maybe there will be enough space if
 426                 ;; we just drop the invalid entries.
 427                 (%fill-cache (copy-cache cache) layouts value t))
 428                (t
 429                 (copy-and-expand-cache cache layouts value)))))
 430     (if (listp layouts)
 431         (%fill-cache cache layouts value nil)
 432         (%fill-cache cache (list layouts) value nil))))
 433
 434 ;;; Calls FUNCTION with all layouts and values in cache.
 435 (defun map-cache (function cache)
 436   (let* ((vector (cache-vector cache))
 437          (key-count (cache-key-count cache))
 438          (valuep (cache-value cache))
 439          (line-size (cache-line-size cache))
 440          (mask (cache-mask cache))
 441          (fun (if (functionp function)
 442                   function
 443                   (fdefinition function)))
 444          (index 0))
 445     (tagbody
 446      :map
 447        (let ((layouts
 448               (loop for offset from 0 below key-count
 449                     collect (non-empty-or (svref vector (+ offset index))
 450                                           (go :next)))))
 451          (let ((value (when valuep
 452                         (non-empty-or (svref vector (+ index key-count))
 453                                       (go :next)))))
 454            ;; Let the callee worry about invalid layouts
 455            (funcall fun layouts value)))
 456      :next
 457        (setf index (next-cache-index mask index line-size))
 458        (unless (zerop index)
 459          (go :map))))
 460   cache)
 461
 462 ;;; Copying a cache without expanding it is very much like mapping it:
 463 ;;; we need to be carefull because there may be updates while we are
 464 ;;; copying it, and we don't want to copy incomplete entries or invalid
 465 ;;; ones.
 466 (defun copy-cache (cache)
 467   (let* ((vector (cache-vector cache))
 468          (copy (make-array (length vector) :initial-element '..empty..))
 469          (line-size (cache-line-size cache))
 470          (key-count (cache-key-count cache))
 471          (valuep (cache-value cache))
 472          (mask (cache-mask cache))
 473          (size (/ (length vector) line-size))
 474          (index 0)
 475          (depth 0))
 476     (tagbody
 477      :copy
 478        (let ((layouts (loop for offset from 0 below key-count
 479                             collect (non-empty-or (svref vector (+ index offset))
 480                                                   (go :next)))))
 481          ;; Check validity & compute primary index.
 482          (let ((primary (or (compute-cache-index cache layouts)
 483                             (go :next))))
 484            ;; Check & copy value.
 485            (when valuep
 486              (setf (svref copy (+ index key-count))
 487                    (non-empty-or (svref vector (+ index key-count))
 488                                  (go :next))))
 489            ;; Copy layouts.
 490            (loop for offset from 0 below key-count do
 491                  (setf (svref copy (+ index offset)) (pop layouts)))
 492            ;; Update probe depth.
 493            (let ((distance (/ (- index primary) line-size)))
 494              (setf depth (max depth (if (minusp distance)
 495                                         ;; account for wrap-around
 496                                         (+ distance size)
 497                                         distance))))))
 498      :next
 499        (setf index (next-cache-index mask index line-size))
 500        (unless (zerop index)
 501          (go :copy)))
 502     (%make-cache :vector copy
 503                  :depth depth
 504                  :key-count (cache-key-count cache)
 505                  :line-size line-size
 506                  :value valuep
 507                  :mask mask
 508                  :limit (cache-limit cache))))
 509
 510 ;;;; For debugging & collecting statistics.
 511
 512 (defun map-all-caches (function)
 513   (dolist (p (list-all-packages))
 514     (do-symbols (s p)
 515       (when (eq p (symbol-package s))
 516         (dolist (name (list s
 517                             `(setf ,s)
 518                             (slot-reader-name s)
 519                             (slot-writer-name s)
 520                             (slot-boundp-name s)))
 521           (when (fboundp name)
 522             (let ((fun (fdefinition name)))
 523               (when (typep fun 'generic-function)
 524                 (let ((cache (gf-dfun-cache fun)))
 525                   (when cache
 526                     (funcall function name cache)))))))))))
 527
 528 (defun check-cache-consistency (cache)
 529   (let ((table (make-hash-table :test 'equal)))
 530     (map-cache (lambda (layouts value)
 531                  (declare (ignore value))
 532                  (if (gethash layouts table)
 533                      (cerror "Check futher."
 534                              "Multiple appearances of ~S." layouts)
 535                      (setf (gethash layouts table) t)))
 536                cache)))