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