/[cmucl]/src/pcl/cache.lisp
ViewVC logotype

Contents of /src/pcl/cache.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.36 - (show annotations)
Fri Mar 19 15:19:03 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.35: +13 -12 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
1 ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
2 ;;;
3 ;;; *************************************************************************
4 ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5 ;;; All rights reserved.
6 ;;;
7 ;;; Use and copying of this software and preparation of derivative works
8 ;;; based upon this software are permitted. Any distribution of this
9 ;;; software or derivative works must comply with all applicable United
10 ;;; States export control laws.
11 ;;;
12 ;;; This software is made available AS IS, and Xerox Corporation makes no
13 ;;; warranty about the software, its performance or its conformity to any
14 ;;; specification.
15 ;;;
16 ;;; Any person obtaining a copy of this software is requested to send their
17 ;;; name and post office or electronic mail address to:
18 ;;; CommonLoops Coordinator
19 ;;; Xerox PARC
20 ;;; 3333 Coyote Hill Rd.
21 ;;; Palo Alto, CA 94304
22 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23 ;;;
24 ;;; Suggestions, comments and requests for improvements are also welcome.
25 ;;; *************************************************************************
26
27 (file-comment
28 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/cache.lisp,v 1.36 2010/03/19 15:19:03 rtoy Rel $")
29
30 ;;;
31 ;;; The basics of the PCL wrapper cache mechanism.
32 ;;;
33
34 (in-package :pcl)
35 (intl:textdomain "cmucl")
36
37 ;;;
38 ;;; The caching algorithm implemented:
39 ;;;
40 ;;; << put a paper here >>
41 ;;;
42 ;;; For now, understand that as far as most of this code goes, a cache has
43 ;;; two important properties. The first is the number of wrappers used as
44 ;;; keys in each cache line. Throughout this code, this value is always
45 ;;; called NKEYS. The second is whether or not the cache lines of a cache
46 ;;; store a value. Throughout this code, this always called VALUEP.
47 ;;;
48 ;;; Depending on these values, there are three kinds of caches.
49 ;;;
50 ;;; NKEYS = 1, VALUEP = NIL
51 ;;;
52 ;;; In this kind of cache, each line is 1 word long. No cache locking is
53 ;;; needed since all read's in the cache are a single value. Nevertheless
54 ;;; line 0 (location 0) is reserved, to ensure that invalid wrappers will
55 ;;; not get a first probe hit.
56 ;;;
57 ;;; To keep the code simpler, a cache lock count does appear in location 0
58 ;;; of these caches, that count is incremented whenever data is written to
59 ;;; the cache. But, the actual lookup code (see make-dlap) doesn't need to
60 ;;; do locking when reading the cache.
61 ;;;
62 ;;;
63 ;;; NKEYS = 1, VALUEP = T
64 ;;;
65 ;;; In this kind of cache, each line is 2 words long. Cache locking must
66 ;;; be done to ensure the synchronization of cache reads. Line 0 of the
67 ;;; cache (location 0) is reserved for the cache lock count. Location 1
68 ;;; of the cache is unused (in effect wasted).
69 ;;;
70 ;;; NKEYS > 1
71 ;;;
72 ;;; In this kind of cache, the 0 word of the cache holds the lock count.
73 ;;; The 1 word of the cache is line 0. Line 0 of these caches is not
74 ;;; reserved.
75 ;;;
76 ;;; This is done because in this sort of cache, the overhead of doing the
77 ;;; cache probe is high enough that the 1+ required to offset the location
78 ;;; is not a significant cost. In addition, because of the larger line
79 ;;; sizes, the space that would be wasted by reserving line 0 to hold the
80 ;;; lock count is more significant.
81 ;;;
82
83 ;;;
84 ;;; Caches
85 ;;;
86 ;;; A cache is essentially just a vector. The use of the individual `words'
87 ;;; in the vector depends on particular properties of the cache as described
88 ;;; above.
89 ;;;
90 ;;; This defines an abstraction for caches in terms of their most obvious
91 ;;; implementation as simple vectors. But, please notice that part of the
92 ;;; implementation of this abstraction, is the function lap-out-cache-ref.
93 ;;; This means that most port-specific modifications to the implementation
94 ;;; of caches will require corresponding port-specific modifications to the
95 ;;; lap code assembler.
96 ;;;
97
98 (declaim (inline default-limit-fn))
99
100 (defun default-limit-fn (nlines)
101 (case nlines
102 ((1 2 4) 1)
103 ((8 16) 4)
104 (otherwise 6)))
105
106 (defmacro cache-vector-ref (cache-vector location)
107 `(%svref ,cache-vector ,location))
108
109 (declaim (inline cache-vector-size))
110 (defun cache-vector-size (cache-vector)
111 (array-dimension (the simple-vector cache-vector) 0))
112
113 (defmacro cache-vector-lock-count (cache-vector)
114 `(cache-vector-ref ,cache-vector 0))
115
116 (defun flush-cache-vector-internal (cache-vector)
117 (with-pcl-lock
118 (fill (the simple-vector cache-vector) nil)
119 (setf (cache-vector-lock-count cache-vector) 0))
120 cache-vector)
121
122 (defmacro modify-cache (cache-vector &body body)
123 `(with-pcl-lock
124 (multiple-value-prog1
125 (progn ,@body)
126 (let ((old-count (cache-vector-lock-count ,cache-vector)))
127 (declare (fixnum old-count))
128 (setf (cache-vector-lock-count ,cache-vector)
129 (if (= old-count most-positive-fixnum)
130 1
131 (the fixnum (1+ old-count))))))))
132
133 (deftype layout-hash-index ()
134 '(integer 0 #.(1- kernel:layout-hash-length)))
135
136 (eval-when (:compile-toplevel :load-toplevel :execute)
137 (defun power-of-two-ceiling (x)
138 (declare (fixnum x))
139 (the fixnum (ash 1 (integer-length (1- x)))))
140
141 (defconstant +nkeys-limit+ 256))
142
143 (defstruct (cache
144 (:print-function print-cache)
145 (:constructor make-cache ())
146 (:copier copy-cache-internal))
147 (owner nil)
148 ;;
149 ;; Number of wrappers used as keys in each cache line.
150 (nkeys 1 :type (integer 1 #.+nkeys-limit+))
151 ;;
152 ;; True if keys are followed by a value in the cache.
153 (valuep nil :type (member nil t))
154 ;;
155 ;; Number of cache lines, that is, number of entries in the cache
156 ;; vector.
157 (nlines 0 :type fixnum)
158 ;;
159 ;; Index with which to call KERNEL:LAYOUT-HASH when computing
160 ;; the position of a set of wrappers in the cache.
161 (field 0 :type layout-hash-index)
162 ;;
163 ;; Mask value with which to LOGAND the hash code of a set of
164 ;; wrappers.
165 (mask 0 :type fixnum)
166 ;;
167 ;; The size of the cache vector.
168 (size 0 :type fixnum)
169 ;;
170 ;; The size of a line in the cache.
171 (line-size 1 :type (integer 1 #.(power-of-two-ceiling (1+ +nkeys-limit+))))
172 ;;
173 ;; Start index of the last cache line (cache entry) in VECTOR.
174 (max-location 0 :type fixnum)
175 ;;
176 ;; The cache vector itself, holding the cache lines. Empty entries
177 ;; are filled with NIL.
178 (vector #() :type simple-vector)
179 ;;
180 ;; List of entries not fitting in VECTOR.
181 (overflow nil :type list))
182
183 (declaim (freeze-type cache))
184
185 (defun print-cache (cache stream depth)
186 (declare (ignore depth))
187 (print-unreadable-object (cache stream :identity t)
188 (format stream "cache ~D ~S ~D"
189 (cache-nkeys cache) (cache-valuep cache) (cache-nlines cache))))
190
191
192 ;;;
193 ;;; Return a cache that has had flush-cache-vector-internal called on
194 ;;; it. This returns a cache of exactly the size requested, it won't
195 ;;; ever return a larger cache.
196 ;;;
197 (defun get-cache-vector (size)
198 (flush-cache-vector-internal (make-array size)))
199
200
201 ;;;
202 ;;; The constant +MAX-HASH-CODE-ADDITIONS+ controls the number of
203 ;;; non-zero bits wrapper cache numbers will have.
204 ;;;
205 ;;; The value of this constant is the number of wrapper cache numbers which
206 ;;; can be added and still be certain the result will be a fixnum. This is
207 ;;; used by all the code that computes primary cache locations from multiple
208 ;;; wrappers.
209 ;;;
210 (defconstant +max-hash-code-additions+
211 (truncate most-positive-fixnum kernel:layout-hash-max))
212
213
214 ;;;
215 ;;; wrappers themselves
216 ;;;
217 ;;; This caching algorithm requires that wrappers have more than one wrapper
218 ;;; cache number. You should think of these multiple numbers as being in
219 ;;; columns. That is, for a given cache, the same column of wrapper cache
220 ;;; numbers will be used.
221 ;;;
222 ;;; If at some point the cache distribution of a cache gets bad, the cache
223 ;;; can be rehashed by switching to a different column.
224 ;;;
225 ;;; The columns are referred to by field number which is that number which,
226 ;;; when used as a second argument to wrapper-ref, will return that column
227 ;;; of wrapper cache number.
228 ;;;
229 ;;; This code is written to allow flexibility as to how many wrapper cache
230 ;;; numbers will be in each wrapper, and where they will be located. It is
231 ;;; also set up to allow port specific modifications to `pack' the wrapper
232 ;;; cache numbers on machines where the addressing modes make that a good
233 ;;; idea.
234 ;;;
235
236 ;;; In CMUCL we want to do type checking as early as possible;
237 ;;; structures help this.
238
239 (unless (boundp '*the-class-t*)
240 (setq *the-class-t* nil))
241
242 ;;;
243 ;;; Note that for CMU, the WRAPPER of a built-in or structure class
244 ;;; will be some other kind of KERNEL:LAYOUT, but this shouldn't
245 ;;; matter, since the only two slots that WRAPPER adds are meaningless
246 ;;; in those cases.
247 ;;;
248 (defstruct (wrapper
249 (:include kernel:layout)
250 (:conc-name %wrapper-)
251 (:print-function print-wrapper)
252 (:constructor make-wrapper-internal))
253 ;;
254 ;; List of all instance slot names. The position of a slot name
255 ;; in this list determines the location of its slot in an instance's
256 ;; slot value vector.
257 (instance-slots-layout nil :type list)
258 ;;
259 ;; Alist of pairs (SLOT-NAME . VALUE) for class slots. Pairs are
260 ;; shared with subclasses inheriting a class slot.
261 (class-slots nil :type list))
262
263 (declaim (freeze-type wrapper))
264
265 (defmacro wrapper-class (wrapper)
266 `(kernel:%class-pcl-class (kernel:layout-class ,wrapper)))
267
268 (defmacro wrapper-no-of-instance-slots (wrapper)
269 `(kernel:layout-length ,wrapper))
270
271 (defmacro wrapper-instance-slots-layout (wrapper)
272 `(%wrapper-instance-slots-layout ,wrapper))
273
274 (defmacro wrapper-class-slots (wrapper)
275 `(%wrapper-class-slots ,wrapper))
276
277 ;;;
278 ;;; BOOT-MAKE-WRAPPER -- Interface
279 ;;;
280 ;;; Called in BRAID when we are making wrappers for classes whose slots are
281 ;;; not initialized yet, and which may be built-in classes. We pass in the
282 ;;; class name in addition to the class.
283 ;;;
284 (defun boot-make-wrapper (length name &optional class)
285 (let ((found (kernel::find-class name nil)))
286 (cond
287 (found
288 (unless (kernel:%class-pcl-class found)
289 (setf (kernel:%class-pcl-class found) class))
290 (assert (eq (kernel:%class-pcl-class found) class))
291 (let ((layout (kernel:%class-layout found)))
292 (assert layout)
293 layout))
294 (t
295 (kernel:initialize-layout-hash
296 (make-wrapper-internal
297 :length length
298 :class (kernel:make-standard-class :name name :pcl-class class)))))))
299
300
301 ;;; The following variable may be set to a standard-class that has
302 ;;; already been created by the lisp code and which is to be redefined
303 ;;; by PCL. This allows standard-classes to be defined and used for
304 ;;; type testing and dispatch before PCL is loaded.
305
306 (defvar *pcl-class-boot* nil)
307
308 ;;; MAKE-WRAPPER -- Interface
309 ;;;
310 ;;; In CMU CL, the layouts (a.k.a wrappers) for built-in and structure
311 ;;; classes already exist when PCL is initialized, so we don't necessarily
312 ;;; always make a wrapper. Also, we help maintain the mapping between
313 ;;; lisp:class and pcl::class objects.
314 ;;;
315 (defun make-wrapper (length class)
316 (cond ((or (typep class 'std-class)
317 (typep class 'forward-referenced-class))
318 (kernel:initialize-layout-hash
319 (make-wrapper-internal
320 :length length
321 :class
322 (let ((owrap (class-wrapper class)))
323 (cond (owrap
324 (kernel:layout-class owrap))
325 ((or (*subtypep (class-of class) *the-class-standard-class*)
326 (typep class 'forward-referenced-class))
327 (cond ((and *pcl-class-boot*
328 (eq (slot-value class 'name) *pcl-class-boot*))
329 (let ((found (kernel::find-class
330 (slot-value class 'name))))
331 (unless (kernel:%class-pcl-class found)
332 (setf (kernel:%class-pcl-class found) class))
333 (assert (eq (kernel:%class-pcl-class found) class))
334 found))
335 (t
336 (kernel:make-standard-class :pcl-class class))))
337 (t
338 (kernel:make-random-pcl-class :pcl-class class)))))))
339 (t
340 (let* ((found (kernel::find-class (slot-value class 'name)))
341 (layout (kernel:%class-layout found)))
342 (unless (kernel:%class-pcl-class found)
343 (setf (kernel:%class-pcl-class found) class))
344 (assert (eq (kernel:%class-pcl-class found) class))
345 (assert layout)
346 layout))))
347
348 (defun print-wrapper (wrapper stream depth)
349 (declare (ignore depth))
350 (print-unreadable-object (wrapper stream :identity t)
351 (format stream _"Wrapper ~S" (wrapper-class wrapper))))
352
353 (defmacro wrapper-class* (wrapper)
354 `(let ((wrapper ,wrapper))
355 (or (wrapper-class wrapper)
356 (ensure-non-standard-class
357 (kernel:%class-name (kernel:layout-class wrapper))))))
358
359 ;;;
360 ;;; The wrapper cache machinery provides general mechanism for trapping on
361 ;;; the next access to any instance of a given class. This mechanism is
362 ;;; used to implement the updating of instances when the class is redefined
363 ;;; (make-instances-obsolete). The same mechanism is also used to update
364 ;;; generic function caches when there is a change to the supers of a class.
365 ;;;
366 ;;; Basically, a given wrapper can be valid or invalid. If it is invalid,
367 ;;; it means that any attempt to do a wrapper cache lookup using the wrapper
368 ;;; should trap. Also, methods on slot-value-using-class check the wrapper
369 ;;; validity as well. This is done by calling check-wrapper-validity.
370 ;;;
371
372 (declaim (inline invalid-wrapper-p))
373 (defun invalid-wrapper-p (wrapper)
374 (not (null (kernel:layout-invalid wrapper))))
375
376 (defvar *previous-nwrappers* (make-hash-table))
377
378 (defun invalidate-wrapper (owrapper state nwrapper)
379 (assert (member state '(:flush :obsolete) :test #'eq))
380 (let ((new-previous ()))
381 ;;
382 ;; First off, a previous call to invalidate-wrapper may have recorded
383 ;; owrapper as an nwrapper to update to. Since owrapper is about to
384 ;; be invalid, it no longer makes sense to update to it.
385 ;;
386 ;; We go back and change the previously invalidated wrappers so that
387 ;; they will now update directly to nwrapper. This corresponds to a
388 ;; kind of transitivity of wrapper updates.
389 ;;
390 (dolist (previous (gethash owrapper *previous-nwrappers*))
391 (when (eq state :obsolete)
392 (setf (first previous) :obsolete))
393 (setf (second previous) nwrapper)
394 (push previous new-previous))
395
396 (loop for i below kernel:layout-hash-length do
397 (setf (kernel:layout-hash owrapper i) 0))
398
399 (let ((new-state (list state nwrapper)))
400 (setf (kernel:layout-invalid owrapper) new-state)
401 (push new-state new-previous)
402 (setf (gethash owrapper *previous-nwrappers*) ()
403 (gethash nwrapper *previous-nwrappers*) new-previous))))
404
405 (defun check-wrapper-validity (instance)
406 (let* ((owrapper (wrapper-of instance))
407 (state (kernel:layout-invalid owrapper)))
408 (cond ((null state)
409 owrapper)
410 ;;
411 ;; We assume in this case, that the :INVALID is from a
412 ;; previous call to REGISTER-LAYOUT for a superclass of
413 ;; INSTANCE's class. See also the comment above
414 ;; FORCE-CACHE-FLUSHES. Paul Dietz has test cases for this.
415 ;; Note that FORCE-CACHE-FLUSHES may change LAYOUT-INVALID,
416 ;; so we have to recurse.
417 ((eq state :invalid)
418 (force-cache-flushes (class-of instance))
419 (check-wrapper-validity instance))
420 ((eq (car state) :flush)
421 (flush-cache-trap owrapper (second state) instance))
422 ((eq (car state) :obsolete)
423 (obsolete-instance-trap owrapper (second state) instance))
424 (t
425 (internal-error _"Unknown wrapper state")))))
426
427 (declaim (inline check-obsolete-instance))
428 (defun check-obsolete-instance (instance)
429 (when (invalid-wrapper-p (kernel:layout-of instance))
430 (check-wrapper-validity instance)))
431
432
433 (defun get-cache (nkeys valuep nlines)
434 (let ((cache (make-cache)))
435 (declare (type cache cache))
436 (multiple-value-bind (cache-mask actual-size line-size nlines)
437 (compute-cache-parameters nkeys valuep nlines)
438 (setf (cache-nkeys cache) nkeys
439 (cache-valuep cache) valuep
440 (cache-nlines cache) nlines
441 (cache-field cache) 0
442 (cache-mask cache) cache-mask
443 (cache-size cache) actual-size
444 (cache-line-size cache) line-size
445 (cache-max-location cache) (let ((line (1- nlines)))
446 (if (= nkeys 1)
447 (* line line-size)
448 (1+ (* line line-size))))
449 (cache-vector cache) (get-cache-vector actual-size)
450 (cache-overflow cache) nil)
451 cache)))
452
453 (defun get-cache-from-cache (old-cache new-nlines &optional (new-field 0))
454 (let ((nkeys (cache-nkeys old-cache))
455 (valuep (cache-valuep old-cache))
456 (cache (make-cache)))
457 (declare (type cache cache))
458 (multiple-value-bind (cache-mask actual-size line-size nlines)
459 (if (= new-nlines (cache-nlines old-cache))
460 (values (cache-mask old-cache) (cache-size old-cache)
461 (cache-line-size old-cache) (cache-nlines old-cache))
462 (compute-cache-parameters nkeys valuep new-nlines))
463 (setf (cache-owner cache) (cache-owner old-cache)
464 (cache-nkeys cache) nkeys
465 (cache-valuep cache) valuep
466 (cache-nlines cache) nlines
467 (cache-field cache) new-field
468 (cache-mask cache) cache-mask
469 (cache-size cache) actual-size
470 (cache-line-size cache) line-size
471 (cache-max-location cache) (let ((line (1- nlines)))
472 (if (= nkeys 1)
473 (* line line-size)
474 (1+ (* line line-size))))
475 (cache-vector cache) (get-cache-vector actual-size)
476 (cache-overflow cache) nil)
477 cache)))
478
479 (defun copy-cache (old-cache)
480 (let* ((new-cache (copy-cache-internal old-cache))
481 (size (cache-size old-cache))
482 (old-vector (cache-vector old-cache))
483 (new-vector (get-cache-vector size)))
484 (declare (simple-vector old-vector new-vector))
485 (dotimes (i size)
486 (declare (fixnum i))
487 (setf (svref new-vector i) (svref old-vector i)))
488 (setf (cache-vector new-cache) new-vector)
489 new-cache))
490
491 (defun compute-line-size (x)
492 (power-of-two-ceiling x))
493
494 (defun compute-cache-parameters (nkeys valuep nlines-or-cache-vector)
495 (declare (fixnum nkeys))
496 (if (= nkeys 1)
497 (let* ((line-size (if valuep 2 1))
498 (cache-size (if (typep nlines-or-cache-vector 'fixnum)
499 (the fixnum
500 (* line-size
501 (the fixnum
502 (power-of-two-ceiling
503 nlines-or-cache-vector))))
504 (cache-vector-size nlines-or-cache-vector))))
505 (declare (fixnum line-size cache-size))
506 (values (logxor (the fixnum (1- cache-size))
507 (the fixnum (1- line-size)))
508 cache-size
509 line-size
510 (the (values fixnum t) (floor cache-size line-size))))
511 (let* ((line-size (power-of-two-ceiling (if valuep (1+ nkeys) nkeys)))
512 (cache-size (if (typep nlines-or-cache-vector 'fixnum)
513 (the fixnum
514 (* line-size
515 (the fixnum
516 (power-of-two-ceiling
517 nlines-or-cache-vector))))
518 (1- (cache-vector-size nlines-or-cache-vector)))))
519 (declare (fixnum line-size cache-size))
520 (values (logxor (the fixnum (1- cache-size))
521 (the fixnum (1- line-size)))
522 (the fixnum (1+ cache-size))
523 line-size
524 (the (values fixnum t) (floor cache-size line-size))))))
525
526
527 ;;;
528 ;;; The various implementations of computing a primary cache location from
529 ;;; wrappers. Because some implementations of this must run fast there are
530 ;;; several implementations of the same algorithm.
531 ;;;
532 ;;; The algorithm is:
533 ;;;
534 ;;; SUM over the wrapper cache numbers,
535 ;;; ENSURING that the result is a fixnum
536 ;;; MASK the result against the mask argument.
537 ;;;
538 ;;;
539
540 ;;;
541 ;;; COMPUTE-PRIMARY-CACHE-LOCATION
542 ;;;
543 ;;; The basic functional version. This is used by the cache miss code to
544 ;;; compute the primary location of an entry.
545 ;;;
546 #-pcl-xorhash
547 (defun compute-primary-cache-location (hash-index mask wrappers)
548 (declare (type layout-hash-index hash-index) (fixnum mask)
549 #.*optimize-speed*)
550 (if (not (listp wrappers))
551 (logand mask (the fixnum (kernel:layout-hash wrappers hash-index)))
552 (loop with location of-type fixnum = 0
553 for i of-type fixnum from 0 and wrapper in wrappers
554 as hash of-type fixnum = (kernel:layout-hash wrapper hash-index)
555 if (zerop hash) do
556 ;; Invalid wrapper.
557 (return-from compute-primary-cache-location 0)
558 else do
559 (setq location (the fixnum (+ location hash)))
560 (when (and (not (zerop i))
561 (zerop (mod i +max-hash-code-additions+)))
562 (setq location (logand location kernel:layout-hash-max)))
563 end
564 finally
565 (return (the fixnum (1+ (logand mask location)))))))
566
567 #+pcl-xorhash
568 (defun compute-primary-cache-location (hash-index mask wrappers)
569 (declare (type layout-hash-index hash-index) (fixnum mask)
570 #.*optimize-speed*)
571 (if (not (listp wrappers))
572 (logand mask (the fixnum (kernel:layout-hash wrappers hash-index)))
573 (loop with location of-type fixnum = 0
574 for wrapper in wrappers
575 as hash of-type fixnum = (kernel:layout-hash wrapper hash-index)
576 if (invalid-wrapper-p wrapper) do
577 (return-from compute-primary-cache-location 0)
578 else do
579 (setq location (logxor location hash))
580 finally
581 (return (the fixnum (1+ (logand mask location)))))))
582
583 ;;;
584 ;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION
585 ;;;
586 ;;; This version is called on a cache line. It fetches the wrappers from
587 ;;; the cache line and determines the primary location. Various parts of
588 ;;; the cache filling code call this to determine whether it is appropriate
589 ;;; to displace a given cache entry.
590 ;;;
591 ;;; If this comes across a wrapper whose cache-no is 0, it returns the symbol
592 ;;; invalid to suggest to its caller that it would be provident to blow away
593 ;;; the cache line in question.
594 ;;;
595 #-pcl-xorhash
596 (defun compute-primary-cache-location-from-location
597 (to-cache from-location &optional (from-cache to-cache))
598 (declare (type cache to-cache from-cache) (fixnum from-location))
599 (loop with result of-type fixnum = 0
600 with hash-index of-type layout-hash-index = (cache-field to-cache)
601 with mask of-type fixnum = (cache-mask to-cache)
602 with nkeys of-type fixnum = (cache-nkeys to-cache)
603 with cache-vector of-type simple-vector = (cache-vector from-cache)
604 for i of-type fixnum below nkeys
605 for wrapper = (cache-vector-ref cache-vector (+ i from-location))
606 for hash = (kernel:layout-hash wrapper hash-index) do
607 (setq result (+ result hash))
608 (when (and (not (zerop i))
609 (zerop (mod i +max-hash-code-additions+)))
610 (setq result (logand result kernel:layout-hash-max)))
611 finally
612 (return (if (= nkeys 1)
613 (logand mask result)
614 (the fixnum (1+ (logand mask result)))))))
615
616 #+pcl-xorhash
617 (defun compute-primary-cache-location-from-location
618 (to-cache from-location &optional (from-cache to-cache))
619 (declare (type cache to-cache from-cache) (fixnum from-location))
620 (loop with result of-type fixnum = 0
621 with hash-index of-type layout-hash-index = (cache-field to-cache)
622 with mask of-type fixnum = (cache-mask to-cache)
623 with nkeys of-type fixnum = (cache-nkeys to-cache)
624 with cache-vector of-type simple-vector = (cache-vector from-cache)
625 for i of-type fixnum below nkeys
626 for wrapper = (cache-vector-ref cache-vector (+ i from-location))
627 as hash = (kernel:layout-hash wrapper hash-index) do
628 (setq result (logxor result hash))
629 finally
630 (return (if (= nkeys 1)
631 (logand mask result)
632 (the fixnum (1+ (logand mask result)))))))
633
634
635 ;;;
636 ;;; NIL means nothing so far, no actual arg info has NILs
637 ;;; in the metatype
638 ;;; CLASS seen all sorts of metaclasses
639 ;;; (specifically, more than one of the next 4 values)
640 ;;; T means everything so far is the class T
641 ;;; STANDARD-CLASS seen only standard classes
642 ;;; BUILT-IN-CLASS seen only built in classes
643 ;;; STRUCTURE-CLASS seen only structure classes
644 ;;;
645 (defun raise-metatype (metatype new-specializer)
646 (let ((slot (find-class 'slot-class))
647 (standard (find-class 'standard-class))
648 (fsc (find-class 'funcallable-standard-class))
649 (structure (find-class 'structure-class))
650 (condition (find-class 'condition-class))
651 (built-in (find-class 'built-in-class)))
652 (flet ((specializer->metatype (x)
653 (let ((meta-specializer
654 (if (eq *boot-state* 'complete)
655 (class-of (specializer-class x))
656 (class-of x))))
657 (cond ((eq x *the-class-t*) t)
658 ((*subtypep meta-specializer standard) 'standard-instance)
659 ((*subtypep meta-specializer fsc) 'standard-instance)
660 ((*subtypep meta-specializer condition) 'condition-instance)
661 ((*subtypep meta-specializer structure) 'structure-instance)
662 ((*subtypep meta-specializer built-in) 'built-in-instance)
663 ((*subtypep meta-specializer slot) 'slot-instance)
664 (t (error _"~@<PCL cannot handle the specializer ~S ~
665 (meta-specializer ~S).~@:>"
666 new-specializer meta-specializer))))))
667 ;;
668 ;; We implement the following table. The notation is
669 ;; that X and Y are distinct meta specializer names.
670 ;;
671 ;; NIL <anything> ===> <anything>
672 ;; X X ===> X
673 ;; X Y ===> CLASS
674 ;;
675 (let ((new-metatype (specializer->metatype new-specializer)))
676 (cond ((eq new-metatype 'slot-instance) 'class)
677 ((null metatype) new-metatype)
678 ((eq metatype new-metatype) new-metatype)
679 (t 'class))))))
680
681 (defmacro with-dfun-wrappers ((args metatypes)
682 (dfun-wrappers invalid-wrapper-p
683 &optional wrappers classes types)
684 invalid-arguments-form
685 &body body)
686 `(let* ((args-tail ,args) (,invalid-wrapper-p nil) (invalid-arguments-p nil)
687 (,dfun-wrappers nil) (dfun-wrappers-tail nil)
688 ,@(when wrappers
689 `((wrappers-rev nil) (types-rev nil) (classes-rev nil))))
690 (dolist (mt ,metatypes)
691 (unless args-tail
692 (setq invalid-arguments-p t)
693 (return nil))
694 (let* ((arg (pop args-tail))
695 (wrapper nil)
696 ,@(when wrappers
697 `((class *the-class-t*)
698 (type t))))
699 (unless (eq mt t)
700 (setq wrapper (wrapper-of arg))
701 (when (invalid-wrapper-p wrapper)
702 (setq ,invalid-wrapper-p t)
703 (setq wrapper (check-wrapper-validity arg)))
704 (cond ((null ,dfun-wrappers)
705 (setq ,dfun-wrappers wrapper))
706 ((not (consp ,dfun-wrappers))
707 (setq dfun-wrappers-tail (list wrapper))
708 (setq ,dfun-wrappers (cons ,dfun-wrappers dfun-wrappers-tail)))
709 (t
710 (let ((new-dfun-wrappers-tail (list wrapper)))
711 (setf (cdr dfun-wrappers-tail) new-dfun-wrappers-tail)
712 (setf dfun-wrappers-tail new-dfun-wrappers-tail))))
713 ,@(when wrappers
714 `((setq class (wrapper-class* wrapper))
715 (setq type `(class-eq ,class)))))
716 ,@(when wrappers
717 `((push wrapper wrappers-rev)
718 (push class classes-rev)
719 (push type types-rev)))))
720 (if invalid-arguments-p
721 ,invalid-arguments-form
722 (let* (,@(when wrappers
723 `((,wrappers (nreverse wrappers-rev))
724 (,classes (nreverse classes-rev))
725 (,types (nreverse types-rev)))))
726 ,@body))))
727
728
729 ;;;
730 ;;; Some support stuff for getting a hold of symbols that we need when
731 ;;; building the discriminator codes. Its ok for these to be interned
732 ;;; symbols because we don't capture any user code in the scope in which
733 ;;; these symbols are bound.
734 ;;;
735
736 (defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.))
737
738 (defun dfun-arg-symbol (arg-number)
739 (or (nth arg-number (the list *dfun-arg-symbols*))
740 (make-.variable. 'arg arg-number)))
741
742 (defun dfun-arg-symbol-list (metatypes)
743 (loop for i from 0 and s in metatypes
744 collect (dfun-arg-symbol i)))
745
746 (defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.))
747
748 (defun slot-vector-symbol (arg-number)
749 (or (nth arg-number (the list *slot-vector-symbols*))
750 (make-.variable. 'slots arg-number)))
751
752 (defun make-dfun-lambda-list (metatypes applyp)
753 (if applyp
754 (nconc (dfun-arg-symbol-list metatypes) (list '&rest '.dfun-rest-arg.))
755 (dfun-arg-symbol-list metatypes)))
756
757 (defun make-dlap-lambda-list (metatypes applyp)
758 (if applyp
759 (nconc (dfun-arg-symbol-list metatypes) (list '&rest))
760 (dfun-arg-symbol-list metatypes)))
761
762 (defun make-emf-call (metatypes applyp fn-variable &optional emf-type)
763 (let ((required (dfun-arg-symbol-list metatypes)))
764 `(,(if (eq emf-type 'fast-method-call)
765 'invoke-effective-method-function-fast
766 'invoke-effective-method-function)
767 ,fn-variable ,applyp ,@required ,@(when applyp `(.dfun-rest-arg.)))))
768
769 (defun make-fast-method-call-lambda-list (metatypes applyp)
770 (let ((required (dfun-arg-symbol-list metatypes)))
771 (if applyp
772 `(.pv-cell. .next-method-call. ,@required .dfun-rest-arg.)
773 `(.pv-cell. .next-method-call. ,@required))))
774
775
776 (defmacro with-local-cache-functions ((cache) &body body)
777 `(let ((.cache. ,cache))
778 (declare (type cache .cache.))
779 (labels ((cache () .cache.)
780 (nkeys () (cache-nkeys .cache.))
781 (line-size () (cache-line-size .cache.))
782 (vector () (cache-vector .cache.))
783 (valuep () (cache-valuep .cache.))
784 (nlines () (cache-nlines .cache.))
785 (max-location () (cache-max-location .cache.))
786 (size () (cache-size .cache.))
787 (mask () (cache-mask .cache.))
788 (field () (cache-field .cache.))
789 (overflow () (cache-overflow .cache.))
790 ;;
791 ;; Return T IFF this cache location is reserved. The
792 ;; only time this is true is for line number 0 of an
793 ;; nkeys=1 cache.
794 ;;
795 (line-reserved-p (line)
796 (declare (fixnum line))
797 (and (= (nkeys) 1)
798 (= line 0)))
799 ;;
800 (location-reserved-p (location)
801 (declare (fixnum location))
802 (and (= (nkeys) 1)
803 (= location 0)))
804 ;;
805 ;; Given a line number, return the cache location.
806 ;; This is the value that is the second argument to
807 ;; cache-vector-ref. Basically, this deals with the
808 ;; offset of nkeys>1 caches and multiplies by line
809 ;; size.
810 ;;
811 (line-location (line)
812 (declare (fixnum line))
813 (when (line-reserved-p line)
814 (internal-error _"Line is reserved."))
815 (if (= (nkeys) 1)
816 (the fixnum (* line (line-size)))
817 (the fixnum (1+ (the fixnum (* line (line-size)))))))
818 ;;
819 ;; Given a cache location, return the line. This is
820 ;; the inverse of LINE-LOCATION.
821 ;;
822 (location-line (location)
823 (declare (fixnum location))
824 (if (= (nkeys) 1)
825 (floor location (line-size))
826 (floor (the fixnum (1- location)) (line-size))))
827 ;;
828 ;; Given a line number, return the wrappers stored at
829 ;; that line. As usual, if nkeys=1, this returns a
830 ;; single value. Only when nkeys>1 does it return a
831 ;; list. An error is signalled if the line is
832 ;; reserved.
833 ;;
834 (line-wrappers (line)
835 (declare (fixnum line))
836 (when (line-reserved-p line)
837 (internal-error _"Line is reserved."))
838 (location-wrappers (line-location line)))
839 ;;
840 (location-wrappers (location) ; avoid multiplies caused by line-location
841 (declare (fixnum location))
842 (if (= (nkeys) 1)
843 (cache-vector-ref (vector) location)
844 (let ((list (make-list (nkeys)))
845 (vector (vector)))
846 (declare (simple-vector vector))
847 (dotimes (i (nkeys) list)
848 (declare (fixnum i))
849 (setf (nth i list) (cache-vector-ref vector (+ location i)))))))
850 ;;
851 ;; Given a line number, return true IFF the line's
852 ;; wrappers are the same as wrappers.
853 ;;
854 (line-matches-wrappers-p (line wrappers)
855 (declare (fixnum line))
856 (and (not (line-reserved-p line))
857 (location-matches-wrappers-p (line-location line) wrappers)))
858 ;;
859 (location-matches-wrappers-p (loc wrappers) ; must not be reserved
860 (declare (fixnum loc))
861 (let ((cache-vector (vector)))
862 (declare (simple-vector cache-vector))
863 (if (= (nkeys) 1)
864 (eq wrappers (cache-vector-ref cache-vector loc))
865 (dotimes (i (nkeys) t)
866 (declare (fixnum i))
867 (unless (eq (pop wrappers)
868 (cache-vector-ref cache-vector (+ loc i)))
869 (return nil))))))
870 ;;
871 ;; Given a line number, return the value stored at that line.
872 ;; If valuep is NIL, this returns NIL. As with line-wrappers,
873 ;; an error is signalled if the line is reserved.
874 ;;
875 (line-value (line)
876 (declare (fixnum line))
877 (when (line-reserved-p line)
878 (internal-error _"Line is reserved."))
879 (location-value (line-location line)))
880 ;;
881 (location-value (loc)
882 (declare (fixnum loc))
883 (and (valuep)
884 (cache-vector-ref (vector) (+ loc (nkeys)))))
885 ;;
886 ;; Given a line number, return true IFF that line has data in
887 ;; it. The state of the wrappers stored in the line is not
888 ;; checked. An error is signalled if line is reserved.
889 (line-full-p (line)
890 (when (line-reserved-p line)
891 (internal-error _"Line is reserved."))
892 (not (null (cache-vector-ref (vector) (line-location line)))))
893 ;;
894 ;; Given a line number, return true IFF the line is full and
895 ;; there are no invalid wrappers in the line, and the line's
896 ;; wrappers are different from wrappers.
897 ;; An error is signalled if the line is reserved.
898 ;;
899 (line-valid-p (line wrappers)
900 (declare (fixnum line))
901 (when (line-reserved-p line)
902 (internal-error _"Line is reserved."))
903 (location-valid-p (line-location line) wrappers))
904 ;;
905 (location-valid-p (loc wrappers)
906 (declare (fixnum loc))
907 (let ((cache-vector (vector))
908 (wrappers-mismatch-p (null wrappers)))
909 (declare (simple-vector cache-vector))
910 (dotimes (i (nkeys) wrappers-mismatch-p)
911 (declare (fixnum i))
912 (let ((wrapper (cache-vector-ref cache-vector (+ loc i))))
913 (when (or (null wrapper)
914 (invalid-wrapper-p wrapper))
915 (return nil))
916 (unless (and wrappers
917 (eq wrapper
918 (if (consp wrappers) (pop wrappers) wrappers)))
919 (setq wrappers-mismatch-p t))))))
920 ;;
921 ;; How many unreserved lines separate line-1 and line-2.
922 ;;
923 (line-distance (line-1 line-2)
924 (declare (fixnum line-1 line-2))
925 (let ((diff (the fixnum (- line-2 line-1))))
926 (declare (fixnum diff))
927 (when (minusp diff)
928 (setq diff (+ diff (nlines)))
929 (when (line-reserved-p 0)
930 (setq diff (1- diff))))
931 diff))
932 ;;
933 ;; Given a cache line, get the next cache line. This will not
934 ;; return a reserved line.
935 ;;
936 (next-line (line)
937 (declare (fixnum line))
938 (if (= line (the fixnum (1- (nlines))))
939 (if (line-reserved-p 0) 1 0)
940 (the fixnum (1+ line))))
941 ;;
942 (next-location (loc)
943 (declare (fixnum loc))
944 (if (= loc (max-location))
945 (if (= (nkeys) 1)
946 (line-size)
947 1)
948 (the fixnum (+ loc (line-size)))))
949 ;;
950 ;; Given a line which has a valid entry in it, this
951 ;; will return the primary cache line of the wrappers
952 ;; in that line. We just call
953 ;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this
954 ;; is an easier packaging up of the call to it.
955 ;;
956 (line-primary (line)
957 (declare (fixnum line))
958 (location-line (line-primary-location line)))
959 ;;
960 (line-primary-location (line)
961 (declare (fixnum line))
962 (compute-primary-cache-location-from-location
963 (cache) (line-location line))))
964 (declare (ignorable #'cache #'nkeys #'line-size #'vector #'valuep
965 #'nlines #'max-location #'size
966 #'mask #'field #'overflow #'line-reserved-p
967 #'location-reserved-p #'line-location
968 #'location-line #'line-wrappers #'location-wrappers
969 #'line-matches-wrappers-p
970 #'location-matches-wrappers-p
971 #'line-value #'location-value #'line-full-p
972 #'line-valid-p #'location-valid-p
973 #'line-distance #'next-line #'next-location
974 #'line-primary #'line-primary-location))
975 ;;
976 ;; This does nothing but ensure that LEAF-EVER-USED for the
977 ;; inline function INVALID-WRAPPER-P is true, even if the local
978 ;; function above using it is deleted. In other words it's
979 ;; only for getting rid of some disturbing compiler notes, and
980 ;; it should really be fixed in the compiler, if anywhere. I'm
981 ;; not in the mood, at present.
982 #'invalid-wrapper-p
983 ,@body)))
984
985
986 ;;;
987 ;;; Here is where we actually fill, recache and expand caches.
988 ;;;
989 ;;; The functions FILL-CACHE and PROBE-CACHE are the ONLY external
990 ;;; entrypoints into this code.
991 ;;;
992 ;;; FILL-CACHE returns 1 value: a new cache
993 ;;;
994 ;;; a wrapper field number
995 ;;; a cache
996 ;;; a mask
997 ;;; an absolute cache size (the size of the actual vector)
998 ;;; It tries to re-adjust the cache every time it makes a new fill. The
999 ;;; intuition here is that we want uniformity in the number of probes needed to
1000 ;;; find an entry. Furthermore, adjusting has the nice property of throwing out
1001 ;;; any entries that are invalid.
1002 ;;;
1003 (defun fill-cache (cache wrappers value)
1004 ;; fill-cache won't return if wrappers is nil, might as well check.
1005 (assert wrappers)
1006 (or (fill-cache-p nil cache wrappers value)
1007 (and (< (ceiling (* (cache-count cache) 1.25))
1008 (if (= (cache-nkeys cache) 1)
1009 (1- (cache-nlines cache))
1010 (cache-nlines cache)))
1011 (adjust-cache cache wrappers value))
1012 (expand-cache cache wrappers value)))
1013
1014 (defvar *check-cache-p* nil)
1015
1016 (defmacro maybe-check-cache (cache)
1017 `(progn
1018 (when *check-cache-p*
1019 (check-cache ,cache))
1020 ,cache))
1021
1022 (defun check-cache (cache)
1023 (with-local-cache-functions (cache)
1024 (let ((location (if (= (nkeys) 1) 0 1))
1025 (limit (default-limit-fn (nlines))))
1026 (dotimes (i (nlines) cache)
1027 (declare (fixnum i))
1028 (when (and (not (location-reserved-p location))
1029 (line-full-p i))
1030 (let* ((home-loc (compute-primary-cache-location-from-location
1031 cache location))
1032 (home (location-line (if (location-reserved-p home-loc)
1033 (next-location home-loc)
1034 home-loc)))
1035 (sep (when home (line-distance home i))))
1036 (when (and sep (> sep limit))
1037 (internal-error _"~@<Bad cache ~S: Value at location ~D is ~D ~
1038 lines from its home, limit is ~D.~@:>"
1039 cache location sep limit))))
1040 (setq location (next-location location))))))
1041
1042 (defun probe-cache (cache wrappers &optional default)
1043 (declare #.*optimize-speed*)
1044 (assert wrappers)
1045 (let ((limit (default-limit-fn (cache-nlines cache))))
1046 (declare (fixnum limit))
1047 (if (= (cache-nkeys cache) 1)
1048 (loop with primary of-type fixnum
1049 = (logand (cache-mask cache)
1050 (the fixnum (kernel:layout-hash
1051 (if (listp wrappers)
1052 (car wrappers)
1053 wrappers)
1054 (cache-field cache))))
1055 with line-size of-type fixnum = (cache-line-size cache)
1056 with max-location of-type fixnum = (cache-max-location cache)
1057 with cache-vector of-type simple-vector = (cache-vector cache)
1058 for location of-type fixnum
1059 = (if (zerop primary)
1060 (if (= primary max-location)
1061 line-size
1062 (the fixnum (+ primary line-size)))
1063 primary)
1064 then (if (= location max-location)
1065 line-size
1066 (the fixnum (+ location line-size)))
1067 for i of-type fixnum upto limit
1068 when (eq wrappers (%svref cache-vector location)) do
1069 (return-from probe-cache
1070 (or (not (cache-valuep cache))
1071 (%svref cache-vector (1+ location)))))
1072 (loop with primary of-type fixnum
1073 = (compute-primary-cache-location (cache-field cache)
1074 (cache-mask cache)
1075 wrappers)
1076 with line-size of-type fixnum = (cache-line-size cache)
1077 with max-location of-type fixnum = (cache-max-location cache)
1078 with nkeys of-type fixnum = (cache-nkeys cache)
1079 with cache-vector of-type simple-vector = (cache-vector cache)
1080 for location of-type fixnum = primary
1081 then (if (= location max-location)
1082 1
1083 (the fixnum (+ location line-size)))
1084 for i of-type fixnum upto limit do
1085 (loop with found? = t
1086 repeat nkeys
1087 for i of-type fixnum from location
1088 for wrapper in wrappers
1089 unless (eq (%svref cache-vector i) wrapper) do
1090 (setq found? nil)
1091 (loop-finish)
1092 finally
1093 (when found?
1094 (return-from probe-cache
1095 (or (not (cache-valuep cache))
1096 (%svref cache-vector (+ location nkeys)))))))))
1097 (loop for entry in (cache-overflow cache)
1098 when (equal (car entry) wrappers) do
1099 (return-from probe-cache (or (not (cache-valuep cache))
1100 (cdr entry))))
1101 default)
1102
1103 (defun map-cache (function cache &optional set-p)
1104 (with-local-cache-functions (cache)
1105 (let ((set-p (and set-p (valuep))))
1106 (dotimes (i (nlines) cache)
1107 (declare (fixnum i))
1108 (unless (or (line-reserved-p i) (not (line-valid-p i nil)))
1109 (let ((value (funcall function (line-wrappers i) (line-value i))))
1110 (when set-p
1111 (setf (cache-vector-ref (vector) (+ (line-location i) (nkeys)))
1112 value)))))
1113 (dolist (entry (overflow))
1114 (let ((value (funcall function (car entry) (cdr entry))))
1115 (when set-p
1116 (setf (cdr entry) value))))))
1117 cache)
1118
1119 (defun cache-count (cache)
1120 (with-local-cache-functions (cache)
1121 (loop for i of-type fixnum below (nlines)
1122 count (and (not (line-reserved-p i))
1123 (line-full-p i)))))
1124
1125 ;;;
1126 ;;; returns T or NIL
1127 ;;;
1128 (defun fill-cache-p (forcep cache wrappers value)
1129 (with-local-cache-functions (cache)
1130 (let* ((location (compute-primary-cache-location (field) (mask) wrappers))
1131 (primary (location-line location)))
1132 (declare (fixnum location primary))
1133 (multiple-value-bind (free emptyp)
1134 (find-free-cache-line primary cache wrappers)
1135 (when (or forcep emptyp)
1136 (when (not emptyp)
1137 (push (cons (line-wrappers free) (line-value free))
1138 (cache-overflow cache)))
1139 ;;(fill-line free wrappers value)
1140 (let ((line free))
1141 (declare (fixnum line))
1142 (when (line-reserved-p line)
1143 (internal-error _"Attempt to fill a reserved cache line."))
1144 (let ((loc (line-location line))
1145 (cache-vector (vector)))
1146 (declare (fixnum loc) (simple-vector cache-vector))
1147 (cond ((= (nkeys) 1)
1148 (setf (cache-vector-ref cache-vector loc) wrappers)
1149 (when (valuep)
1150 (setf (cache-vector-ref cache-vector (1+ loc)) value)))
1151 (t
1152 (let ((i 0))
1153 (declare (fixnum i))
1154 (dolist (w wrappers)
1155 (setf (cache-vector-ref cache-vector (+ loc i)) w)
1156 (setq i (the fixnum (1+ i)))))
1157 (when (valuep)
1158 (setf (cache-vector-ref cache-vector (+ loc (nkeys)))
1159 value))))
1160 (maybe-check-cache cache))))))))
1161
1162 (defun fill-cache-from-cache-p (forcep cache from-cache from-line)
1163 (declare (fixnum from-line))
1164 (with-local-cache-functions (cache)
1165 (let ((primary (location-line (compute-primary-cache-location-from-location
1166 cache (line-location from-line) from-cache))))
1167 (declare (fixnum primary))
1168 (multiple-value-bind (free emptyp)
1169 (find-free-cache-line primary cache)
1170 (when (or forcep emptyp)
1171 (when (not emptyp)
1172 (push (cons (line-wrappers free) (line-value free))
1173 (cache-overflow cache)))
1174 ;;(transfer-line from-cache-vector from-line cache-vector free)
1175 (let ((from-cache-vector (cache-vector from-cache))
1176 (to-cache-vector (vector))
1177 (to-line free))
1178 (declare (fixnum to-line))
1179 (if (line-reserved-p to-line)
1180 (internal-error
1181 _"Transfering something into a reserved cache line.")
1182 (let ((from-loc (line-location from-line))
1183 (to-loc (line-location to-line)))
1184 (declare (fixnum from-loc to-loc))
1185 (modify-cache to-cache-vector
1186 (dotimes (i (line-size))
1187 (declare (fixnum i))
1188 (setf (cache-vector-ref to-cache-vector
1189 (+ to-loc i))
1190 (cache-vector-ref from-cache-vector
1191 (+ from-loc i)))))))
1192 (maybe-check-cache cache)))))))
1193
1194 ;;;
1195 ;;; Returns NIL or (values <field> <cache-vector>)
1196 ;;;
1197 ;;; This is only called when it isn't possible to put the entry in the cache
1198 ;;; the easy way. That is, this function assumes that FILL-CACHE-P has been
1199 ;;; called as returned NIL.
1200 ;;;
1201 ;;; If this returns NIL, it means that it wasn't possible to find a wrapper
1202 ;;; field for which all of the entries could be put in the cache (within the
1203 ;;; limit).
1204 ;;;
1205 (defun adjust-cache (cache wrappers value)
1206 (with-local-cache-functions (cache)
1207 (let ((ncache (get-cache-from-cache cache (nlines) (field))))
1208 (do ((nfield (cache-field ncache)
1209 (when (< nfield (1- kernel:layout-hash-length))
1210 (1+ nfield))))
1211 ((null nfield) nil)
1212 (setf (cache-field ncache) nfield)
1213 (labels ((try-one-fill-from-line (line)
1214 (fill-cache-from-cache-p nil ncache cache line))
1215 (try-one-fill (wrappers value)
1216 (fill-cache-p nil ncache wrappers value)))
1217 (if (and (dotimes (i (nlines) t)
1218 (declare (fixnum i))
1219 (when (and (null (line-reserved-p i))
1220 (line-valid-p i wrappers))
1221 (unless (try-one-fill-from-line i) (return nil))))
1222 (dolist (wrappers+value (cache-overflow cache) t)
1223 (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
1224 (return nil)))
1225 (try-one-fill wrappers value))
1226 (progn
1227 (return (maybe-check-cache ncache)))
1228 (flush-cache-vector-internal (cache-vector ncache))))))))
1229
1230
1231 ;;;
1232 ;;; returns: (values <cache>)
1233 ;;;
1234 (defun expand-cache (cache wrappers value)
1235 (with-local-cache-functions (cache)
1236 (let ((ncache (get-cache-from-cache cache (* (nlines) 2))))
1237 (labels ((do-one-fill-from-line (line)
1238 (unless (fill-cache-from-cache-p nil ncache cache line)
1239 (do-one-fill (line-wrappers line) (line-value line))))
1240 (do-one-fill (wrappers value)
1241 (setq ncache (or (adjust-cache ncache wrappers value)
1242 (fill-cache-p t ncache wrappers value))))
1243 (try-one-fill (wrappers value)
1244 (fill-cache-p nil ncache wrappers value)))
1245 (dotimes (i (nlines))
1246 (declare (fixnum i))
1247 (when (and (null (line-reserved-p i))
1248 (line-valid-p i wrappers))
1249 (do-one-fill-from-line i)))
1250 (dolist (wrappers+value (cache-overflow cache))
1251 (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
1252 (do-one-fill (car wrappers+value) (cdr wrappers+value))))
1253 (unless (try-one-fill wrappers value)
1254 (do-one-fill wrappers value))
1255 (maybe-check-cache ncache)))))
1256
1257
1258 ;;;
1259 ;;; This is the heart of the cache filling mechanism. It implements
1260 ;;; the decisions about where entries are placed.
1261 ;;;
1262 ;;; Find a line in the cache at which a new entry can be inserted.
1263 ;;;
1264 ;;; <line>
1265 ;;; <empty?> is <line> in fact empty?
1266 ;;;
1267 (defun find-free-cache-line (primary cache &optional wrappers)
1268 (declare (fixnum primary))
1269 (with-local-cache-functions (cache)
1270 (when (line-reserved-p primary)
1271 (setq primary (next-line primary)))
1272 (let ((limit (default-limit-fn (nlines)))
1273 (wrappedp nil)
1274 (lines nil)
1275 (p primary) (s primary))
1276 (declare (fixnum p s limit))
1277 (block find-free
1278 (loop
1279 ;; Try to find a free line starting at <s>. <p> is the
1280 ;; primary line of the entry we are finding a free
1281 ;; line for, it is used to compute the seperations.
1282 (do* ((line s (next-line line))
1283 (nsep (line-distance p s) (1+ nsep)))
1284 (())
1285 (declare (fixnum line nsep))
1286 ;;If this line is empty or invalid, just use it.
1287 (when (null (line-valid-p line wrappers))
1288 (push line lines)
1289 (return-from find-free))
1290 (when (and wrappedp (>= line primary))
1291 ;; have gone all the way around the cache, time to quit
1292 (return-from find-free-cache-line (values primary nil)))
1293 (let ((osep (line-distance (line-primary line) line)))
1294 (when (>= osep limit)
1295 (return-from find-free-cache-line (values primary nil)))
1296 (when (cond ((= nsep limit) t)
1297 ((= nsep osep) (zerop (random 2)))
1298 ((> nsep osep) t)
1299 (t nil))
1300 ;; See if we can displace what is in this line so that we
1301 ;; can use the line.
1302 (when (= line (the fixnum (1- (nlines))))
1303 (setq wrappedp t))
1304 (setq p (line-primary line))
1305 (setq s (next-line line))
1306 (push line lines)
1307 (return nil)))
1308 (when (= line (the fixnum (1- (nlines))))
1309 (setq wrappedp t)))))
1310 ;; Do all the displacing.
1311 (loop
1312 (when (null (cdr lines))
1313 (return nil))
1314 (let ((dline (pop lines))
1315 (line (car lines)))
1316 (declare (fixnum dline line))
1317 ;;Copy from line to dline (dline is known to be free).
1318 (let ((from-loc (line-location line))
1319 (to-loc (line-location dline))
1320 (cache-vector (vector)))
1321 (declare (fixnum from-loc to-loc) (simple-vector cache-vector))
1322 (modify-cache cache-vector
1323 (dotimes (i (line-size))
1324 (declare (fixnum i))
1325 (setf (cache-vector-ref cache-vector (+ to-loc i))
1326 (cache-vector-ref cache-vector (+ from-loc i)))
1327 (setf (cache-vector-ref cache-vector (+ from-loc i))
1328 nil))))))
1329 (values (car lines) t))))
1330

  ViewVC Help
Powered by ViewVC 1.1.5