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 (in-package "SB-PCL")
  27 \f
  28 ;;; The caching algorithm implemented:
  29 ;;;
  30 ;;; << put a paper here >>
  31 ;;;
  32 ;;; For now, understand that as far as most of this code goes, a cache
  33 ;;; has two important properties. The first is the number of wrappers
  34 ;;; used as keys in each cache line. Throughout this code, this value
  35 ;;; is always called NKEYS. The second is whether or not the cache
  36 ;;; lines of a cache store a value. Throughout this code, this always
  37 ;;; called VALUEP.
  38 ;;;
  39 ;;; Depending on these values, there are three kinds of caches.
  40 ;;;
  41 ;;; NKEYS = 1, VALUEP = NIL
  42 ;;;
  43 ;;; In this kind of cache, each line is 1 word long. No cache locking
  44 ;;; is needed since all read's in the cache are a single value.
  45 ;;; Nevertheless line 0 (location 0) is reserved, to ensure that
  46 ;;; invalid wrappers will not get a first probe hit.
  47 ;;;
  48 ;;; To keep the code simpler, a cache lock count does appear in
  49 ;;; location 0 of these caches, that count is incremented whenever
  50 ;;; data is written to the cache. But, the actual lookup code (see
  51 ;;; make-dlap) doesn't need to do locking when reading the cache.
  52 ;;;
  53 ;;; NKEYS = 1, VALUEP = T
  54 ;;;
  55 ;;; In this kind of cache, each line is 2 words long. Cache locking
  56 ;;; must be done to ensure the synchronization of cache reads. Line 0
  57 ;;; of the cache (location 0) is reserved for the cache lock count.
  58 ;;; Location 1 of the cache is unused (in effect wasted).
  59 ;;;
  60 ;;; NKEYS > 1
  61 ;;;
  62 ;;; In this kind of cache, the 0 word of the cache holds the lock
  63 ;;; count. The 1 word of the cache is line 0. Line 0 of these caches
  64 ;;; is not reserved.
  65 ;;;
  66 ;;; This is done because in this sort of cache, the overhead of doing
  67 ;;; the cache probe is high enough that the 1+ required to offset the
  68 ;;; location is not a significant cost. In addition, because of the
  69 ;;; larger line sizes, the space that would be wasted by reserving
  70 ;;; line 0 to hold the lock count is more significant.
  71 \f
  72 ;;; caches
  73 ;;;
  74 ;;; A cache is essentially just a vector. The use of the individual
  75 ;;; `words' in the vector depends on particular properties of the
  76 ;;; cache as described above.
  77 ;;;
  78 ;;; This defines an abstraction for caches in terms of their most
  79 ;;; obvious implementation as simple vectors. But, please notice that
  80 ;;; part of the implementation of this abstraction, is the function
  81 ;;; lap-out-cache-ref. This means that most port-specific
  82 ;;; modifications to the implementation of caches will require
  83 ;;; corresponding port-specific modifications to the lap code
  84 ;;; assembler.
  85 (defmacro cache-vector-ref (cache-vector location)
  86   `(svref (the simple-vector ,cache-vector)
  87           (sb-ext:truly-the fixnum ,location)))
  88
  89 (defmacro cache-vector-size (cache-vector)
  90   `(array-dimension (the simple-vector ,cache-vector) 0))
  91
  92 (defun allocate-cache-vector (size)
  93   (make-array size :adjustable nil))
  94
  95 (defmacro cache-vector-lock-count (cache-vector)
  96   `(cache-vector-ref ,cache-vector 0))
  97
  98 (defun flush-cache-vector-internal (cache-vector)
  99   (sb-sys:without-interrupts
 100     (fill (the simple-vector cache-vector) nil)
 101     (setf (cache-vector-lock-count cache-vector) 0))
 102   cache-vector)
 103
 104 (defmacro modify-cache (cache-vector &body body)
 105   `(sb-sys:without-interrupts
 106      (multiple-value-prog1
 107        (progn ,@body)
 108        (let ((old-count (cache-vector-lock-count ,cache-vector)))
 109          (declare (fixnum old-count))
 110          (setf (cache-vector-lock-count ,cache-vector)
 111                (if (= old-count most-positive-fixnum)
 112                    1 (the fixnum (1+ old-count))))))))
 113
 114 (deftype field-type ()
 115   '(mod #.sb-kernel:layout-clos-hash-length))
 116
 117 (eval-when (:compile-toplevel :load-toplevel :execute)
 118 (defun power-of-two-ceiling (x)
 119   (declare (fixnum x))
 120   ;;(expt 2 (ceiling (log x 2)))
 121   (the fixnum (ash 1 (integer-length (1- x)))))
 122 ) ; EVAL-WHEN
 123
 124 (defconstant +nkeys-limit+ 256)
 125
 126 (defstruct (cache (:constructor make-cache ())
 127                   (:copier copy-cache-internal))
 128   (owner nil)
 129   (nkeys 1 :type (integer 1 #.+nkeys-limit+))
 130   (valuep nil :type (member nil t))
 131   (nlines 0 :type fixnum)
 132   (field 0 :type field-type)
 133   (limit-fn #'default-limit-fn :type function)
 134   (mask 0 :type fixnum)
 135   (size 0 :type fixnum)
 136   (line-size 1 :type (integer 1 #.(power-of-two-ceiling (1+ +nkeys-limit+))))
 137   (max-location 0 :type fixnum)
 138   (vector #() :type simple-vector)
 139   (overflow nil :type list))
 140
 141 #-sb-fluid (declaim (sb-ext:freeze-type cache))
 142
 143 (defmacro cache-lock-count (cache)
 144   `(cache-vector-lock-count (cache-vector ,cache)))
 145 \f
 146 ;;; some facilities for allocation and freeing caches as they are needed
 147
 148 ;;; This is done on the assumption that a better port of PCL will
 149 ;;; arrange to cons these all in the same static area. Given that, the
 150 ;;; fact that PCL tries to reuse them should be a win.
 151
 152 (defvar *free-cache-vectors* (make-hash-table :size 16 :test 'eql))
 153
 154 ;;; Return a cache that has had FLUSH-CACHE-VECTOR-INTERNAL called on
 155 ;;; it. This returns a cache of exactly the size requested, it won't
 156 ;;; ever return a larger cache.
 157 (defun get-cache-vector (size)
 158   (let ((entry (gethash size *free-cache-vectors*)))
 159     (sb-sys:without-interrupts
 160       (cond ((null entry)
 161              (setf (gethash size *free-cache-vectors*) (cons 0 nil))
 162              (get-cache-vector size))
 163             ((null (cdr entry))
 164              (incf (car entry))
 165              (flush-cache-vector-internal (allocate-cache-vector size)))
 166             (t
 167              (let ((cache (cdr entry)))
 168                (setf (cdr entry) (cache-vector-ref cache 0))
 169                (flush-cache-vector-internal cache)))))))
 170
 171 (defun free-cache-vector (cache-vector)
 172   (let ((entry (gethash (cache-vector-size cache-vector) *free-cache-vectors*)))
 173     (sb-sys:without-interrupts
 174       (if (null entry)
 175           (error
 176            "attempt to free a cache-vector not allocated by GET-CACHE-VECTOR")
 177           (let ((thread (cdr entry)))
 178             (loop (unless thread (return))
 179                   (when (eq thread cache-vector)
 180                     (error "freeing a cache twice"))
 181                   (setq thread (cache-vector-ref thread 0)))
 182             (flush-cache-vector-internal cache-vector) ; to help the GC
 183             (setf (cache-vector-ref cache-vector 0) (cdr entry))
 184             (setf (cdr entry) cache-vector)
 185             nil)))))
 186
 187 ;;; This is just for debugging and analysis. It shows the state of the
 188 ;;; free cache resource.
 189 #+sb-show
 190 (defun show-free-cache-vectors ()
 191   (let ((elements ()))
 192     (maphash (lambda (s e) (push (list s e) elements)) *free-cache-vectors*)
 193     (setq elements (sort elements #'< :key #'car))
 194     (dolist (e elements)
 195       (let* ((size (car e))
 196              (entry (cadr e))
 197              (allocated (car entry))
 198              (head (cdr entry))
 199              (free 0))
 200         (loop (when (null head) (return t))
 201               (setq head (cache-vector-ref head 0))
 202               (incf free))
 203         (format t
 204                 "~&There are  ~4D caches of size  ~4D. (~D free  ~3D%)"
 205                 allocated
 206                 size
 207                 free
 208                 (floor (* 100 (/ free (float allocated)))))))))
 209 \f
 210 ;;;; wrapper cache numbers
 211
 212 ;;; The constant WRAPPER-CACHE-NUMBER-ADDS-OK controls the number of
 213 ;;; non-zero bits wrapper cache numbers will have.
 214 ;;;
 215 ;;; The value of this constant is the number of wrapper cache numbers
 216 ;;; which can be added and still be certain the result will be a
 217 ;;; fixnum. This is used by all the code that computes primary cache
 218 ;;; locations from multiple wrappers.
 219 ;;;
 220 ;;; The value of this constant is used to derive the next two which
 221 ;;; are the forms of this constant which it is more convenient for the
 222 ;;; runtime code to use.
 223 (defconstant wrapper-cache-number-length
 224   (integer-length sb-kernel:layout-clos-hash-max))
 225 (defconstant wrapper-cache-number-mask sb-kernel:layout-clos-hash-max)
 226 (defconstant wrapper-cache-number-adds-ok
 227   (truncate most-positive-fixnum sb-kernel:layout-clos-hash-max))
 228 \f
 229 ;;;; wrappers themselves
 230
 231 ;;; This caching algorithm requires that wrappers have more than one
 232 ;;; wrapper cache number. You should think of these multiple numbers
 233 ;;; as being in columns. That is, for a given cache, the same column
 234 ;;; of wrapper cache numbers will be used.
 235 ;;;
 236 ;;; If at some point the cache distribution of a cache gets bad, the
 237 ;;; cache can be rehashed by switching to a different column.
 238 ;;;
 239 ;;; The columns are referred to by field number which is that number
 240 ;;; which, when used as a second argument to wrapper-ref, will return
 241 ;;; that column of wrapper cache number.
 242 ;;;
 243 ;;; This code is written to allow flexibility as to how many wrapper
 244 ;;; cache numbers will be in each wrapper, and where they will be
 245 ;;; located. It is also set up to allow port specific modifications to
 246 ;;; `pack' the wrapper cache numbers on machines where the addressing
 247 ;;; modes make that a good idea.
 248
 249 ;;; In SBCL, as in CMU CL, we want to do type checking as early as
 250 ;;; possible; structures help this. The structures are hard-wired to
 251 ;;; have a fixed number of cache hash values, and that number must
 252 ;;; correspond to the number of cache lines we use.
 253 (defconstant wrapper-cache-number-vector-length
 254   sb-kernel:layout-clos-hash-length)
 255
 256 (unless (boundp '*the-class-t*)
 257   (setq *the-class-t* nil))
 258
 259 (defmacro wrapper-class (wrapper)
 260   `(sb-kernel:class-pcl-class (sb-kernel:layout-class ,wrapper)))
 261 (defmacro wrapper-no-of-instance-slots (wrapper)
 262   `(sb-kernel:layout-length ,wrapper))
 263
 264 ;;; WRAPPER-STATE returns T (not generalized boolean, but T exactly)
 265 ;;; iff the wrapper is valid. Any other return value denotes some
 266 ;;; invalid state. Special conventions have been set up for certain
 267 ;;; invalid states, e.g. obsoleteness or flushedness, but I (WHN
 268 ;;; 19991204) haven't been motivated to reverse engineer them from the
 269 ;;; code and document them here.
 270 ;;;
 271 ;;; FIXME: This is awkward and unmnemonic. There is a function
 272 ;;; (INVALID-WRAPPER-P) to test this return result abstractly for
 273 ;;; invalidness but it's not called consistently; the functions that
 274 ;;; need to know whether a wrapper is invalid often test (EQ
 275 ;;; (WRAPPER-STATE X) T), ick. It would be good to use the abstract
 276 ;;; test instead. It would probably be even better to switch the sense
 277 ;;; of the WRAPPER-STATE function, renaming it to WRAPPER-INVALID and
 278 ;;; making it synonymous with LAYOUT-INVALID. Then the
 279 ;;; INVALID-WRAPPER-P function would become trivial and would go away
 280 ;;; (replaced with WRAPPER-INVALID), since all the various invalid
 281 ;;; wrapper states would become generalized boolean "true" values. --
 282 ;;; WHN 19991204
 283 #-sb-fluid (declaim (inline wrapper-state (setf wrapper-state)))
 284 (defun wrapper-state (wrapper)
 285   (let ((invalid (sb-kernel:layout-invalid wrapper)))
 286     (cond ((null invalid)
 287            t)
 288           ((atom invalid)
 289            ;; some non-PCL object. INVALID is probably :INVALID. We
 290            ;; should arguably compute the new wrapper here instead of
 291            ;; returning NIL, but we don't bother, since
 292            ;; OBSOLETE-INSTANCE-TRAP can't use it.
 293            '(:obsolete nil))
 294           (t
 295            invalid))))
 296 (defun (setf wrapper-state) (new-value wrapper)
 297   (setf (sb-kernel:layout-invalid wrapper)
 298         (if (eq new-value t)
 299             nil
 300           new-value)))
 301
 302 (defmacro wrapper-instance-slots-layout (wrapper)
 303   `(%wrapper-instance-slots-layout ,wrapper))
 304 (defmacro wrapper-class-slots (wrapper)
 305   `(%wrapper-class-slots ,wrapper))
 306 (defmacro wrapper-cache-number-vector (x) x)
 307
 308 ;;; This is called in BRAID when we are making wrappers for classes
 309 ;;; whose slots are not initialized yet, and which may be built-in
 310 ;;; classes. We pass in the class name in addition to the class.
 311 (defun boot-make-wrapper (length name &optional class)
 312   (let ((found (cl:find-class name nil)))
 313     (cond
 314      (found
 315       (unless (sb-kernel:class-pcl-class found)
 316         (setf (sb-kernel:class-pcl-class found) class))
 317       (aver (eq (sb-kernel:class-pcl-class found) class))
 318       (let ((layout (sb-kernel:class-layout found)))
 319         (aver layout)
 320         layout))
 321      (t
 322       (make-wrapper-internal
 323        :length length
 324        :class (sb-kernel:make-standard-class :name name :pcl-class class))))))
 325
 326 ;;; The following variable may be set to a STANDARD-CLASS that has
 327 ;;; already been created by the lisp code and which is to be redefined
 328 ;;; by PCL. This allows STANDARD-CLASSes to be defined and used for
 329 ;;; type testing and dispatch before PCL is loaded.
 330 (defvar *pcl-class-boot* nil)
 331
 332 ;;; In SBCL, as in CMU CL, the layouts (a.k.a wrappers) for built-in
 333 ;;; and structure classes already exist when PCL is initialized, so we
 334 ;;; don't necessarily always make a wrapper. Also, we help maintain
 335 ;;; the mapping between CL:CLASS and PCL::CLASS objects.
 336 (defun make-wrapper (length class)
 337   (cond
 338    ((typep class 'std-class)
 339     (make-wrapper-internal
 340      :length length
 341      :class
 342      (let ((owrap (class-wrapper class)))
 343        (cond (owrap
 344               (sb-kernel:layout-class owrap))
 345              ((*subtypep (class-of class)
 346                          *the-class-standard-class*)
 347               (cond ((and *pcl-class-boot*
 348                           (eq (slot-value class 'name) *pcl-class-boot*))
 349                      (let ((found (cl:find-class (slot-value class 'name))))
 350                        (unless (sb-kernel:class-pcl-class found)
 351                          (setf (sb-kernel:class-pcl-class found) class))
 352                        (aver (eq (sb-kernel:class-pcl-class found) class))
 353                        found))
 354                     (t
 355                      (sb-kernel:make-standard-class :pcl-class class))))
 356              (t
 357               (sb-kernel:make-random-pcl-class :pcl-class class))))))
 358    (t
 359     (let* ((found (cl:find-class (slot-value class 'name)))
 360            (layout (sb-kernel:class-layout found)))
 361       (unless (sb-kernel:class-pcl-class found)
 362         (setf (sb-kernel:class-pcl-class found) class))
 363       (aver (eq (sb-kernel:class-pcl-class found) class))
 364       (aver layout)
 365       layout))))
 366
 367 (defconstant +first-wrapper-cache-number-index+ 0)
 368
 369 (declaim (inline next-wrapper-cache-number-index))
 370 (defun next-wrapper-cache-number-index (field-number)
 371   (and (< field-number #.(1- wrapper-cache-number-vector-length))
 372        (1+ field-number)))
 373
 374 ;;; FIXME: Why are there two layers here, with one operator trivially
 375 ;;; defined in terms of the other? It'd be nice either to have a
 376 ;;; comment explaining why the separation is valuable, or to collapse
 377 ;;; it into a single layer.
 378 ;;;
 379 ;;; FIXME (?): These are logically inline functions, but they need to
 380 ;;; be SETFable, and for now it seems not worth the trouble to DEFUN
 381 ;;; both inline FOO and inline (SETF FOO) for each one instead of a
 382 ;;; single macro. Perhaps the best thing would be to make them
 383 ;;; immutable (since it seems sort of surprising and gross to be able
 384 ;;; to modify hash values) so that they can become inline functions
 385 ;;; with no muss or fuss. I (WHN) didn't do this only because I didn't
 386 ;;; know whether any code anywhere depends on the values being
 387 ;;; modified.
 388 (defmacro cache-number-vector-ref (cnv n)
 389   `(wrapper-cache-number-vector-ref ,cnv ,n))
 390 (defmacro wrapper-cache-number-vector-ref (wrapper n)
 391   `(sb-kernel:layout-clos-hash ,wrapper ,n))
 392
 393 (declaim (inline wrapper-class*))
 394 (defun wrapper-class* (wrapper)
 395   (or (wrapper-class wrapper)
 396       (find-structure-class
 397        (cl:class-name (sb-kernel:layout-class wrapper)))))
 398
 399 ;;; The wrapper cache machinery provides general mechanism for
 400 ;;; trapping on the next access to any instance of a given class. This
 401 ;;; mechanism is used to implement the updating of instances when the
 402 ;;; class is redefined (MAKE-INSTANCES-OBSOLETE). The same mechanism
 403 ;;; is also used to update generic function caches when there is a
 404 ;;; change to the superclasses of a class.
 405 ;;;
 406 ;;; Basically, a given wrapper can be valid or invalid. If it is
 407 ;;; invalid, it means that any attempt to do a wrapper cache lookup
 408 ;;; using the wrapper should trap. Also, methods on
 409 ;;; SLOT-VALUE-USING-CLASS check the wrapper validity as well. This is
 410 ;;; done by calling CHECK-WRAPPER-VALIDITY.
 411
 412 (declaim (inline invalid-wrapper-p))
 413 (defun invalid-wrapper-p (wrapper)
 414   (neq (wrapper-state wrapper) t))
 415
 416 (defvar *previous-nwrappers* (make-hash-table))
 417
 418 (defun invalidate-wrapper (owrapper state nwrapper)
 419   (ecase state
 420     ((:flush :obsolete)
 421      (let ((new-previous ()))
 422        ;; First off, a previous call to INVALIDATE-WRAPPER may have
 423        ;; recorded OWRAPPER as an NWRAPPER to update to. Since
 424        ;; OWRAPPER is about to be invalid, it no longer makes sense to
 425        ;; update to it.
 426        ;;
 427        ;; We go back and change the previously invalidated wrappers so
 428        ;; that they will now update directly to NWRAPPER. This
 429        ;; corresponds to a kind of transitivity of wrapper updates.
 430        (dolist (previous (gethash owrapper *previous-nwrappers*))
 431          (when (eq state :obsolete)
 432            (setf (car previous) :obsolete))
 433          (setf (cadr previous) nwrapper)
 434          (push previous new-previous))
 435
 436        (let ((ocnv (wrapper-cache-number-vector owrapper)))
 437          (dotimes (i sb-kernel:layout-clos-hash-length)
 438            (setf (cache-number-vector-ref ocnv i) 0)))
 439        (push (setf (wrapper-state owrapper) (list state nwrapper))
 440              new-previous)
 441
 442        (setf (gethash owrapper *previous-nwrappers*) ()
 443              (gethash nwrapper *previous-nwrappers*) new-previous)))))
 444
 445 (defun check-wrapper-validity (instance)
 446   (let* ((owrapper (wrapper-of instance))
 447          (state (wrapper-state owrapper)))
 448     (if (eq state t)
 449         owrapper
 450         (let ((nwrapper
 451                 (ecase (car state)
 452                   (:flush
 453                     (flush-cache-trap owrapper (cadr state) instance))
 454                   (:obsolete
 455                     (obsolete-instance-trap owrapper (cadr state) instance)))))
 456           ;; This little bit of error checking is superfluous. It only
 457           ;; checks to see whether the person who implemented the trap
 458           ;; handling screwed up. Since that person is hacking
 459           ;; internal PCL code, and is not a user, this should be
 460           ;; needless. Also, since this directly slows down instance
 461           ;; update and generic function cache refilling, feel free to
 462           ;; take it out sometime soon.
 463           ;;
 464           ;; FIXME: We probably need to add a #+SB-PARANOID feature to
 465           ;; make stuff like this optional. Until then, it stays in.
 466           (cond ((neq nwrapper (wrapper-of instance))
 467                  (error "wrapper returned from trap not wrapper of instance"))
 468                 ((invalid-wrapper-p nwrapper)
 469                  (error "wrapper returned from trap invalid")))
 470           nwrapper))))
 471
 472 (defmacro check-wrapper-validity1 (object)
 473   (let ((owrapper (gensym)))
 474     `(let ((,owrapper (sb-kernel:layout-of object)))
 475        (if (sb-kernel:layout-invalid ,owrapper)
 476            (check-wrapper-validity ,object)
 477            ,owrapper))))
 478 \f
 479 (defvar *free-caches* nil)
 480
 481 (defun get-cache (nkeys valuep limit-fn nlines)
 482   (let ((cache (or (sb-sys:without-interrupts (pop *free-caches*))
 483                    (make-cache))))
 484     (declare (type cache cache))
 485     (multiple-value-bind (cache-mask actual-size line-size nlines)
 486         (compute-cache-parameters nkeys valuep nlines)
 487       (setf (cache-nkeys cache) nkeys
 488             (cache-valuep cache) valuep
 489             (cache-nlines cache) nlines
 490             (cache-field cache) +first-wrapper-cache-number-index+
 491             (cache-limit-fn cache) limit-fn
 492             (cache-mask cache) cache-mask
 493             (cache-size cache) actual-size
 494             (cache-line-size cache) line-size
 495             (cache-max-location cache) (let ((line (1- nlines)))
 496                                          (if (= nkeys 1)
 497                                              (* line line-size)
 498                                              (1+ (* line line-size))))
 499             (cache-vector cache) (get-cache-vector actual-size)
 500             (cache-overflow cache) nil)
 501       cache)))
 502
 503 (defun get-cache-from-cache (old-cache new-nlines
 504                              &optional (new-field +first-wrapper-cache-number-index+))
 505   (let ((nkeys (cache-nkeys old-cache))
 506         (valuep (cache-valuep old-cache))
 507         (cache (or (sb-sys:without-interrupts (pop *free-caches*))
 508                    (make-cache))))
 509     (declare (type cache cache))
 510     (multiple-value-bind (cache-mask actual-size line-size nlines)
 511         (if (= new-nlines (cache-nlines old-cache))
 512             (values (cache-mask old-cache) (cache-size old-cache)
 513                     (cache-line-size old-cache) (cache-nlines old-cache))
 514             (compute-cache-parameters nkeys valuep new-nlines))
 515       (setf (cache-owner cache) (cache-owner old-cache)
 516             (cache-nkeys cache) nkeys
 517             (cache-valuep cache) valuep
 518             (cache-nlines cache) nlines
 519             (cache-field cache) new-field
 520             (cache-limit-fn cache) (cache-limit-fn old-cache)
 521             (cache-mask cache) cache-mask
 522             (cache-size cache) actual-size
 523             (cache-line-size cache) line-size
 524             (cache-max-location cache) (let ((line (1- nlines)))
 525                                          (if (= nkeys 1)
 526                                              (* line line-size)
 527                                              (1+ (* line line-size))))
 528             (cache-vector cache) (get-cache-vector actual-size)
 529             (cache-overflow cache) nil)
 530       cache)))
 531
 532 (defun copy-cache (old-cache)
 533   (let* ((new-cache (copy-cache-internal old-cache))
 534          (size (cache-size old-cache))
 535          (old-vector (cache-vector old-cache))
 536          (new-vector (get-cache-vector size)))
 537     (declare (simple-vector old-vector new-vector))
 538     (dotimes-fixnum (i size)
 539       (setf (svref new-vector i) (svref old-vector i)))
 540     (setf (cache-vector new-cache) new-vector)
 541     new-cache))
 542
 543 (defun free-cache (cache)
 544   (free-cache-vector (cache-vector cache))
 545   (setf (cache-vector cache) #())
 546   (setf (cache-owner cache) nil)
 547   (push cache *free-caches*)
 548   nil)
 549
 550 (defun compute-line-size (x)
 551   (power-of-two-ceiling x))
 552
 553 (defun compute-cache-parameters (nkeys valuep nlines-or-cache-vector)
 554   ;;(declare (values cache-mask actual-size line-size nlines))
 555   (declare (fixnum nkeys))
 556   (if (= nkeys 1)
 557       (let* ((line-size (if valuep 2 1))
 558              (cache-size (if (typep nlines-or-cache-vector 'fixnum)
 559                              (the fixnum
 560                                   (* line-size
 561                                      (the fixnum
 562                                           (power-of-two-ceiling
 563                                             nlines-or-cache-vector))))
 564                              (cache-vector-size nlines-or-cache-vector))))
 565         (declare (fixnum line-size cache-size))
 566         (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
 567                 cache-size
 568                 line-size
 569                 (the (values fixnum t) (floor cache-size line-size))))
 570       (let* ((line-size (power-of-two-ceiling (if valuep (1+ nkeys) nkeys)))
 571              (cache-size (if (typep nlines-or-cache-vector 'fixnum)
 572                              (the fixnum
 573                                   (* line-size
 574                                      (the fixnum
 575                                           (power-of-two-ceiling
 576                                             nlines-or-cache-vector))))
 577                              (1- (cache-vector-size nlines-or-cache-vector)))))
 578         (declare (fixnum line-size cache-size))
 579         (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
 580                 (the fixnum (1+ cache-size))
 581                 line-size
 582                 (the (values fixnum t) (floor cache-size line-size))))))
 583 \f
 584 ;;; the various implementations of computing a primary cache location from
 585 ;;; wrappers. Because some implementations of this must run fast there are
 586 ;;; several implementations of the same algorithm.
 587 ;;;
 588 ;;; The algorithm is:
 589 ;;;
 590 ;;;  SUM       over the wrapper cache numbers,
 591 ;;;  ENSURING  that the result is a fixnum
 592 ;;;  MASK      the result against the mask argument.
 593
 594 ;;; The basic functional version. This is used by the cache miss code to
 595 ;;; compute the primary location of an entry.
 596 (defun compute-primary-cache-location (field mask wrappers)
 597
 598   (declare (type field-type field) (fixnum mask))
 599   (if (not (listp wrappers))
 600       (logand mask
 601               (the fixnum (wrapper-cache-number-vector-ref wrappers field)))
 602       (let ((location 0) (i 0))
 603         (declare (fixnum location i))
 604         (dolist (wrapper wrappers)
 605           ;; First add the cache number of this wrapper to location.
 606           (let ((wrapper-cache-number (wrapper-cache-number-vector-ref wrapper
 607                                                                        field)))
 608             (declare (fixnum wrapper-cache-number))
 609             (if (zerop wrapper-cache-number)
 610                 (return-from compute-primary-cache-location 0)
 611                 (setq location
 612                       (the fixnum (+ location wrapper-cache-number)))))
 613           ;; Then, if we are working with lots of wrappers, deal with
 614           ;; the wrapper-cache-number-mask stuff.
 615           (when (and (not (zerop i))
 616                      (zerop (mod i wrapper-cache-number-adds-ok)))
 617             (setq location
 618                   (logand location wrapper-cache-number-mask)))
 619           (incf i))
 620         (the fixnum (1+ (logand mask location))))))
 621
 622 ;;; This version is called on a cache line. It fetches the wrappers
 623 ;;; from the cache line and determines the primary location. Various
 624 ;;; parts of the cache filling code call this to determine whether it
 625 ;;; is appropriate to displace a given cache entry.
 626 ;;;
 627 ;;; If this comes across a wrapper whose CACHE-NO is 0, it returns the
 628 ;;; symbol invalid to suggest to its caller that it would be provident
 629 ;;; to blow away the cache line in question.
 630 (defun compute-primary-cache-location-from-location (to-cache
 631                                                      from-location
 632                                                      &optional
 633                                                      (from-cache to-cache))
 634   (declare (type cache to-cache from-cache) (fixnum from-location))
 635   (let ((result 0)
 636         (cache-vector (cache-vector from-cache))
 637         (field (cache-field to-cache))
 638         (mask (cache-mask to-cache))
 639         (nkeys (cache-nkeys to-cache)))
 640     (declare (type field-type field) (fixnum result mask nkeys)
 641              (simple-vector cache-vector))
 642     (dotimes-fixnum (i nkeys)
 643       (let* ((wrapper (cache-vector-ref cache-vector (+ i from-location)))
 644              (wcn (wrapper-cache-number-vector-ref wrapper field)))
 645         (declare (fixnum wcn))
 646         (setq result (+ result wcn)))
 647       (when (and (not (zerop i))
 648                  (zerop (mod i wrapper-cache-number-adds-ok)))
 649         (setq result (logand result wrapper-cache-number-mask))))
 650     (if (= nkeys 1)
 651         (logand mask result)
 652         (the fixnum (1+ (logand mask result))))))
 653 \f
 654 ;;;  NIL              means nothing so far, no actual arg info has NILs
 655 ;;;                in the metatype
 656 ;;;  CLASS          seen all sorts of metaclasses
 657 ;;;                (specifically, more than one of the next 4 values)
 658 ;;;  T          means everything so far is the class T
 659 ;;;  STANDARD-CLASS   seen only standard classes
 660 ;;;  BUILT-IN-CLASS   seen only built in classes
 661 ;;;  STRUCTURE-CLASS  seen only structure classes
 662 (defun raise-metatype (metatype new-specializer)
 663   (let ((slot      (find-class 'slot-class))
 664         (std       (find-class 'std-class))
 665         (standard  (find-class 'standard-class))
 666         (fsc       (find-class 'funcallable-standard-class))
 667         (structure (find-class 'structure-class))
 668         (built-in  (find-class 'built-in-class)))
 669     (flet ((specializer->metatype (x)
 670              (let ((meta-specializer
 671                      (if (eq *boot-state* 'complete)
 672                          (class-of (specializer-class x))
 673                          (class-of x))))
 674                (cond ((eq x *the-class-t*) t)
 675                      ((*subtypep meta-specializer std)
 676                       'standard-instance)
 677                      ((*subtypep meta-specializer standard)
 678                       'standard-instance)
 679                      ((*subtypep meta-specializer fsc)
 680                       'standard-instance)
 681                      ((*subtypep meta-specializer structure)
 682                       'structure-instance)
 683                      ((*subtypep meta-specializer built-in)
 684                       'built-in-instance)
 685                      ((*subtypep meta-specializer slot)
 686                       'slot-instance)
 687                      (t (error "PCL cannot handle the specializer ~S (meta-specializer ~S)."
 688                                new-specializer
 689                                meta-specializer))))))
 690       ;; We implement the following table. The notation is
 691       ;; that X and Y are distinct meta specializer names.
 692       ;;
 693       ;;   NIL    <anything>    ===>  <anything>
 694       ;;    X      X        ===>      X
 695       ;;    X      Y        ===>    CLASS
 696       (let ((new-metatype (specializer->metatype new-specializer)))
 697         (cond ((eq new-metatype 'slot-instance) 'class)
 698               ((null metatype) new-metatype)
 699               ((eq metatype new-metatype) new-metatype)
 700               (t 'class))))))
 701
 702 (defmacro with-dfun-wrappers ((args metatypes)
 703                               (dfun-wrappers invalid-wrapper-p
 704                                              &optional wrappers classes types)
 705                               invalid-arguments-form
 706                               &body body)
 707   `(let* ((args-tail ,args) (,invalid-wrapper-p nil) (invalid-arguments-p nil)
 708           (,dfun-wrappers nil) (dfun-wrappers-tail nil)
 709           ,@(when wrappers
 710               `((wrappers-rev nil) (types-rev nil) (classes-rev nil))))
 711      (dolist (mt ,metatypes)
 712        (unless args-tail
 713          (setq invalid-arguments-p t)
 714          (return nil))
 715        (let* ((arg (pop args-tail))
 716               (wrapper nil)
 717               ,@(when wrappers
 718                   `((class *the-class-t*)
 719                     (type t))))
 720          (unless (eq mt t)
 721            (setq wrapper (wrapper-of arg))
 722            (when (invalid-wrapper-p wrapper)
 723              (setq ,invalid-wrapper-p t)
 724              (setq wrapper (check-wrapper-validity arg)))
 725            (cond ((null ,dfun-wrappers)
 726                   (setq ,dfun-wrappers wrapper))
 727                  ((not (consp ,dfun-wrappers))
 728                   (setq dfun-wrappers-tail (list wrapper))
 729                   (setq ,dfun-wrappers (cons ,dfun-wrappers dfun-wrappers-tail)))
 730                  (t
 731                   (let ((new-dfun-wrappers-tail (list wrapper)))
 732                     (setf (cdr dfun-wrappers-tail) new-dfun-wrappers-tail)
 733                     (setf dfun-wrappers-tail new-dfun-wrappers-tail))))
 734            ,@(when wrappers
 735                `((setq class (wrapper-class* wrapper))
 736                  (setq type `(class-eq ,class)))))
 737          ,@(when wrappers
 738              `((push wrapper wrappers-rev)
 739                (push class classes-rev)
 740                (push type types-rev)))))
 741      (if invalid-arguments-p
 742          ,invalid-arguments-form
 743          (let* (,@(when wrappers
 744                     `((,wrappers (nreverse wrappers-rev))
 745                       (,classes (nreverse classes-rev))
 746                       (,types (mapcar (lambda (class)
 747                                         `(class-eq ,class))
 748                                       ,classes)))))
 749            ,@body))))
 750 \f
 751 ;;;; some support stuff for getting a hold of symbols that we need when
 752 ;;;; building the discriminator codes. It's OK for these to be interned
 753 ;;;; symbols because we don't capture any user code in the scope in which
 754 ;;;; these symbols are bound.
 755
 756 (defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.))
 757
 758 (defun dfun-arg-symbol (arg-number)
 759   (or (nth arg-number (the list *dfun-arg-symbols*))
 760       (intern (format nil ".ARG~A." arg-number) *pcl-package*)))
 761
 762 (defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.))
 763
 764 (defun slot-vector-symbol (arg-number)
 765   (or (nth arg-number (the list *slot-vector-symbols*))
 766       (intern (format nil ".SLOTS~A." arg-number) *pcl-package*)))
 767
 768 ;; FIXME: There ought to be a good way to factor out the idiom:
 769 ;;
 770 ;; (dotimes (i (length metatypes))
 771 ;;   (push (dfun-arg-symbol i) lambda-list))
 772 ;;
 773 ;; used in the following six functions into common code that we can
 774 ;; declare inline or something.  --njf 2001-12-20
 775 (defun make-dfun-lambda-list (metatypes applyp)
 776   (let ((lambda-list nil))
 777     (dotimes (i (length metatypes))
 778       (push (dfun-arg-symbol i) lambda-list))
 779     (when applyp
 780       (push '&rest lambda-list)
 781       (push '.dfun-rest-arg. lambda-list))
 782     (nreverse lambda-list)))
 783
 784 (defun make-dlap-lambda-list (metatypes applyp)
 785   (let ((lambda-list nil))
 786     (dotimes (i (length metatypes))
 787       (push (dfun-arg-symbol i) lambda-list))
 788     ;; FIXME: This is translated directly from the old PCL code.
 789     ;; It didn't have a (PUSH '.DFUN-REST-ARG. LAMBDA-LIST) or
 790     ;; something similar, so we don't either.  It's hard to see how
 791     ;; this could be correct, since &REST wants an argument after
 792     ;; it.  This function works correctly because the caller
 793     ;; magically tacks on something after &REST.  The calling functions
 794     ;; (in dlisp.lisp) should be fixed and this function rewritten.
 795     ;; --njf 2001-12-20
 796     (when applyp
 797       (push '&rest lambda-list))
 798     (nreverse lambda-list)))
 799
 800 ;; FIXME: The next four functions suffer from having a `.DFUN-REST-ARG.'
 801 ;; in their lambda lists, but no corresponding `&REST' symbol.  We assume
 802 ;; this should be the case by analogy with the previous two functions.
 803 ;; It works, and I don't know why.  Check the calling functions and
 804 ;; fix these too.  --njf 2001-12-20
 805 (defun make-emf-call (metatypes applyp fn-variable &optional emf-type)
 806   (let ((required
 807          (let ((required nil))
 808            (dotimes (i (length metatypes))
 809              (push (dfun-arg-symbol i) required))
 810            (nreverse required))))
 811     `(,(if (eq emf-type 'fast-method-call)
 812            'invoke-effective-method-function-fast
 813            'invoke-effective-method-function)
 814       ,fn-variable ,applyp ,@required ,@(when applyp `(.dfun-rest-arg.)))))
 815
 816 (defun make-dfun-call (metatypes applyp fn-variable)
 817   (let ((required
 818          (let ((required nil))
 819            (dotimes (i (length metatypes))
 820              (push (dfun-arg-symbol i) required))
 821            (nreverse required))))
 822     (if applyp
 823         `(function-apply   ,fn-variable ,@required .dfun-rest-arg.)
 824         `(function-funcall ,fn-variable ,@required))))
 825
 826 (defun make-dfun-arg-list (metatypes applyp)
 827   (let ((required (let ((reversed-required nil))
 828                     (dotimes (i (length metatypes))
 829                       (push (dfun-arg-symbol i) reversed-required))
 830                     (nreverse reversed-required))))
 831     (if applyp
 832         `(list* ,@required .dfun-rest-arg.)
 833         `(list ,@required))))
 834
 835 (defun make-fast-method-call-lambda-list (metatypes applyp)
 836   (let ((reversed-lambda-list nil))
 837     (push '.pv-cell. reversed-lambda-list)
 838     (push '.next-method-call. reversed-lambda-list)
 839     (dotimes (i (length metatypes))
 840       (push (dfun-arg-symbol i) reversed-lambda-list))
 841     (when applyp
 842       (push '.dfun-rest-arg. reversed-lambda-list))
 843     (nreverse reversed-lambda-list)))
 844 \f
 845 ;;;; a comment from some PCL implementor:
 846 ;;;;     Its too bad Common Lisp compilers freak out when you have a
 847 ;;;;   DEFUN with a lot of LABELS in it. If I could do that I could
 848 ;;;;   make this code much easier to read and work with.
 849 ;;;;     Ahh Scheme...
 850 ;;;;     In the absence of that, the following little macro makes the
 851 ;;;;   code that follows a little bit more reasonable. I would like to
 852 ;;;;   add that having to practically write my own compiler in order to
 853 ;;;;   get just this simple thing is something of a drag.
 854 ;;;;
 855 ;;;; KLUDGE: Maybe we could actually implement this as LABELS now,
 856 ;;;; since AFAIK CMU CL doesn't freak out when you have a DEFUN with a
 857 ;;;; lot of LABELS in it (and if it does we can fix it instead of
 858 ;;;; working around it). -- WHN 19991204
 859
 860 (eval-when (:compile-toplevel :load-toplevel :execute)
 861
 862 (defvar *cache* nil)
 863
 864 ;;; FIXME: should be undefined after bootstrapping
 865 (defparameter *local-cache-functions*
 866   '((cache () .cache.)
 867     (nkeys () (cache-nkeys .cache.))
 868     (line-size () (cache-line-size .cache.))
 869     (vector () (cache-vector .cache.))
 870     (valuep () (cache-valuep .cache.))
 871     (nlines () (cache-nlines .cache.))
 872     (max-location () (cache-max-location .cache.))
 873     (limit-fn () (cache-limit-fn .cache.))
 874     (size () (cache-size .cache.))
 875     (mask () (cache-mask .cache.))
 876     (field () (cache-field .cache.))
 877     (overflow () (cache-overflow .cache.))
 878
 879     ;; Return T IFF this cache location is reserved. The only time
 880     ;; this is true is for line number 0 of an nkeys=1 cache.
 881     (line-reserved-p (line)
 882       (declare (fixnum line))
 883       (and (= (nkeys) 1)
 884            (= line 0)))
 885     (location-reserved-p (location)
 886       (declare (fixnum location))
 887       (and (= (nkeys) 1)
 888            (= location 0)))
 889     ;; Given a line number, return the cache location. This is the
 890     ;; value that is the second argument to cache-vector-ref. Basically,
 891     ;; this deals with the offset of nkeys>1 caches and multiplies
 892     ;; by line size.
 893     (line-location (line)
 894       (declare (fixnum line))
 895       (when (line-reserved-p line)
 896         (error "Line is reserved."))
 897       (if (= (nkeys) 1)
 898           (the fixnum (* line (line-size)))
 899           (the fixnum (1+ (the fixnum (* line (line-size)))))))
 900
 901     ;; Given a cache location, return the line. This is the inverse
 902     ;; of LINE-LOCATION.
 903     (location-line (location)
 904       (declare (fixnum location))
 905       (if (= (nkeys) 1)
 906           (floor location (line-size))
 907           (floor (the fixnum (1- location)) (line-size))))
 908
 909     ;; Given a line number, return the wrappers stored at that line.
 910     ;; As usual, if nkeys=1, this returns a single value. Only when
 911     ;; nkeys>1 does it return a list. An error is signalled if the
 912     ;; line is reserved.
 913     (line-wrappers (line)
 914       (declare (fixnum line))
 915       (when (line-reserved-p line) (error "Line is reserved."))
 916       (location-wrappers (line-location line)))
 917     (location-wrappers (location) ; avoid multiplies caused by line-location
 918       (declare (fixnum location))
 919       (if (= (nkeys) 1)
 920           (cache-vector-ref (vector) location)
 921           (let ((list (make-list (nkeys)))
 922                 (vector (vector)))
 923             (declare (simple-vector vector))
 924             (dotimes-fixnum (i (nkeys) list)
 925               (setf (nth i list) (cache-vector-ref vector (+ location i)))))))
 926
 927     ;; Given a line number, return true IFF the line's
 928     ;; wrappers are the same as wrappers.
 929     (line-matches-wrappers-p (line wrappers)
 930       (declare (fixnum line))
 931       (and (not (line-reserved-p line))
 932            (location-matches-wrappers-p (line-location line) wrappers)))
 933     (location-matches-wrappers-p (loc wrappers) ; must not be reserved
 934       (declare (fixnum loc))
 935       (let ((cache-vector (vector)))
 936         (declare (simple-vector cache-vector))
 937         (if (= (nkeys) 1)
 938             (eq wrappers (cache-vector-ref cache-vector loc))
 939             (dotimes-fixnum (i (nkeys) t)
 940               (unless (eq (pop wrappers)
 941                           (cache-vector-ref cache-vector (+ loc i)))
 942                 (return nil))))))
 943
 944     ;; Given a line number, return the value stored at that line.
 945     ;; If valuep is NIL, this returns NIL. As with line-wrappers,
 946     ;; an error is signalled if the line is reserved.
 947     (line-value (line)
 948       (declare (fixnum line))
 949       (when (line-reserved-p line) (error "Line is reserved."))
 950       (location-value (line-location line)))
 951     (location-value (loc)
 952       (declare (fixnum loc))
 953       (and (valuep)
 954            (cache-vector-ref (vector) (+ loc (nkeys)))))
 955
 956     ;; Given a line number, return true iff that line has data in
 957     ;; it. The state of the wrappers stored in the line is not
 958     ;; checked. An error is signalled if line is reserved.
 959     (line-full-p (line)
 960       (when (line-reserved-p line) (error "Line is reserved."))
 961       (not (null (cache-vector-ref (vector) (line-location line)))))
 962
 963     ;; Given a line number, return true iff the line is full and
 964     ;; there are no invalid wrappers in the line, and the line's
 965     ;; wrappers are different from wrappers.
 966     ;; An error is signalled if the line is reserved.
 967     (line-valid-p (line wrappers)
 968       (declare (fixnum line))
 969       (when (line-reserved-p line) (error "Line is reserved."))
 970       (location-valid-p (line-location line) wrappers))
 971     (location-valid-p (loc wrappers)
 972       (declare (fixnum loc))
 973       (let ((cache-vector (vector))
 974             (wrappers-mismatch-p (null wrappers)))
 975         (declare (simple-vector cache-vector))
 976         (dotimes-fixnum (i (nkeys) wrappers-mismatch-p)
 977           (let ((wrapper (cache-vector-ref cache-vector (+ loc i))))
 978             (when (or (null wrapper)
 979                       (invalid-wrapper-p wrapper))
 980               (return nil))
 981             (unless (and wrappers
 982                          (eq wrapper
 983                              (if (consp wrappers) (pop wrappers) wrappers)))
 984               (setq wrappers-mismatch-p t))))))
 985
 986     ;; how many unreserved lines separate line-1 and line-2
 987     (line-separation (line-1 line-2)
 988      (declare (fixnum line-1 line-2))
 989      (let ((diff (the fixnum (- line-2 line-1))))
 990        (declare (fixnum diff))
 991        (when (minusp diff)
 992          (setq diff (+ diff (nlines)))
 993          (when (line-reserved-p 0)
 994            (setq diff (1- diff))))
 995        diff))
 996
 997     ;; Given a cache line, get the next cache line. This will not
 998     ;; return a reserved line.
 999     (next-line (line)
1000      (declare (fixnum line))
1001      (if (= line (the fixnum (1- (nlines))))
1002          (if (line-reserved-p 0) 1 0)
1003          (the fixnum (1+ line))))
1004     (next-location (loc)
1005       (declare (fixnum loc))
1006       (if (= loc (max-location))
1007           (if (= (nkeys) 1)
1008               (line-size)
1009               1)
1010           (the fixnum (+ loc (line-size)))))
1011
1012     ;; Given a line which has a valid entry in it, this will return
1013     ;; the primary cache line of the wrappers in that line. We just
1014     ;; call COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this is an
1015     ;; easier packaging up of the call to it.
1016     (line-primary (line)
1017       (declare (fixnum line))
1018       (location-line (line-primary-location line)))
1019     (line-primary-location (line)
1020      (declare (fixnum line))
1021      (compute-primary-cache-location-from-location
1022        (cache) (line-location line)))))
1023
1024 (defmacro with-local-cache-functions ((cache) &body body)
1025   `(let ((.cache. ,cache))
1026      (declare (type cache .cache.))
1027      (macrolet ,(mapcar (lambda (fn)
1028                           `(,(car fn) ,(cadr fn)
1029                             `(let (,,@(mapcar (lambda (var)
1030                                                 ``(,',var ,,var))
1031                                               (cadr fn)))
1032                                ,@',(cddr fn))))
1033                         *local-cache-functions*)
1034        ,@body)))
1035
1036 ) ; EVAL-WHEN
1037 \f
1038 ;;; Here is where we actually fill, recache and expand caches.
1039 ;;;
1040 ;;; The functions FILL-CACHE and PROBE-CACHE are the ONLY external
1041 ;;; entrypoints into this code.
1042 ;;;
1043 ;;; FILL-CACHE returns 1 value: a new cache
1044 ;;;
1045 ;;;   a wrapper field number
1046 ;;;   a cache
1047 ;;;   a mask
1048 ;;;   an absolute cache size (the size of the actual vector)
1049 ;;; It tries to re-adjust the cache every time it makes a new fill.
1050 ;;; The intuition here is that we want uniformity in the number of
1051 ;;; probes needed to find an entry. Furthermore, adjusting has the
1052 ;;; nice property of throwing out any entries that are invalid.
1053 (defvar *cache-expand-threshold* 1.25)
1054
1055 (defun fill-cache (cache wrappers value &optional free-cache-p)
1056
1057   ;; FILL-CACHE won't return if WRAPPERS is nil, might as well check..
1058   (unless wrappers
1059     (error "fill-cache: WRAPPERS arg is NIL!"))
1060
1061   (or (fill-cache-p nil cache wrappers value)
1062       (and (< (ceiling (* (cache-count cache) 1.25))
1063               (if (= (cache-nkeys cache) 1)
1064                   (1- (cache-nlines cache))
1065                   (cache-nlines cache)))
1066            (adjust-cache cache wrappers value free-cache-p))
1067       (expand-cache cache wrappers value free-cache-p)))
1068
1069 (defvar *check-cache-p* nil)
1070
1071 (defmacro maybe-check-cache (cache)
1072   `(progn
1073      (when *check-cache-p*
1074        (check-cache ,cache))
1075      ,cache))
1076
1077 (defun check-cache (cache)
1078   (with-local-cache-functions (cache)
1079     (let ((location (if (= (nkeys) 1) 0 1))
1080           (limit (funcall (limit-fn) (nlines))))
1081       (dotimes-fixnum (i (nlines) cache)
1082         (when (and (not (location-reserved-p location))
1083                    (line-full-p i))
1084           (let* ((home-loc (compute-primary-cache-location-from-location
1085                             cache location))
1086                  (home (location-line (if (location-reserved-p home-loc)
1087                                           (next-location home-loc)
1088                                           home-loc)))
1089                  (sep (when home (line-separation home i))))
1090             (when (and sep (> sep limit))
1091               (error "bad cache ~S ~@
1092                       value at location ~W: ~W lines from its home. The limit is ~W."
1093                      cache location sep limit))))
1094         (setq location (next-location location))))))
1095
1096 (defun probe-cache (cache wrappers &optional default limit-fn)
1097   ;;(declare (values value))
1098   (unless wrappers
1099     ;; FIXME: This and another earlier test on a WRAPPERS arg can
1100     ;; be compact assertoids.
1101     (error "WRAPPERS arg is NIL!"))
1102   (with-local-cache-functions (cache)
1103     (let* ((location (compute-primary-cache-location (field) (mask) wrappers))
1104            (limit (funcall (or limit-fn (limit-fn)) (nlines))))
1105       (declare (fixnum location limit))
1106       (when (location-reserved-p location)
1107         (setq location (next-location location)))
1108       (dotimes-fixnum (i (1+ limit))
1109         (when (location-matches-wrappers-p location wrappers)
1110           (return-from probe-cache (or (not (valuep))
1111                                        (location-value location))))
1112         (setq location (next-location location)))
1113       (dolist (entry (overflow))
1114         (when (equal (car entry) wrappers)
1115           (return-from probe-cache (or (not (valuep))
1116                                        (cdr entry)))))
1117       default)))
1118
1119 (defun map-cache (function cache &optional set-p)
1120   (with-local-cache-functions (cache)
1121     (let ((set-p (and set-p (valuep))))
1122       (dotimes-fixnum (i (nlines) cache)
1123         (unless (or (line-reserved-p i) (not (line-valid-p i nil)))
1124           (let ((value (funcall function (line-wrappers i) (line-value i))))
1125             (when set-p
1126               (setf (cache-vector-ref (vector) (+ (line-location i) (nkeys)))
1127                     value)))))
1128       (dolist (entry (overflow))
1129         (let ((value (funcall function (car entry) (cdr entry))))
1130           (when set-p
1131             (setf (cdr entry) value))))))
1132   cache)
1133
1134 (defun cache-count (cache)
1135   (with-local-cache-functions (cache)
1136     (let ((count 0))
1137       (declare (fixnum count))
1138       (dotimes-fixnum (i (nlines) count)
1139         (unless (line-reserved-p i)
1140           (when (line-full-p i)
1141             (incf count)))))))
1142
1143 (defun entry-in-cache-p (cache wrappers value)
1144   (declare (ignore value))
1145   (with-local-cache-functions (cache)
1146     (dotimes-fixnum (i (nlines))
1147       (unless (line-reserved-p i)
1148         (when (equal (line-wrappers i) wrappers)
1149           (return t))))))
1150
1151 ;;; returns T or NIL
1152 (defun fill-cache-p (forcep cache wrappers value)
1153   (with-local-cache-functions (cache)
1154     (let* ((location (compute-primary-cache-location (field) (mask) wrappers))
1155            (primary (location-line location)))
1156       (declare (fixnum location primary))
1157       (multiple-value-bind (free emptyp)
1158           (find-free-cache-line primary cache wrappers)
1159         (when (or forcep emptyp)
1160           (when (not emptyp)
1161             (push (cons (line-wrappers free) (line-value free))
1162                   (cache-overflow cache)))
1163           ;;(fill-line free wrappers value)
1164           (let ((line free))
1165             (declare (fixnum line))
1166             (when (line-reserved-p line)
1167               (error "attempt to fill a reserved line"))
1168             (let ((loc (line-location line))
1169                   (cache-vector (vector)))
1170               (declare (fixnum loc) (simple-vector cache-vector))
1171               (cond ((= (nkeys) 1)
1172                      (setf (cache-vector-ref cache-vector loc) wrappers)
1173                      (when (valuep)
1174                        (setf (cache-vector-ref cache-vector (1+ loc)) value)))
1175                     (t
1176                      (let ((i 0))
1177                        (declare (fixnum i))
1178                        (dolist (w wrappers)
1179                          (setf (cache-vector-ref cache-vector (+ loc i)) w)
1180                          (setq i (the fixnum (1+ i)))))
1181                      (when (valuep)
1182                        (setf (cache-vector-ref cache-vector (+ loc (nkeys)))
1183                              value))))
1184               (maybe-check-cache cache))))))))
1185
1186 (defun fill-cache-from-cache-p (forcep cache from-cache from-line)
1187   (declare (fixnum from-line))
1188   (with-local-cache-functions (cache)
1189     (let ((primary (location-line
1190                     (compute-primary-cache-location-from-location
1191                      cache (line-location from-line) from-cache))))
1192       (declare (fixnum primary))
1193       (multiple-value-bind (free emptyp)
1194           (find-free-cache-line primary cache)
1195         (when (or forcep emptyp)
1196           (when (not emptyp)
1197             (push (cons (line-wrappers free) (line-value free))
1198                   (cache-overflow cache)))
1199           ;;(transfer-line from-cache-vector from-line cache-vector free)
1200           (let ((from-cache-vector (cache-vector from-cache))
1201                 (to-cache-vector (vector))
1202                 (to-line free))
1203             (declare (fixnum to-line))
1204             (if (line-reserved-p to-line)
1205                 (error "transferring something into a reserved cache line")
1206                 (let ((from-loc (line-location from-line))
1207                       (to-loc (line-location to-line)))
1208                   (declare (fixnum from-loc to-loc))
1209                   (modify-cache to-cache-vector
1210                                 (dotimes-fixnum (i (line-size))
1211                                   (setf (cache-vector-ref to-cache-vector
1212                                                           (+ to-loc i))
1213                                         (cache-vector-ref from-cache-vector
1214                                                           (+ from-loc i)))))))
1215             (maybe-check-cache cache)))))))
1216
1217 ;;; Returns NIL or (values <field> <cache-vector>)
1218 ;;;
1219 ;;; This is only called when it isn't possible to put the entry in the
1220 ;;; cache the easy way. That is, this function assumes that
1221 ;;; FILL-CACHE-P has been called as returned NIL.
1222 ;;;
1223 ;;; If this returns NIL, it means that it wasn't possible to find a
1224 ;;; wrapper field for which all of the entries could be put in the
1225 ;;; cache (within the limit).
1226 (defun adjust-cache (cache wrappers value free-old-cache-p)
1227   (with-local-cache-functions (cache)
1228     (let ((ncache (get-cache-from-cache cache (nlines) (field))))
1229       (do ((nfield (cache-field ncache) (next-wrapper-cache-number-index nfield)))
1230           ((null nfield) (free-cache ncache) nil)
1231         (setf (cache-field ncache) nfield)
1232         (labels ((try-one-fill-from-line (line)
1233                    (fill-cache-from-cache-p nil ncache cache line))
1234                  (try-one-fill (wrappers value)
1235                    (fill-cache-p nil ncache wrappers value)))
1236           (if (and (dotimes-fixnum (i (nlines) t)
1237                      (when (and (null (line-reserved-p i))
1238                                 (line-valid-p i wrappers))
1239                        (unless (try-one-fill-from-line i) (return nil))))
1240                    (dolist (wrappers+value (cache-overflow cache) t)
1241                      (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
1242                        (return nil)))
1243                    (try-one-fill wrappers value))
1244               (progn (when free-old-cache-p (free-cache cache))
1245                      (return (maybe-check-cache ncache)))
1246               (flush-cache-vector-internal (cache-vector ncache))))))))
1247
1248 ;;; returns: (values <cache>)
1249 (defun expand-cache (cache wrappers value free-old-cache-p)
1250   ;;(declare (values cache))
1251   (with-local-cache-functions (cache)
1252     (let ((ncache (get-cache-from-cache cache (* (nlines) 2))))
1253       (labels ((do-one-fill-from-line (line)
1254                  (unless (fill-cache-from-cache-p nil ncache cache line)
1255                    (do-one-fill (line-wrappers line) (line-value line))))
1256                (do-one-fill (wrappers value)
1257                  (setq ncache (or (adjust-cache ncache wrappers value t)
1258                                   (fill-cache-p t ncache wrappers value))))
1259                (try-one-fill (wrappers value)
1260                  (fill-cache-p nil ncache wrappers value)))
1261         (dotimes-fixnum (i (nlines))
1262           (when (and (null (line-reserved-p i))
1263                      (line-valid-p i wrappers))
1264             (do-one-fill-from-line i)))
1265         (dolist (wrappers+value (cache-overflow cache))
1266           (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
1267             (do-one-fill (car wrappers+value) (cdr wrappers+value))))
1268         (unless (try-one-fill wrappers value)
1269           (do-one-fill wrappers value))
1270         (when free-old-cache-p (free-cache cache))
1271         (maybe-check-cache ncache)))))
1272 \f
1273 ;;; This is the heart of the cache filling mechanism. It implements
1274 ;;; the decisions about where entries are placed.
1275 ;;;
1276 ;;; Find a line in the cache at which a new entry can be inserted.
1277 ;;;
1278 ;;;   <line>
1279 ;;;   <empty?>     is <line> in fact empty?
1280 (defun find-free-cache-line (primary cache &optional wrappers)
1281   ;;(declare (values line empty?))
1282   (declare (fixnum primary))
1283   (with-local-cache-functions (cache)
1284     (when (line-reserved-p primary) (setq primary (next-line primary)))
1285     (let ((limit (funcall (limit-fn) (nlines)))
1286           (wrappedp nil)
1287           (lines nil)
1288           (p primary) (s primary))
1289       (declare (fixnum p s limit))
1290       (block find-free
1291         (loop
1292          ;; Try to find a free line starting at <s>. <p> is the
1293          ;; primary line of the entry we are finding a free
1294          ;; line for, it is used to compute the separations.
1295          (do* ((line s (next-line line))
1296                (nsep (line-separation p s) (1+ nsep)))
1297               (())
1298            (declare (fixnum line nsep))
1299            (when (null (line-valid-p line wrappers)) ;If this line is empty or
1300              (push line lines)          ;invalid, just use it.
1301              (return-from find-free))
1302            (when (and wrappedp (>= line primary))
1303              ;; have gone all the way around the cache, time to quit
1304              (return-from find-free-cache-line (values primary nil)))
1305            (let ((osep (line-separation (line-primary line) line)))
1306              (when (>= osep limit)
1307                (return-from find-free-cache-line (values primary nil)))
1308              (when (cond ((= nsep limit) t)
1309                          ((= nsep osep) (zerop (random 2)))
1310                          ((> nsep osep) t)
1311                          (t nil))
1312                ;; See whether we can displace what is in this line so that we
1313                ;; can use the line.
1314                (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t))
1315                (setq p (line-primary line))
1316                (setq s (next-line line))
1317                (push line lines)
1318                (return nil)))
1319            (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t)))))
1320       ;; Do all the displacing.
1321       (loop
1322        (when (null (cdr lines)) (return nil))
1323        (let ((dline (pop lines))
1324              (line (car lines)))
1325          (declare (fixnum dline line))
1326          ;;Copy from line to dline (dline is known to be free).
1327          (let ((from-loc (line-location line))
1328                (to-loc (line-location dline))
1329                (cache-vector (vector)))
1330            (declare (fixnum from-loc to-loc) (simple-vector cache-vector))
1331            (modify-cache cache-vector
1332                          (dotimes-fixnum (i (line-size))
1333                            (setf (cache-vector-ref cache-vector
1334                                                    (+ to-loc i))
1335                                  (cache-vector-ref cache-vector
1336                                                    (+ from-loc i)))
1337                            (setf (cache-vector-ref cache-vector
1338                                                    (+ from-loc i))
1339                                  nil))))))
1340       (values (car lines) t))))
1341
1342 (defun default-limit-fn (nlines)
1343   (case nlines
1344     ((1 2 4) 1)
1345     ((8 16)  4)
1346     (otherwise 6)))
1347
1348 (defvar *empty-cache* (make-cache)) ; for defstruct slot initial value forms
1349 \f
1350 ;;; Pre-allocate generic function caches. The hope is that this will
1351 ;;; put them nicely together in memory, and that that may be a win. Of
1352 ;;; course the first GC copy will probably blow that out, this really
1353 ;;; wants to be wrapped in something that declares the area static.
1354 ;;;
1355 ;;; This preallocation only creates about 25% more caches than PCL
1356 ;;; itself uses. Some ports may want to preallocate some more of
1357 ;;; these.
1358 ;;;
1359 ;;; KLUDGE: Isn't something very similar going on in precom1.lisp? Do
1360 ;;; we need it both here and there? Why? -- WHN 19991203
1361 (eval-when (:load-toplevel)
1362   (dolist (n-size '((1 513) (3 257) (3 129) (14 128) (6 65)
1363                     (2 64) (7 33) (16 32) (16 17) (32 16)
1364                     (64 9) (64 8) (6 5) (128 4) (35 2)))
1365     (let ((n (car n-size))
1366           (size (cadr n-size)))
1367       (mapcar #'free-cache-vector
1368               (mapcar #'get-cache-vector
1369                       (make-list n :initial-element size))))))