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 |
|
;;; The basics of the PCL wrapper cache mechanism. |
28 |
|
;;; |
29 |
|
|
30 |
|
(in-package :pcl) |
31 |
|
;;; |
32 |
|
;;; The caching algorithm implemented: |
33 |
|
;;; |
34 |
|
;;; << put a paper here >> |
35 |
|
;;; |
36 |
|
;;; For now, understand that as far as most of this code goes, a cache has |
37 |
|
;;; two important properties. The first is the number of wrappers used as |
38 |
|
;;; keys in each cache line. Throughout this code, this value is always |
39 |
|
;;; called NKEYS. The second is whether or not the cache lines of a cache |
40 |
|
;;; store a value. Throughout this code, this always called VALUEP. |
41 |
|
;;; |
42 |
|
;;; Depending on these values, there are three kinds of caches. |
43 |
|
;;; |
44 |
|
;;; NKEYS = 1, VALUEP = NIL |
45 |
|
;;; |
46 |
|
;;; In this kind of cache, each line is 1 word long. No cache locking is |
47 |
|
;;; needed since all read's in the cache are a single value. Nevertheless |
48 |
|
;;; line 0 (location 0) is reserved, to ensure that invalid wrappers will |
49 |
|
;;; not get a first probe hit. |
50 |
|
;;; |
51 |
|
;;; To keep the code simpler, a cache lock count does appear in location 0 |
52 |
|
;;; of these caches, that count is incremented whenever data is written to |
53 |
|
;;; the cache. But, the actual lookup code (see make-dlap) doesn't need to |
54 |
|
;;; do locking when reading the cache. |
55 |
|
;;; |
56 |
|
;;; |
57 |
|
;;; NKEYS = 1, VALUEP = T |
58 |
|
;;; |
59 |
|
;;; In this kind of cache, each line is 2 words long. Cache locking must |
60 |
|
;;; be done to ensure the synchronization of cache reads. Line 0 of the |
61 |
|
;;; cache (location 0) is reserved for the cache lock count. Location 1 |
62 |
|
;;; of the cache is unused (in effect wasted). |
63 |
|
;;; |
64 |
|
;;; NKEYS > 1 |
65 |
|
;;; |
66 |
|
;;; In this kind of cache, the 0 word of the cache holds the lock count. |
67 |
|
;;; The 1 word of the cache is line 0. Line 0 of these caches is not |
68 |
|
;;; reserved. |
69 |
|
;;; |
70 |
|
;;; This is done because in this sort of cache, the overhead of doing the |
71 |
|
;;; cache probe is high enough that the 1+ required to offset the location |
72 |
|
;;; is not a significant cost. In addition, because of the larger line |
73 |
|
;;; sizes, the space that would be wasted by reserving line 0 to hold the |
74 |
|
;;; lock count is more significant. |
75 |
|
;;; |
76 |
|
|
77 |
|
;;; |
78 |
|
;;; Caches |
79 |
|
;;; |
80 |
|
;;; A cache is essentially just a vector. The use of the individual `words' |
81 |
|
;;; in the vector depends on particular properties of the cache as described |
82 |
|
;;; above. |
83 |
|
;;; |
84 |
|
;;; This defines an abstraction for caches in terms of their most obvious |
85 |
|
;;; implementation as simple vectors. But, please notice that part of the |
86 |
|
;;; implementation of this abstraction, is the function lap-out-cache-ref. |
87 |
|
;;; This means that most port-specific modifications to the implementation |
88 |
|
;;; of caches will require corresponding port-specific modifications to the |
89 |
|
;;; lap code assembler. |
90 |
|
;;; |
91 |
|
(defmacro cache-vector-ref (cache-vector location) |
92 |
|
`(svref (the simple-vector ,cache-vector) |
93 |
|
(#-cmu the #+cmu ext:truly-the non-negative-fixnum ,location))) |
94 |
|
|
95 |
|
(defmacro cache-vector-size (cache-vector) |
96 |
|
`(array-dimension (the simple-vector ,cache-vector) 0)) |
97 |
|
|
98 |
|
(defun allocate-cache-vector (size) |
99 |
|
(make-array size :adjustable nil)) |
100 |
|
|
101 |
|
(defmacro cache-vector-lock-count (cache-vector) |
102 |
|
`(cache-vector-ref ,cache-vector 0)) |
103 |
|
|
104 |
|
(defun flush-cache-vector-internal (cache-vector) |
105 |
|
(without-interrupts |
106 |
|
(fill (the simple-vector cache-vector) nil) |
107 |
|
(setf (cache-vector-lock-count cache-vector) 0)) |
108 |
|
cache-vector) |
109 |
|
|
110 |
|
;; FIXME 64 |
111 |
|
(defconstant rand-base (- (ash 1 31) 1)) |
112 |
|
|
113 |
|
(defmacro modify-cache (cache-vector &body body) |
114 |
|
`(without-interrupts |
115 |
|
(multiple-value-prog1 |
116 |
|
(progn ,@body) |
117 |
|
(let ((old-count (cache-vector-lock-count ,cache-vector))) |
118 |
|
(declare (type non-negative-fixnum old-count)) |
119 |
|
(setf (cache-vector-lock-count ,cache-vector) |
120 |
|
(if (= old-count rand-base) |
121 |
|
1 (the non-negative-fixnum (1+ old-count)))))))) |
122 |
|
|
123 |
|
(deftype field-type () |
124 |
|
'(integer 0 ;#.(position 'number wrapper-layout) |
125 |
|
7)) ;#.(position 'number wrapper-layout :from-end t) |
126 |
|
|
127 |
|
(eval-when (compile load eval) |
128 |
|
(defun power-of-two-ceiling (x) |
129 |
|
(declare (type (and fixnum (integer 1 *)) x)) |
130 |
|
;;(expt 2 (ceiling (log x 2))) |
131 |
|
(the non-negative-fixnum (ash 1 (integer-length (1- x))))) |
132 |
|
|
133 |
|
(defconstant *nkeys-limit* 256) |
134 |
|
) |
135 |
|
|
136 |
|
(defstruct (cache |
137 |
|
(:print-function print-cache) |
138 |
|
(:constructor make-cache ()) |
139 |
|
(:copier copy-cache-internal)) |
140 |
|
(owner nil) |
141 |
|
(nkeys 1 :type (integer 1 #.*nkeys-limit*)) |
142 |
|
(valuep nil :type (member nil t)) |
143 |
|
(nlines 0 :type non-negative-fixnum) |
144 |
|
(field 0 :type field-type) |
145 |
|
(limit-fn #'default-limit-fn :type function) |
146 |
|
(mask 0 :type non-negative-fixnum) |
147 |
|
(size 0 :type non-negative-fixnum) |
148 |
|
(line-size 1 :type (integer 1 #.(power-of-two-ceiling (1+ *nkeys-limit*)))) |
149 |
|
(max-location 0 :type non-negative-fixnum) |
150 |
|
(vector #() :type simple-vector) |
151 |
|
(overflow nil :type list)) |
152 |
|
|
153 |
|
#+cmu |
154 |
|
(declaim (ext:freeze-type cache)) |
155 |
|
|
156 |
|
(defun print-cache (cache stream depth) |
157 |
|
(declare (ignore depth)) |
158 |
|
(printing-random-thing (cache stream) |
159 |
|
(format stream "cache ~D ~S ~D" |
160 |
|
(cache-nkeys cache) (cache-valuep cache) (cache-nlines cache)))) |
161 |
|
|
162 |
|
#+akcl |
163 |
|
(si::freeze-defstruct 'cache) |
164 |
|
|
165 |
|
(defmacro cache-lock-count (cache) |
166 |
|
`(cache-vector-lock-count (cache-vector ,cache))) |
167 |
|
|
168 |
|
|
169 |
|
;;; |
170 |
|
;;; Some facilities for allocation and freeing caches as they are needed. |
171 |
|
;;; This is done on the assumption that a better port of PCL will arrange |
172 |
|
;;; to cons these all the same static area. Given that, the fact that |
173 |
|
;;; PCL tries to reuse them should be a win. |
174 |
|
;;; |
175 |
|
(defvar *free-cache-vectors* (make-hash-table :size 16 :test 'eql)) |
176 |
|
|
177 |
|
;;; |
178 |
|
;;; Return a cache that has had flush-cache-vector-internal called on it. This |
179 |
|
;;; returns a cache of exactly the size requested, it won't ever return a |
180 |
|
;;; larger cache. |
181 |
|
;;; |
182 |
|
(defun get-cache-vector (size) |
183 |
|
(let ((entry (gethash size *free-cache-vectors*))) |
184 |
|
(without-interrupts |
185 |
|
(cond ((null entry) |
186 |
|
(setf (gethash size *free-cache-vectors*) (cons 0 nil)) |
187 |
|
(get-cache-vector size)) |
188 |
|
((null (cdr entry)) |
189 |
|
(incf (car entry)) |
190 |
|
(flush-cache-vector-internal (allocate-cache-vector size))) |
191 |
|
(t |
192 |
|
(let ((cache (cdr entry))) |
193 |
|
(setf (cdr entry) (cache-vector-ref cache 0)) |
194 |
|
(flush-cache-vector-internal cache))))))) |
195 |
|
|
196 |
|
(defun free-cache-vector (cache-vector) |
197 |
|
(let ((entry (gethash (cache-vector-size cache-vector) *free-cache-vectors*))) |
198 |
|
(without-interrupts |
199 |
|
(if (null entry) |
200 |
|
(error "Attempt to free a cache-vector not allocated by GET-CACHE-VECTOR.") |
201 |
|
(let ((thread (cdr entry))) |
202 |
|
(loop (unless thread (return)) |
203 |
|
(when (eq thread cache-vector) (error "Freeing a cache twice.")) |
204 |
|
(setq thread (cache-vector-ref thread 0))) |
205 |
|
(flush-cache-vector-internal cache-vector) ;Help the GC |
206 |
|
(setf (cache-vector-ref cache-vector 0) (cdr entry)) |
207 |
|
(setf (cdr entry) cache-vector) |
208 |
|
nil))))) |
209 |
|
|
210 |
|
;;; |
211 |
|
;;; This is just for debugging and analysis. It shows the state of the free |
212 |
|
;;; cache resource. |
213 |
|
;;; |
214 |
|
(defun show-free-cache-vectors () |
215 |
|
(let ((elements ())) |
216 |
|
(maphash #'(lambda (s e) (push (list s e) elements)) *free-cache-vectors*) |
217 |
|
(setq elements (sort elements #'< :key #'car)) |
218 |
|
(dolist (e elements) |
219 |
|
(let* ((size (car e)) |
220 |
|
(entry (cadr e)) |
221 |
|
(allocated (car entry)) |
222 |
|
(head (cdr entry)) |
223 |
|
(free 0)) |
224 |
|
(loop (when (null head) (return t)) |
225 |
|
(setq head (cache-vector-ref head 0)) |
226 |
|
(incf free)) |
227 |
|
(format t |
228 |
|
"~&There ~4D are caches of size ~4D. (~D free ~3D%)" |
229 |
|
allocated |
230 |
|
size |
231 |
|
free |
232 |
|
(floor (* 100 (/ free (float allocated))))))))) |
233 |
|
|
234 |
|
|
235 |
|
;;; |
236 |
|
;;; Wrapper cache numbers |
237 |
|
;;; |
238 |
|
|
239 |
|
;;; |
240 |
|
;;; The constant WRAPPER-CACHE-NUMBER-ADDS-OK controls the number of non-zero |
241 |
|
;;; bits wrapper cache numbers will have. |
242 |
|
;;; |
243 |
|
;;; The value of this constant is the number of wrapper cache numbers which |
244 |
|
;;; can be added and still be certain the result will be a fixnum. This is |
245 |
|
;;; used by all the code that computes primary cache locations from multiple |
246 |
|
;;; wrappers. |
247 |
|
;;; |
248 |
|
;;; The value of this constant is used to derive the next two which are the |
249 |
|
;;; forms of this constant which it is more convenient for the runtime code |
250 |
|
;;; to use. |
251 |
|
;;; |
252 |
|
#-cmu17 |
253 |
|
(eval-when (compile load eval) |
254 |
|
|
255 |
|
(defconstant wrapper-cache-number-adds-ok 4) |
256 |
|
|
257 |
|
;;; Incorrect. This actually allows 15 or 16 adds, depending on whether |
258 |
|
;;; most-positive-fixnum is all-ones. -- Ram |
259 |
|
;;; |
260 |
|
(defconstant wrapper-cache-number-length |
261 |
|
(- (integer-length rand-base) |
262 |
|
wrapper-cache-number-adds-ok)) |
263 |
|
|
264 |
|
(defconstant wrapper-cache-number-mask |
265 |
|
(1- (expt 2 wrapper-cache-number-length))) |
266 |
|
|
267 |
|
|
268 |
|
(defvar *get-wrapper-cache-number* (make-random-state)) |
269 |
|
|
270 |
|
(defun get-wrapper-cache-number () |
271 |
|
(let ((n 0)) |
272 |
|
(declare (type non-negative-fixnum n)) |
273 |
|
(loop |
274 |
|
(setq n |
275 |
|
(logand wrapper-cache-number-mask |
276 |
|
(random rand-base *get-wrapper-cache-number*))) |
277 |
|
(unless (zerop n) (return n))))) |
278 |
|
|
279 |
|
|
280 |
|
(unless (> wrapper-cache-number-length 8) |
281 |
|
(error "In this implementation of Common Lisp, fixnums are so small that~@ |
282 |
|
wrapper cache numbers end up being only ~D bits long. This does~@ |
283 |
|
not actually keep PCL from running, but it may degrade cache~@ |
284 |
|
performance.~@ |
285 |
|
You may want to consider changing the value of the constant~@ |
286 |
|
WRAPPER-CACHE-NUMBER-ADDS-OK."))) |
287 |
|
|
288 |
|
#+cmu17 |
289 |
|
(progn |
290 |
|
(defconstant wrapper-cache-number-length |
291 |
|
(integer-length kernel:layout-hash-max)) |
292 |
|
|
293 |
|
(defconstant wrapper-cache-number-mask kernel:layout-hash-max) |
294 |
|
|
295 |
|
(defconstant wrapper-cache-number-adds-ok |
296 |
|
(truncate most-positive-fixnum kernel:layout-hash-max))) |
297 |
|
|
298 |
|
|
299 |
|
;;; |
300 |
|
;;; wrappers themselves |
301 |
|
;;; |
302 |
|
;;; This caching algorithm requires that wrappers have more than one wrapper |
303 |
|
;;; cache number. You should think of these multiple numbers as being in |
304 |
|
;;; columns. That is, for a given cache, the same column of wrapper cache |
305 |
|
;;; numbers will be used. |
306 |
|
;;; |
307 |
|
;;; If at some point the cache distribution of a cache gets bad, the cache |
308 |
|
;;; can be rehashed by switching to a different column. |
309 |
|
;;; |
310 |
|
;;; The columns are referred to by field number which is that number which, |
311 |
|
;;; when used as a second argument to wrapper-ref, will return that column |
312 |
|
;;; of wrapper cache number. |
313 |
|
;;; |
314 |
|
;;; This code is written to allow flexibility as to how many wrapper cache |
315 |
|
;;; numbers will be in each wrapper, and where they will be located. It is |
316 |
|
;;; also set up to allow port specific modifications to `pack' the wrapper |
317 |
|
;;; cache numbers on machines where the addressing modes make that a good |
318 |
|
;;; idea. |
319 |
|
;;; |
320 |
|
#-structure-wrapper |
321 |
|
(progn |
322 |
|
(eval-when (compile load eval) |
323 |
|
(defconstant wrapper-layout |
324 |
|
'(number |
325 |
|
number |
326 |
|
number |
327 |
|
number |
328 |
|
number |
329 |
|
number |
330 |
|
number |
331 |
|
number |
332 |
|
state |
333 |
|
instance-slots-layout |
334 |
|
class-slots |
335 |
|
class |
336 |
|
no-of-instance-slots)) |
337 |
|
) |
338 |
|
|
339 |
|
(eval-when (compile load eval) |
340 |
|
|
341 |
|
(defun wrapper-field (type) |
342 |
|
(posq type wrapper-layout)) |
343 |
|
|
344 |
|
(defun next-wrapper-field (field-number) |
345 |
|
(position (nth field-number wrapper-layout) |
346 |
|
wrapper-layout |
347 |
|
:start (1+ field-number))) |
348 |
|
|
349 |
|
(defmacro first-wrapper-cache-number-index () |
350 |
|
`(wrapper-field 'number)) |
351 |
|
|
352 |
|
(defmacro next-wrapper-cache-number-index (field-number) |
353 |
|
`(next-wrapper-field ,field-number)) |
354 |
|
|
355 |
|
);eval-when |
356 |
|
|
357 |
|
(defmacro wrapper-cache-number-vector (wrapper) |
358 |
|
wrapper) |
359 |
|
|
360 |
|
(defmacro cache-number-vector-ref (cnv n) |
361 |
|
`(svref ,cnv ,n)) |
362 |
|
|
363 |
|
|
364 |
|
(defmacro wrapper-ref (wrapper n) |
365 |
|
`(svref ,wrapper ,n)) |
366 |
|
|
367 |
|
(defmacro wrapper-state (wrapper) |
368 |
|
`(wrapper-ref ,wrapper ,(wrapper-field 'state))) |
369 |
|
|
370 |
|
(defmacro wrapper-instance-slots-layout (wrapper) |
371 |
|
`(wrapper-ref ,wrapper ,(wrapper-field 'instance-slots-layout))) |
372 |
|
|
373 |
|
(defmacro wrapper-class-slots (wrapper) |
374 |
|
`(wrapper-ref ,wrapper ,(wrapper-field 'class-slots))) |
375 |
|
|
376 |
|
(defmacro wrapper-class (wrapper) |
377 |
|
`(wrapper-ref ,wrapper ,(wrapper-field 'class))) |
378 |
|
|
379 |
|
(defmacro wrapper-no-of-instance-slots (wrapper) |
380 |
|
`(wrapper-ref ,wrapper ,(wrapper-field 'no-of-instance-slots))) |
381 |
|
|
382 |
|
(defmacro make-wrapper-internal () |
383 |
|
`(let ((wrapper (make-array ,(length wrapper-layout) :adjustable nil))) |
384 |
|
,@(gathering1 (collecting) |
385 |
|
(iterate ((i (interval :from 0)) |
386 |
|
(desc (list-elements wrapper-layout))) |
387 |
|
(ecase desc |
388 |
|
(number |
389 |
|
(gather1 `(setf (wrapper-ref wrapper ,i) |
390 |
|
(get-wrapper-cache-number)))) |
391 |
|
((state instance-slots-layout class-slots class no-of-instance-slots))))) |
392 |
|
(setf (wrapper-state wrapper) 't) |
393 |
|
wrapper)) |
394 |
|
|
395 |
|
(defun make-wrapper (no-of-instance-slots &optional class) |
396 |
|
(let ((wrapper (make-wrapper-internal))) |
397 |
|
(setf (wrapper-no-of-instance-slots wrapper) no-of-instance-slots) |
398 |
|
(setf (wrapper-class wrapper) class) |
399 |
|
wrapper)) |
400 |
|
|
401 |
|
) |
402 |
|
|
403 |
|
; In CMUCL we want to do type checking as early as possible; structures help this. |
404 |
|
#+structure-wrapper |
405 |
|
(eval-when (compile load eval) |
406 |
|
|
407 |
|
(defconstant wrapper-cache-number-vector-length |
408 |
|
#+cmu17 kernel:layout-hash-length #-cmu17 8) |
409 |
|
|
410 |
|
#-cmu17 |
411 |
|
(deftype cache-number-vector () |
412 |
|
`(simple-array fixnum (,wrapper-cache-number-vector-length))) |
413 |
|
|
414 |
|
(defconstant wrapper-layout (make-list wrapper-cache-number-vector-length |
415 |
|
:initial-element 'number)) |
416 |
|
|
417 |
|
) |
418 |
|
|
419 |
|
#+structure-wrapper |
420 |
|
(progn |
421 |
|
|
422 |
|
#-(or new-kcl-wrapper cmu17) |
423 |
|
(defun make-wrapper-cache-number-vector () |
424 |
|
(let ((cnv (make-array #.wrapper-cache-number-vector-length |
425 |
|
:element-type 'fixnum))) |
426 |
|
(dotimes (i #.wrapper-cache-number-vector-length) |
427 |
|
(setf (aref cnv i) (get-wrapper-cache-number))) |
428 |
|
cnv)) |
429 |
|
|
430 |
|
|
431 |
|
#-cmu17 |
432 |
|
(defstruct (wrapper |
433 |
|
#+new-kcl-wrapper (:include si::basic-wrapper) |
434 |
|
(:print-function print-wrapper) |
435 |
|
#-new-kcl-wrapper |
436 |
|
(:constructor make-wrapper (no-of-instance-slots &optional class)) |
437 |
|
#+new-kcl-wrapper |
438 |
|
(:constructor make-wrapper-internal)) |
439 |
|
#-new-kcl-wrapper |
440 |
|
(cache-number-vector (make-wrapper-cache-number-vector) |
441 |
|
:type cache-number-vector) |
442 |
|
#-new-kcl-wrapper |
443 |
|
(state t :type (or (member t) cons)) |
444 |
|
;; either t or a list (state-sym new-wrapper) |
445 |
|
;; where state-sym is either :flush or :obsolete |
446 |
|
(instance-slots-layout nil :type list) |
447 |
|
(class-slots nil :type list) |
448 |
|
#-new-kcl-wrapper |
449 |
|
(no-of-instance-slots 0 :type fixnum) |
450 |
|
#-new-kcl-wrapper |
451 |
|
(class *the-class-t* :type class)) |
452 |
|
|
453 |
|
|
454 |
|
(unless (boundp '*the-class-t*) (setq *the-class-t* nil)) |
455 |
|
|
456 |
|
#+new-kcl-wrapper |
457 |
|
(defmacro wrapper-no-of-instance-slots (wrapper) |
458 |
|
`(si::s-data-length ,wrapper)) |
459 |
|
|
460 |
|
|
461 |
|
;;; Note that for CMU, the WRAPPER of a built-in or structure class will be |
462 |
|
;;; some other kind of KERNEL:LAYOUT, but this shouldn't matter, since the only |
463 |
|
;;; two slots that WRAPPER adds are meaningless in those cases. |
464 |
|
;;; |
465 |
|
#+cmu17 |
466 |
|
(progn |
467 |
|
(defstruct (wrapper |
468 |
|
(:include kernel:layout) |
469 |
|
(:conc-name %wrapper-) |
470 |
|
(:print-function print-wrapper) |
471 |
|
(:constructor make-wrapper-internal)) |
472 |
|
(instance-slots-layout nil :type list) |
473 |
|
(class-slots nil :type list)) |
474 |
|
(declaim (ext:freeze-type wrapper)) |
475 |
|
|
476 |
|
(defmacro wrapper-class (wrapper) |
477 |
|
`(kernel:class-pcl-class (kernel:layout-class ,wrapper))) |
478 |
|
(defmacro wrapper-no-of-instance-slots (wrapper) |
479 |
|
`(kernel:layout-length ,wrapper)) |
480 |
|
(declaim (inline wrapper-state (setf wrapper-state))) |
481 |
|
|
482 |
|
(defun wrapper-state (wrapper) |
483 |
|
(let ((invalid (kernel:layout-invalid wrapper))) |
484 |
|
(cond ((null invalid) |
485 |
|
t) |
486 |
|
((atom invalid) |
487 |
|
;; Some non-pcl object. invalid is probably :INVALID |
488 |
|
;; We should compute the new wrapper here instead |
489 |
|
;; of returning nil, but why bother, since |
490 |
|
;; obsolete-instance-trap can't use it. |
491 |
|
'(:obsolete nil)) |
492 |
|
(t |
493 |
|
invalid)))) |
494 |
|
|
495 |
|
(defun (setf wrapper-state) (new-value wrapper) |
496 |
|
(setf (kernel:layout-invalid wrapper) |
497 |
|
(if (eq new-value 't) |
498 |
|
nil |
499 |
|
new-value))) |
500 |
|
|
501 |
|
(defmacro wrapper-instance-slots-layout (wrapper) |
502 |
|
`(%wrapper-instance-slots-layout ,wrapper)) |
503 |
|
(defmacro wrapper-class-slots (wrapper) |
504 |
|
`(%wrapper-class-slots ,wrapper)) |
505 |
|
(defmacro wrapper-cache-number-vector (x) x)) |
506 |
|
|
507 |
|
|
508 |
|
#+new-kcl-wrapper |
509 |
|
(defun make-wrapper (size &optional class) |
510 |
|
(multiple-value-bind (raw slot-positions) |
511 |
|
(if (< size 50) |
512 |
|
(values si::*all-t-s-type* si::*standard-slot-positions*) |
513 |
|
(values (make-array size :element-type 'unsigned-char) |
514 |
|
(let ((array (make-array size :element-type 'unsigned-short))) |
515 |
|
(dotimes (i size) |
516 |
|
(declare (fixnum i)) |
517 |
|
(setf (aref array i) (* #.(si::size-of t) i)))))) |
518 |
|
(make-wrapper-internal :length size |
519 |
|
:raw raw |
520 |
|
:print-function 'print-std-instance |
521 |
|
:slot-position slot-positions |
522 |
|
:size (* size #.(si::size-of t)) |
523 |
|
:class class))) |
524 |
|
|
525 |
|
#+cmu17 |
526 |
|
;;; BOOT-MAKE-WRAPPER -- Interface |
527 |
|
;;; |
528 |
|
;;; Called in BRAID when we are making wrappers for classes whose slots are |
529 |
|
;;; not initialized yet, and which may be built-in classes. We pass in the |
530 |
|
;;; class name in addition to the class. |
531 |
|
;;; |
532 |
|
(defun boot-make-wrapper (length name &optional class) |
533 |
|
(let ((found (lisp:find-class name nil))) |
534 |
|
(cond |
535 |
|
(found |
536 |
|
(unless (kernel:class-pcl-class found) |
537 |
|
(setf (kernel:class-pcl-class found) class)) |
538 |
|
(assert (eq (kernel:class-pcl-class found) class)) |
539 |
|
(let ((layout (kernel:class-layout found))) |
540 |
|
(assert layout) |
541 |
|
layout)) |
542 |
|
(t |
543 |
|
(kernel:initialize-layout-hash |
544 |
|
(make-wrapper-internal |
545 |
|
:length length |
546 |
|
:class (kernel:make-standard-class :name name :pcl-class class))))))) |
547 |
|
|
548 |
|
|
549 |
|
#+cmu17 |
550 |
|
;;; MAKE-WRAPPER -- Interface |
551 |
|
;;; |
552 |
|
;;; In CMU CL, the layouts (a.k.a wrappers) for built-in and structure |
553 |
|
;;; classes already exist when PCL is initialized, so we don't necessarily |
554 |
|
;;; always make a wrapper. Also, we help maintain the mapping between |
555 |
|
;;; lisp:class and pcl::class objects. |
556 |
|
;;; |
557 |
|
(defun make-wrapper (length class) |
558 |
|
(cond |
559 |
|
((typep class 'std-class) |
560 |
|
(kernel:initialize-layout-hash |
561 |
|
(make-wrapper-internal |
562 |
|
:length length |
563 |
|
:class |
564 |
|
(let ((owrap (class-wrapper class))) |
565 |
|
(cond (owrap |
566 |
|
(kernel:layout-class owrap)) |
567 |
|
((*subtypep (class-of class) |
568 |
|
*the-class-standard-class*) |
569 |
|
(kernel:make-standard-class :pcl-class class)) |
570 |
|
(t |
571 |
|
(kernel:make-random-pcl-class :pcl-class class))))))) |
572 |
|
(t |
573 |
|
(let* ((found (lisp:find-class (slot-value class 'name))) |
574 |
|
(layout (kernel:class-layout found))) |
575 |
|
(unless (kernel:class-pcl-class found) |
576 |
|
(setf (kernel:class-pcl-class found) class)) |
577 |
|
(assert (eq (kernel:class-pcl-class found) class)) |
578 |
|
(assert layout) |
579 |
|
layout)))) |
580 |
|
|
581 |
|
(defun print-wrapper (wrapper stream depth) |
582 |
|
(declare (ignore depth)) |
583 |
|
(printing-random-thing (wrapper stream) |
584 |
|
(format stream "Wrapper ~S" (wrapper-class wrapper)))) |
585 |
|
|
586 |
|
(defmacro first-wrapper-cache-number-index () |
587 |
|
0) |
588 |
|
|
589 |
|
(defmacro next-wrapper-cache-number-index (field-number) |
590 |
|
`(and (< (the field-type ,field-number) |
591 |
|
#.(1- wrapper-cache-number-vector-length)) |
592 |
|
(the field-type (1+ (the field-type ,field-number))))) |
593 |
|
|
594 |
|
#-cmu17 |
595 |
|
(defmacro cache-number-vector-ref (cnv n) |
596 |
|
`(#-kcl svref #+kcl aref ,cnv ,n)) |
597 |
|
|
598 |
|
#+cmu17 |
599 |
|
(defmacro cache-number-vector-ref (cnv n) |
600 |
|
`(wrapper-cache-number-vector-ref ,cnv ,n)) |
601 |
|
|
602 |
|
) |
603 |
|
|
604 |
|
#-cmu17 |
605 |
|
(defmacro wrapper-cache-number-vector-ref (wrapper n) |
606 |
|
`(the fixnum |
607 |
|
(#-structure-wrapper svref #+structure-wrapper aref |
608 |
|
(wrapper-cache-number-vector ,wrapper) ,n))) |
609 |
|
#+cmu17 |
610 |
|
(defmacro wrapper-cache-number-vector-ref (wrapper n) |
611 |
|
`(kernel:layout-hash ,wrapper ,n)) |
612 |
|
|
613 |
|
(defmacro class-no-of-instance-slots (class) |
614 |
|
`(wrapper-no-of-instance-slots (class-wrapper ,class))) |
615 |
|
|
616 |
|
(defmacro wrapper-class* (wrapper) |
617 |
|
#-(or new-kcl-wrapper cmu17) |
618 |
|
`(wrapper-class ,wrapper) |
619 |
|
#+(or new-kcl-wrapper cmu17) |
620 |
|
`(let ((wrapper ,wrapper)) |
621 |
|
(or (wrapper-class wrapper) |
622 |
|
(find-structure-class |
623 |
|
#+new-kcl-wrapper (si::s-data-name wrapper) |
624 |
|
#+cmu17 (lisp:class-name (kernel:layout-class wrapper)))))) |
625 |
|
|
626 |
|
;;; |
627 |
|
;;; The wrapper cache machinery provides general mechanism for trapping on |
628 |
|
;;; the next access to any instance of a given class. This mechanism is |
629 |
|
;;; used to implement the updating of instances when the class is redefined |
630 |
|
;;; (make-instances-obsolete). The same mechanism is also used to update |
631 |
|
;;; generic function caches when there is a change to the supers of a class. |
632 |
|
;;; |
633 |
|
;;; Basically, a given wrapper can be valid or invalid. If it is invalid, |
634 |
|
;;; it means that any attempt to do a wrapper cache lookup using the wrapper |
635 |
|
;;; should trap. Also, methods on slot-value-using-class check the wrapper |
636 |
|
;;; validity as well. This is done by calling check-wrapper-validity. |
637 |
|
;;; |
638 |
|
|
639 |
|
(defmacro invalid-wrapper-p (wrapper) |
640 |
|
`(neq (wrapper-state ,wrapper) 't)) |
641 |
|
|
642 |
|
(defvar *previous-nwrappers* (make-hash-table)) |
643 |
|
|
644 |
|
(defun invalidate-wrapper (owrapper state nwrapper) |
645 |
|
(ecase state |
646 |
|
((:flush :obsolete) |
647 |
|
(let ((new-previous ())) |
648 |
|
;; |
649 |
|
;; First off, a previous call to invalidate-wrapper may have recorded |
650 |
|
;; owrapper as an nwrapper to update to. Since owrapper is about to |
651 |
|
;; be invalid, it no longer makes sense to update to it. |
652 |
|
;; |
653 |
|
;; We go back and change the previously invalidated wrappers so that |
654 |
|
;; they will now update directly to nwrapper. This corresponds to a |
655 |
|
;; kind of transitivity of wrapper updates. |
656 |
|
;; |
657 |
|
(dolist (previous (gethash owrapper *previous-nwrappers*)) |
658 |
|
(when (eq state ':obsolete) |
659 |
|
(setf (car previous) ':obsolete)) |
660 |
|
(setf (cadr previous) nwrapper) |
661 |
|
(push previous new-previous)) |
662 |
|
|
663 |
|
(let ((ocnv (wrapper-cache-number-vector owrapper))) |
664 |
|
(iterate ((type (list-elements wrapper-layout)) |
665 |
|
(i (interval :from 0))) |
666 |
|
(when (eq type 'number) (setf (cache-number-vector-ref ocnv i) 0)))) |
667 |
|
(push (setf (wrapper-state owrapper) (list state nwrapper)) |
668 |
|
new-previous) |
669 |
|
|
670 |
|
(setf (gethash owrapper *previous-nwrappers*) () |
671 |
|
(gethash nwrapper *previous-nwrappers*) new-previous))))) |
672 |
|
|
673 |
|
(defun check-wrapper-validity (instance) |
674 |
|
(let* ((owrapper (wrapper-of instance)) |
675 |
|
(state (wrapper-state owrapper))) |
676 |
|
(if (eq state 't) |
677 |
|
owrapper |
678 |
|
(let ((nwrapper |
679 |
|
(ecase (car state) |
680 |
|
(:flush |
681 |
|
(flush-cache-trap owrapper (cadr state) instance)) |
682 |
|
(:obsolete |
683 |
|
(obsolete-instance-trap owrapper (cadr state) instance))))) |
684 |
|
;; |
685 |
|
;; This little bit of error checking is superfluous. It only |
686 |
|
;; checks to see whether the person who implemented the trap |
687 |
|
;; handling screwed up. Since that person is hacking internal |
688 |
|
;; PCL code, and is not a user, this should be needless. Also, |
689 |
|
;; since this directly slows down instance update and generic |
690 |
|
;; function cache refilling, feel free to take it out sometime |
691 |
|
;; soon. |
692 |
|
;; |
693 |
|
(cond ((neq nwrapper (wrapper-of instance)) |
694 |
|
(error "Wrapper returned from trap not wrapper of instance.")) |
695 |
|
((invalid-wrapper-p nwrapper) |
696 |
|
(error "Wrapper returned from trap invalid."))) |
697 |
|
nwrapper)))) |
698 |
|
|
699 |
|
#-cmu17 |
700 |
|
(defmacro check-wrapper-validity1 (object) |
701 |
|
(let ((owrapper (gensym))) |
702 |
|
`(let ((,owrapper (cond ((std-instance-p ,object) |
703 |
|
(std-instance-wrapper ,object)) |
704 |
|
((fsc-instance-p ,object) |
705 |
|
(fsc-instance-wrapper ,object)) |
706 |
|
#+new-kcl-wrapper |
707 |
|
(t (built-in-wrapper-of ,object)) |
708 |
|
#-new-kcl-wrapper |
709 |
|
(t (wrapper-of ,object))))) |
710 |
|
(if (eq 't (wrapper-state ,owrapper)) |
711 |
|
,owrapper |
712 |
|
(check-wrapper-validity ,object))))) |
713 |
|
|
714 |
|
#+cmu17 |
715 |
|
;;; semantically equivalent, but faster. |
716 |
|
;;; |
717 |
|
(defmacro check-wrapper-validity1 (object) |
718 |
|
(let ((owrapper (gensym))) |
719 |
|
`(let ((,owrapper (kernel:layout-of object))) |
720 |
|
(if (kernel:layout-invalid ,owrapper) |
721 |
|
(check-wrapper-validity ,object) |
722 |
|
,owrapper)))) |
723 |
|
|
724 |
|
|
725 |
|
(defvar *free-caches* nil) |
726 |
|
|
727 |
|
(defun get-cache (nkeys valuep limit-fn nlines) |
728 |
|
(declare (type non-negative-fixnum nlines)) |
729 |
|
(let ((cache (or (without-interrupts (pop *free-caches*)) (make-cache)))) |
730 |
|
(declare (type cache cache)) |
731 |
|
(multiple-value-bind (cache-mask actual-size line-size nlines) |
732 |
|
(compute-cache-parameters nkeys valuep nlines) |
733 |
|
(declare (type non-negative-fixnum |
734 |
|
cache-mask actual-size line-size nlines)) |
735 |
|
(setf (cache-nkeys cache) nkeys |
736 |
|
(cache-valuep cache) valuep |
737 |
|
(cache-nlines cache) nlines |
738 |
|
(cache-field cache) (first-wrapper-cache-number-index) |
739 |
|
(cache-limit-fn cache) limit-fn |
740 |
|
(cache-mask cache) cache-mask |
741 |
|
(cache-size cache) actual-size |
742 |
|
(cache-line-size cache) line-size |
743 |
|
(cache-max-location cache) |
744 |
|
(let ((line (1- nlines))) |
745 |
|
(declare (type non-negative-fixnum line)) |
746 |
|
(if (= nkeys 1) |
747 |
|
(the fixnum (* line line-size)) |
748 |
|
(the fixnum (1+ (the fixnum (* line line-size)))))) |
749 |
|
(cache-vector cache) (get-cache-vector actual-size) |
750 |
|
(cache-overflow cache) nil) |
751 |
|
cache))) |
752 |
|
|
753 |
|
(defun get-cache-from-cache (old-cache new-nlines |
754 |
|
&optional (new-field (first-wrapper-cache-number-index))) |
755 |
|
(declare (type non-negative-fixnum new-nlines)) |
756 |
|
(let ((nkeys (cache-nkeys old-cache)) |
757 |
|
(valuep (cache-valuep old-cache)) |
758 |
|
(cache (or (without-interrupts (pop *free-caches*)) (make-cache)))) |
759 |
|
(declare (type cache cache)) |
760 |
|
(multiple-value-bind (cache-mask actual-size line-size nlines) |
761 |
|
(if (= new-nlines (cache-nlines old-cache)) |
762 |
|
(values (cache-mask old-cache) (cache-size old-cache) |
763 |
|
(cache-line-size old-cache) (cache-nlines old-cache)) |
764 |
|
(compute-cache-parameters nkeys valuep new-nlines)) |
765 |
|
(declare (type non-negative-fixnum |
766 |
|
cache-mask actual-size line-size nlines)) |
767 |
|
(setf (cache-owner cache) (cache-owner old-cache) |
768 |
|
(cache-nkeys cache) nkeys |
769 |
|
(cache-valuep cache) valuep |
770 |
|
(cache-nlines cache) nlines |
771 |
|
(cache-field cache) new-field |
772 |
|
(cache-limit-fn cache) (cache-limit-fn old-cache) |
773 |
|
(cache-mask cache) cache-mask |
774 |
|
(cache-size cache) actual-size |
775 |
|
(cache-line-size cache) line-size |
776 |
|
(cache-max-location cache) |
777 |
|
(let ((line (1- nlines))) |
778 |
|
(declare (type non-negative-fixnum line)) |
779 |
|
(if (= nkeys 1) |
780 |
|
(the fixnum (* line line-size)) |
781 |
|
(the fixnum (1+ (the fixnum (* line line-size)))))) |
782 |
|
(cache-vector cache) (get-cache-vector actual-size) |
783 |
|
(cache-overflow cache) nil) |
784 |
|
cache))) |
785 |
|
|
786 |
|
(defun copy-cache (old-cache) |
787 |
|
(let* ((new-cache (copy-cache-internal old-cache)) |
788 |
|
(size (cache-size old-cache)) |
789 |
|
(old-vector (cache-vector old-cache)) |
790 |
|
(new-vector (get-cache-vector size))) |
791 |
|
(declare (simple-vector old-vector new-vector)) |
792 |
|
(dotimes (i size) |
793 |
|
(setf (svref new-vector i) (svref old-vector i))) |
794 |
|
(setf (cache-vector new-cache) new-vector) |
795 |
|
new-cache)) |
796 |
|
|
797 |
|
(defun free-cache (cache) |
798 |
|
(free-cache-vector (cache-vector cache)) |
799 |
|
(setf (cache-vector cache) #()) |
800 |
|
(setf (cache-owner cache) nil) |
801 |
|
(push cache *free-caches*) |
802 |
|
nil) |
803 |
|
|
804 |
|
(defun compute-line-size (x) |
805 |
|
(power-of-two-ceiling x)) |
806 |
|
|
807 |
|
(defun compute-cache-parameters (nkeys valuep nlines-or-cache-vector) |
808 |
|
;;(declare (values cache-mask actual-size line-size nlines)) |
809 |
|
(declare (type non-negative-fixnum nkeys)) |
810 |
|
(if (= nkeys 1) |
811 |
|
(let* ((line-size (if valuep 2 1)) |
812 |
|
(cache-size (if (typep nlines-or-cache-vector 'fixnum) |
813 |
|
(the non-negative-fixnum |
814 |
|
(* line-size |
815 |
|
(the non-negative-fixnum |
816 |
|
(power-of-two-ceiling |
817 |
|
nlines-or-cache-vector)))) |
818 |
|
(cache-vector-size nlines-or-cache-vector)))) |
819 |
|
(declare (type non-negative-fixnum line-size cache-size)) |
820 |
|
(values (logxor (the non-negative-fixnum (1- cache-size)) |
821 |
|
(the non-negative-fixnum (1- line-size))) |
822 |
|
cache-size |
823 |
|
line-size |
824 |
|
(the non-negative-fixnum (floor cache-size line-size)))) |
825 |
|
(let* ((line-size (power-of-two-ceiling (if valuep (1+ nkeys) nkeys))) |
826 |
|
(cache-size (if (typep nlines-or-cache-vector 'fixnum) |
827 |
|
(the non-negative-fixnum |
828 |
|
(* line-size |
829 |
|
(the non-negative-fixnum |
830 |
|
(power-of-two-ceiling |
831 |
|
nlines-or-cache-vector)))) |
832 |
|
(1- (cache-vector-size nlines-or-cache-vector))))) |
833 |
|
(declare (type non-negative-fixnum line-size cache-size)) |
834 |
|
(values (logxor (the non-negative-fixnum (1- cache-size)) |
835 |
|
(the non-negative-fixnum (1- line-size))) |
836 |
|
(the non-negative-fixnum (1+ cache-size)) |
837 |
|
line-size |
838 |
|
(the non-negative-fixnum (floor cache-size line-size)))))) |
839 |
|
|
840 |
|
|
841 |
|
|
842 |
|
;;; |
843 |
|
;;; The various implementations of computing a primary cache location from |
844 |
|
;;; wrappers. Because some implementations of this must run fast there are |
845 |
|
;;; several implementations of the same algorithm. |
846 |
|
;;; |
847 |
|
;;; The algorithm is: |
848 |
|
;;; |
849 |
|
;;; SUM over the wrapper cache numbers, |
850 |
|
;;; ENSURING that the result is a fixnum |
851 |
|
;;; MASK the result against the mask argument. |
852 |
|
;;; |
853 |
|
;;; |
854 |
|
|
855 |
|
;;; |
856 |
|
;;; COMPUTE-PRIMARY-CACHE-LOCATION |
857 |
|
;;; |
858 |
|
;;; The basic functional version. This is used by the cache miss code to |
859 |
|
;;; compute the primary location of an entry. |
860 |
|
;;; |
861 |
|
(defun compute-primary-cache-location (field mask wrappers) |
862 |
|
(declare (type field-type field) (type non-negative-fixnum mask)) |
863 |
|
(if (not (listp wrappers)) |
864 |
|
(logand mask (the non-negative-fixnum |
865 |
|
(wrapper-cache-number-vector-ref wrappers field))) |
866 |
|
(let ((location 0) (i 0)) |
867 |
|
(declare (type non-negative-fixnum location i)) |
868 |
|
(dolist (wrapper wrappers) |
869 |
|
;; |
870 |
|
;; First add the cache number of this wrapper to location. |
871 |
|
;; |
872 |
|
(let ((wrapper-cache-number |
873 |
|
(wrapper-cache-number-vector-ref wrapper field))) |
874 |
|
(declare (type non-negative-fixnum wrapper-cache-number)) |
875 |
|
(if (zerop wrapper-cache-number) |
876 |
|
(return-from compute-primary-cache-location 0) |
877 |
|
(setq location (the non-negative-fixnum |
878 |
|
(+ location wrapper-cache-number))))) |
879 |
|
;; |
880 |
|
;; Then, if we are working with lots of wrappers, deal with |
881 |
|
;; the wrapper-cache-number-mask stuff. |
882 |
|
;; |
883 |
|
(when (and (not (zerop i)) |
884 |
|
(zerop (mod i wrapper-cache-number-adds-ok))) |
885 |
|
(setq location |
886 |
|
(logand location wrapper-cache-number-mask))) |
887 |
|
(incf i)) |
888 |
|
(the non-negative-fixnum (1+ (logand mask location)))))) |
889 |
|
|
890 |
|
;;; |
891 |
|
;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION |
892 |
|
;;; |
893 |
|
;;; This version is called on a cache line. It fetches the wrappers from |
894 |
|
;;; the cache line and determines the primary location. Various parts of |
895 |
|
;;; the cache filling code call this to determine whether it is appropriate |
896 |
|
;;; to displace a given cache entry. |
897 |
|
;;; |
898 |
|
;;; If this comes across a wrapper whose cache-no is 0, it returns the symbol |
899 |
|
;;; invalid to suggest to its caller that it would be provident to blow away |
900 |
|
;;; the cache line in question. |
901 |
|
;;; |
902 |
|
(defun compute-primary-cache-location-from-location (to-cache from-location |
903 |
|
&optional (from-cache to-cache)) |
904 |
|
(declare (type cache to-cache from-cache) |
905 |
|
(type non-negative-fixnum from-location)) |
906 |
|
(let ((result 0) |
907 |
|
(cache-vector (cache-vector from-cache)) |
908 |
|
(field (cache-field to-cache)) |
909 |
|
(mask (cache-mask to-cache)) |
910 |
|
(nkeys (cache-nkeys to-cache))) |
911 |
|
(declare (type field-type field) |
912 |
|
(type non-negative-fixnum result mask nkeys) |
913 |
|
(simple-vector cache-vector)) |
914 |
|
(dotimes (i nkeys) |
915 |
|
(let* ((wrapper (cache-vector-ref cache-vector (+ i from-location))) |
916 |
|
(wcn (wrapper-cache-number-vector-ref wrapper field))) |
917 |
|
(declare (type non-negative-fixnum wcn)) |
918 |
|
(setq result (+ result wcn))) |
919 |
|
(when (and (not (zerop i)) |
920 |
|
(zerop (mod i wrapper-cache-number-adds-ok))) |
921 |
|
(setq result (logand result wrapper-cache-number-mask)))) |
922 |
|
(if (= nkeys 1) |
923 |
|
(logand mask result) |
924 |
|
(the non-negative-fixnum (1+ (logand mask result)))))) |
925 |
|
|
926 |
|
|
927 |
|
;;; |
928 |
|
;;; NIL means nothing so far, no actual arg info has NILs |
929 |
|
;;; in the metatype |
930 |
|
;;; CLASS seen all sorts of metaclasses |
931 |
|
;;; (specifically, more than one of the next 4 values) |
932 |
|
;;; T means everything so far is the class T |
933 |
|
;;; STANDARD-CLASS seen only standard classes |
934 |
|
;;; BUILT-IN-CLASS seen only built in classes |
935 |
|
;;; STRUCTURE-CLASS seen only structure classes |
936 |
|
;;; |
937 |
|
(defun raise-metatype (metatype new-specializer) |
938 |
|
(let ((slot (find-class 'slot-class)) |
939 |
|
(standard (find-class 'standard-class)) |
940 |
|
(fsc (find-class 'funcallable-standard-class)) |
941 |
|
(structure (find-class 'structure-class)) |
942 |
|
(built-in (find-class 'built-in-class))) |
943 |
|
(flet ((specializer->metatype (x) |
944 |
|
(let ((meta-specializer |
945 |
|
(if (eq *boot-state* 'complete) |
946 |
|
(class-of (specializer-class x)) |
947 |
|
(class-of x)))) |
948 |
|
(cond ((eq x *the-class-t*) t) |
949 |
|
((*subtypep meta-specializer standard) 'standard-instance) |
950 |
|
((*subtypep meta-specializer fsc) 'standard-instance) |
951 |
|
((*subtypep meta-specializer structure) 'structure-instance) |
952 |
|
((*subtypep meta-specializer built-in) 'built-in-instance) |
953 |
|
((*subtypep meta-specializer slot) 'slot-instance) |
954 |
|
(t (error "PCL can not handle the specializer ~S (meta-specializer ~S)." |
955 |
|
new-specializer meta-specializer)))))) |
956 |
|
;; |
957 |
|
;; We implement the following table. The notation is |
958 |
|
;; that X and Y are distinct meta specializer names. |
959 |
|
;; |
960 |
|
;; NIL <anything> ===> <anything> |
961 |
|
;; X X ===> X |
962 |
|
;; X Y ===> CLASS |
963 |
|
;; |
964 |
|
(let ((new-metatype (specializer->metatype new-specializer))) |
965 |
|
(cond ((eq new-metatype 'slot-instance) 'class) |
966 |
|
((null metatype) new-metatype) |
967 |
|
((eq metatype new-metatype) new-metatype) |
968 |
|
(t 'class)))))) |
969 |
|
|
970 |
|
(defmacro with-dfun-wrappers ((args metatypes) |
971 |
|
(dfun-wrappers invalid-wrapper-p |
972 |
|
&optional wrappers classes types) |
973 |
|
invalid-arguments-form |
974 |
|
&body body) |
975 |
|
`(let* ((args-tail ,args) (,invalid-wrapper-p nil) (invalid-arguments-p nil) |
976 |
|
(,dfun-wrappers nil) (dfun-wrappers-tail nil) |
977 |
|
,@(when wrappers |
978 |
|
`((wrappers-rev nil) (types-rev nil) (classes-rev nil)))) |
979 |
|
(dolist (mt ,metatypes) |
980 |
|
(unless args-tail |
981 |
|
(setq invalid-arguments-p t) |
982 |
|
(return nil)) |
983 |
|
(let* ((arg (pop args-tail)) |
984 |
|
(wrapper nil) |
985 |
|
,@(when wrappers |
986 |
|
`((class *the-class-t*) |
987 |
|
(type 't)))) |
988 |
|
(unless (eq mt 't) |
989 |
|
(setq wrapper (wrapper-of arg)) |
990 |
|
(when (invalid-wrapper-p wrapper) |
991 |
|
(setq ,invalid-wrapper-p t) |
992 |
|
(setq wrapper (check-wrapper-validity arg))) |
993 |
|
(cond ((null ,dfun-wrappers) |
994 |
|
(setq ,dfun-wrappers wrapper)) |
995 |
|
((not (consp ,dfun-wrappers)) |
996 |
|
(setq dfun-wrappers-tail (list wrapper)) |
997 |
|
(setq ,dfun-wrappers (cons ,dfun-wrappers dfun-wrappers-tail))) |
998 |
|
(t |
999 |
|
(let ((new-dfun-wrappers-tail (list wrapper))) |
1000 |
|
(setf (cdr dfun-wrappers-tail) new-dfun-wrappers-tail) |
1001 |
|
(setf dfun-wrappers-tail new-dfun-wrappers-tail)))) |
1002 |
|
,@(when wrappers |
1003 |
|
`((setq class (wrapper-class* wrapper)) |
1004 |
|
(setq type `(class-eq ,class))))) |
1005 |
|
,@(when wrappers |
1006 |
|
`((push wrapper wrappers-rev) |
1007 |
|
(push class classes-rev) |
1008 |
|
(push type types-rev))))) |
1009 |
|
(if invalid-arguments-p |
1010 |
|
,invalid-arguments-form |
1011 |
|
(let* (,@(when wrappers |
1012 |
|
`((,wrappers (nreverse wrappers-rev)) |
1013 |
|
(,classes (nreverse classes-rev)) |
1014 |
|
(,types (mapcar #'(lambda (class) |
1015 |
|
`(class-eq ,class)) |
1016 |
|
,classes))))) |
1017 |
|
,@body)))) |
1018 |
|
|
1019 |
|
|
1020 |
|
;;; |
1021 |
|
;;; Some support stuff for getting a hold of symbols that we need when |
1022 |
|
;;; building the discriminator codes. Its ok for these to be interned |
1023 |
|
;;; symbols because we don't capture any user code in the scope in which |
1024 |
|
;;; these symbols are bound. |
1025 |
|
;;; |
1026 |
|
|
1027 |
|
(defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.)) |
1028 |
|
|
1029 |
|
(defun dfun-arg-symbol (arg-number) |
1030 |
|
(or (nth arg-number (the list *dfun-arg-symbols*)) |
1031 |
|
(intern (format nil ".ARG~A." arg-number) *the-pcl-package*))) |
1032 |
|
|
1033 |
|
(defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.)) |
1034 |
|
|
1035 |
|
(defun slot-vector-symbol (arg-number) |
1036 |
|
(or (nth arg-number (the list *slot-vector-symbols*)) |
1037 |
|
(intern (format nil ".SLOTS~A." arg-number) *the-pcl-package*))) |
1038 |
|
|
1039 |
|
(defun make-dfun-lambda-list (metatypes applyp) |
1040 |
|
(gathering1 (collecting) |
1041 |
|
(iterate ((i (interval :from 0)) |
1042 |
|
(s (list-elements metatypes))) |
1043 |
|
(progn s) |
1044 |
|
(gather1 (dfun-arg-symbol i))) |
1045 |
|
(when applyp |
1046 |
|
(gather1 '&rest) |
1047 |
|
(gather1 '.dfun-rest-arg.)))) |
1048 |
|
|
1049 |
|
(defun make-dlap-lambda-list (metatypes applyp) |
1050 |
|
(gathering1 (collecting) |
1051 |
|
(iterate ((i (interval :from 0)) |
1052 |
|
(s (list-elements metatypes))) |
1053 |
|
(progn s) |
1054 |
|
(gather1 (dfun-arg-symbol i))) |
1055 |
|
(when applyp |
1056 |
|
(gather1 '&rest)))) |
1057 |
|
|
1058 |
|
(defun make-emf-call (metatypes applyp fn-variable &optional emf-type) |
1059 |
|
(let ((required |
1060 |
|
(gathering1 (collecting) |
1061 |
|
(iterate ((i (interval :from 0)) |
1062 |
|
(s (list-elements metatypes))) |
1063 |
|
(progn s) |
1064 |
|
(gather1 (dfun-arg-symbol i)))))) |
1065 |
|
`(,(if (eq emf-type 'fast-method-call) |
1066 |
|
'invoke-effective-method-function-fast |
1067 |
|
'invoke-effective-method-function) |
1068 |
|
,fn-variable ,applyp ,@required ,@(when applyp `(.dfun-rest-arg.))))) |
1069 |
|
|
1070 |
|
(defun make-dfun-call (metatypes applyp fn-variable) |
1071 |
|
(let ((required |
1072 |
|
(gathering1 (collecting) |
1073 |
|
(iterate ((i (interval :from 0)) |
1074 |
|
(s (list-elements metatypes))) |
1075 |
|
(progn s) |
1076 |
|
(gather1 (dfun-arg-symbol i)))))) |
1077 |
|
(if applyp |
1078 |
|
`(function-apply ,fn-variable ,@required .dfun-rest-arg.) |
1079 |
|
`(function-funcall ,fn-variable ,@required)))) |
1080 |
|
|
1081 |
|
(defun make-dfun-arg-list (metatypes applyp) |
1082 |
|
(let ((required |
1083 |
|
(gathering1 (collecting) |
1084 |
|
(iterate ((i (interval :from 0)) |
1085 |
|
(s (list-elements metatypes))) |
1086 |
|
(progn s) |
1087 |
|
(gather1 (dfun-arg-symbol i)))))) |
1088 |
|
(if applyp |
1089 |
|
`(list* ,@required .dfun-rest-arg.) |
1090 |
|
`(list ,@required)))) |
1091 |
|
|
1092 |
|
(defun make-fast-method-call-lambda-list (metatypes applyp) |
1093 |
|
(gathering1 (collecting) |
1094 |
|
(gather1 '.pv-cell.) |
1095 |
|
(gather1 '.next-method-call.) |
1096 |
|
(iterate ((i (interval :from 0)) |
1097 |
|
(s (list-elements metatypes))) |
1098 |
|
(progn s) |
1099 |
|
(gather1 (dfun-arg-symbol i))) |
1100 |
|
(when applyp |
1101 |
|
(gather1 '.dfun-rest-arg.)))) |
1102 |
|
|
1103 |
|
(defmacro fin-lambda-fn (arglist &body body) |
1104 |
|
`#'(#+cmu kernel:instance-lambda #-cmu lambda |
1105 |
|
,arglist |
1106 |
|
,@body)) |
1107 |
|
|
1108 |
|
(defun make-dispatch-lambda (function-p metatypes applyp body) |
1109 |
|
`(#+cmu ,(if function-p 'kernel:instance-lambda 'lambda) #-cmu lambda |
1110 |
|
,(if function-p |
1111 |
|
(make-dfun-lambda-list metatypes applyp) |
1112 |
|
(make-fast-method-call-lambda-list metatypes applyp)) |
1113 |
|
,@(unless function-p |
1114 |
|
`((declare (ignore .pv-cell. .next-method-call.)))) |
1115 |
|
#+cmu (declare (ignorable ,@(cddr (make-fast-method-call-lambda-list |
1116 |
|
metatypes applyp)))) |
1117 |
|
#+copy-&rest-arg |
1118 |
|
,@(when (and applyp function-p) |
1119 |
|
`((setq .dfun-rest-arg. (copy-list .dfun-rest-arg.)))) |
1120 |
|
,@body)) |
1121 |
|
|
1122 |
|
|
1123 |
|
;;; |
1124 |
|
;;; Its too bad Common Lisp compilers freak out when you have a defun with |
1125 |
|
;;; a lot of LABELS in it. If I could do that I could make this code much |
1126 |
|
;;; easier to read and work with. |
1127 |
|
;;; |
1128 |
|
;;; Ahh Scheme... |
1129 |
|
;;; |
1130 |
|
;;; In the absence of that, the following little macro makes the code that |
1131 |
|
;;; follows a little bit more reasonable. I would like to add that having |
1132 |
|
;;; to practically write my own compiler in order to get just this simple |
1133 |
|
;;; thing is something of a drag. |
1134 |
|
;;; |
1135 |
|
(eval-when (compile load eval) |
1136 |
|
|
1137 |
|
(defvar *cache* nil) |
1138 |
|
|
1139 |
|
(defconstant *local-cache-functions* |
1140 |
|
'((cache () .cache.) |
1141 |
|
(nkeys () (cache-nkeys .cache.)) |
1142 |
|
(line-size () (cache-line-size .cache.)) |
1143 |
|
(vector () (cache-vector .cache.)) |
1144 |
|
(valuep () (cache-valuep .cache.)) |
1145 |
|
(nlines () (cache-nlines .cache.)) |
1146 |
|
(max-location () (cache-max-location .cache.)) |
1147 |
|
(limit-fn () (cache-limit-fn .cache.)) |
1148 |
|
(size () (cache-size .cache.)) |
1149 |
|
(mask () (cache-mask .cache.)) |
1150 |
|
(field () (cache-field .cache.)) |
1151 |
|
(overflow () (cache-overflow .cache.)) |
1152 |
|
|
1153 |
|
;; |
1154 |
|
;; Return T IFF this cache location is reserved. The only time |
1155 |
|
;; this is true is for line number 0 of an nkeys=1 cache. |
1156 |
|
;; |
1157 |
|
(line-reserved-p (line) |
1158 |
|
(declare (type non-negative-fixnum line)) |
1159 |
|
(and (= (nkeys) 1) |
1160 |
|
(= line 0))) |
1161 |
|
;; |
1162 |
|
(location-reserved-p (location) |
1163 |
|
(declare (type non-negative-fixnum location)) |
1164 |
|
(and (= (nkeys) 1) |
1165 |
|
(= location 0))) |
1166 |
|
;; |
1167 |
|
;; Given a line number, return the cache location. This is the |
1168 |
|
;; value that is the second argument to cache-vector-ref. Basically, |
1169 |
|
;; this deals with the offset of nkeys>1 caches and multiplies |
1170 |
|
;; by line size. |
1171 |
|
;; |
1172 |
|
(line-location (line) |
1173 |
|
(declare (type non-negative-fixnum line)) |
1174 |
|
(when (line-reserved-p line) |
1175 |
|
(error "line is reserved")) |
1176 |
|
(if (= (nkeys) 1) |
1177 |
|
(the non-negative-fixnum (* line (line-size))) |
1178 |
|
(the non-negative-fixnum |
1179 |
|
(1+ (the non-negative-fixnum (* line (line-size))))))) |
1180 |
|
;; |
1181 |
|
;; Given a cache location, return the line. This is the inverse |
1182 |
|
;; of LINE-LOCATION. |
1183 |
|
;; |
1184 |
|
(location-line (location) |
1185 |
|
(declare (type non-negative-fixnum location)) |
1186 |
|
(if (= (nkeys) 1) |
1187 |
|
(floor location (line-size)) |
1188 |
|
(floor (the non-negative-fixnum (1- location)) (line-size)))) |
1189 |
|
;; |
1190 |
|
;; Given a line number, return the wrappers stored at that line. |
1191 |
|
;; As usual, if nkeys=1, this returns a single value. Only when |
1192 |
|
;; nkeys>1 does it return a list. An error is signalled if the |
1193 |
|
;; line is reserved. |
1194 |
|
;; |
1195 |
|
(line-wrappers (line) |
1196 |
|
(declare (type non-negative-fixnum line)) |
1197 |
|
(when (line-reserved-p line) (error "Line is reserved.")) |
1198 |
|
(location-wrappers (line-location line))) |
1199 |
|
;; |
1200 |
|
(location-wrappers (location) ; avoid multiplies caused by line-location |
1201 |
|
(declare (type non-negative-fixnum location)) |
1202 |
|
(if (= (nkeys) 1) |
1203 |
|
(cache-vector-ref (vector) location) |
1204 |
|
(let ((list (make-list (nkeys))) |
1205 |
|
(vector (vector))) |
1206 |
|
(declare (simple-vector vector)) |
1207 |
|
(dotimes (i (nkeys) list) |
1208 |
|
(setf (nth i list) (cache-vector-ref vector (+ location i))))))) |
1209 |
|
;; |
1210 |
|
;; Given a line number, return true IFF the line's |
1211 |
|
;; wrappers are the same as wrappers. |
1212 |
|
;; |
1213 |
|
(line-matches-wrappers-p (line wrappers) |
1214 |
|
(declare (type non-negative-fixnum line)) |
1215 |
|
(and (not (line-reserved-p line)) |
1216 |
|
(location-matches-wrappers-p (line-location line) wrappers))) |
1217 |
|
;; |
1218 |
|
(location-matches-wrappers-p (loc wrappers) ; must not be reserved |
1219 |
|
(declare (type non-negative-fixnum loc)) |
1220 |
|
(let ((cache-vector (vector))) |
1221 |
|
(declare (simple-vector cache-vector)) |
1222 |
|
(if (= (nkeys) 1) |
1223 |
|
(eq wrappers (cache-vector-ref cache-vector loc)) |
1224 |
|
(dotimes (i (nkeys) t) |
1225 |
|
(unless (eq (pop wrappers) |
1226 |
|
(cache-vector-ref cache-vector (+ loc i))) |
1227 |
|
(return nil)))))) |
1228 |
|
;; |
1229 |
|
;; Given a line number, return the value stored at that line. |
1230 |
|
;; If valuep is NIL, this returns NIL. As with line-wrappers, |
1231 |
|
;; an error is signalled if the line is reserved. |
1232 |
|
;; |
1233 |
|
(line-value (line) |
1234 |
|
(declare (type non-negative-fixnum line)) |
1235 |
|
(when (line-reserved-p line) (error "Line is reserved.")) |
1236 |
|
(location-value (line-location line))) |
1237 |
|
;; |
1238 |
|
(location-value (loc) |
1239 |
|
(declare (type non-negative-fixnum loc)) |
1240 |
|
(and (valuep) |
1241 |
|
(cache-vector-ref (vector) (+ loc (nkeys))))) |
1242 |
|
;; |
1243 |
|
;; Given a line number, return true IFF that line has data in |
1244 |
|
;; it. The state of the wrappers stored in the line is not |
1245 |
|
;; checked. An error is signalled if line is reserved. |
1246 |
|
(line-full-p (line) |
1247 |
|
(when (line-reserved-p line) (error "Line is reserved.")) |
1248 |
|
(not (null (cache-vector-ref (vector) (line-location line))))) |
1249 |
|
;; |
1250 |
|
;; Given a line number, return true IFF the line is full and |
1251 |
|
;; there are no invalid wrappers in the line, and the line's |
1252 |
|
;; wrappers are different from wrappers. |
1253 |
|
;; An error is signalled if the line is reserved. |
1254 |
|
;; |
1255 |
|
(line-valid-p (line wrappers) |
1256 |
|
(declare (type non-negative-fixnum line)) |
1257 |
|
(when (line-reserved-p line) (error "Line is reserved.")) |
1258 |
|
(location-valid-p (line-location line) wrappers)) |
1259 |
|
;; |
1260 |
|
(location-valid-p (loc wrappers) |
1261 |
|
(declare (type non-negative-fixnum loc)) |
1262 |
|
(let ((cache-vector (vector)) |
1263 |
|
(wrappers-mismatch-p (null wrappers))) |
1264 |
|
(declare (simple-vector cache-vector)) |
1265 |
|
(dotimes (i (nkeys) wrappers-mismatch-p) |
1266 |
|
(let ((wrapper (cache-vector-ref cache-vector (+ loc i)))) |
1267 |
|
(when (or (null wrapper) |
1268 |
|
(invalid-wrapper-p wrapper)) |
1269 |
|
(return nil)) |
1270 |
|
(unless (and wrappers |
1271 |
|
(eq wrapper |
1272 |
|
(if (consp wrappers) (pop wrappers) wrappers))) |
1273 |
|
(setq wrappers-mismatch-p t)))))) |
1274 |
|
;; |
1275 |
|
;; How many unreserved lines separate line-1 and line-2. |
1276 |
|
;; |
1277 |
|
(line-separation (line-1 line-2) |
1278 |
|
(declare (type non-negative-fixnum line-1 line-2)) |
1279 |
|
(let ((diff (the fixnum (- line-2 line-1)))) |
1280 |
|
(declare (fixnum diff)) |
1281 |
|
(when (minusp diff) |
1282 |
|
(setq diff (+ diff (nlines))) |
1283 |
|
(when (line-reserved-p 0) |
1284 |
|
(setq diff (1- diff)))) |
1285 |
|
diff)) |
1286 |
|
;; |
1287 |
|
;; Given a cache line, get the next cache line. This will not |
1288 |
|
;; return a reserved line. |
1289 |
|
;; |
1290 |
|
(next-line (line) |
1291 |
|
(declare (type non-negative-fixnum line)) |
1292 |
|
(if (= line (the fixnum (1- (nlines)))) |
1293 |
|
(if (line-reserved-p 0) 1 0) |
1294 |
|
(the non-negative-fixnum (1+ line)))) |
1295 |
|
;; |
1296 |
|
(next-location (loc) |
1297 |
|
(declare (type non-negative-fixnum loc)) |
1298 |
|
(if (= loc (max-location)) |
1299 |
|
(if (= (nkeys) 1) |
1300 |
|
(line-size) |
1301 |
|
1) |
1302 |
|
(the non-negative-fixnum (+ loc (line-size))))) |
1303 |
|
;; |
1304 |
|
;; Given a line which has a valid entry in it, this will return |
1305 |
|
;; the primary cache line of the wrappers in that line. We just |
1306 |
|
;; call COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this is an |
1307 |
|
;; easier packaging up of the call to it. |
1308 |
|
;; |
1309 |
|
(line-primary (line) |
1310 |
|
(declare (type non-negative-fixnum line)) |
1311 |
|
(location-line (line-primary-location line))) |
1312 |
|
;; |
1313 |
|
(line-primary-location (line) |
1314 |
|
(declare (type non-negative-fixnum line)) |
1315 |
|
(compute-primary-cache-location-from-location |
1316 |
|
(cache) (line-location line))) |
1317 |
|
)) |
1318 |
|
|
1319 |
|
(defmacro with-local-cache-functions ((cache) &body body) |
1320 |
|
`(let ((.cache. ,cache)) |
1321 |
|
(declare (type cache .cache.)) |
1322 |
|
(macrolet ,(mapcar #'(lambda (fn) |
1323 |
|
`(,(car fn) ,(cadr fn) |
1324 |
|
`(let (,,@(mapcar #'(lambda (var) |
1325 |
|
``(,',var ,,var)) |
1326 |
|
(cadr fn))) |
1327 |
|
,@',(cddr fn)))) |
1328 |
|
*local-cache-functions*) |
1329 |
|
,@body))) |
1330 |
|
|
1331 |
|
) |
1332 |
|
|
1333 |
|
;;; |
1334 |
|
;;; Here is where we actually fill, recache and expand caches. |
1335 |
|
;;; |
1336 |
|
;;; The functions FILL-CACHE and PROBE-CACHE are the ONLY external |
1337 |
|
;;; entrypoints into this code. |
1338 |
|
;;; |
1339 |
|
;;; FILL-CACHE returns 1 value: a new cache |
1340 |
|
;;; |
1341 |
|
;;; a wrapper field number |
1342 |
|
;;; a cache |
1343 |
|
;;; a mask |
1344 |
|
;;; an absolute cache size (the size of the actual vector) |
1345 |
|
;;; It tries to re-adjust the cache every time it makes a new fill. The |
1346 |
|
;;; intuition here is that we want uniformity in the number of probes needed to |
1347 |
|
;;; find an entry. Furthermore, adjusting has the nice property of throwing out |
1348 |
|
;;; any entries that are invalid. |
1349 |
|
;;; |
1350 |
|
(defvar *cache-expand-threshold* 1.25) |
1351 |
|
|
1352 |
|
(defun fill-cache (cache wrappers value &optional free-cache-p) |
1353 |
|
;;(declare (values cache)) |
1354 |
|
(unless wrappers ; fill-cache won't return if wrappers is nil, might as well check. |
1355 |
|
(error "fill-cache: wrappers arg is NIL!")) |
1356 |
|
(or (fill-cache-p nil cache wrappers value) |
1357 |
|
(and (< (ceiling (* (cache-count cache) 1.25)) |
1358 |
|
(if (= (cache-nkeys cache) 1) |
1359 |
|
(1- (cache-nlines cache)) |
1360 |
|
(cache-nlines cache))) |
1361 |
|
(adjust-cache cache wrappers value free-cache-p)) |
1362 |
|
(expand-cache cache wrappers value free-cache-p))) |
1363 |
|
|
1364 |
|
(defvar *check-cache-p* nil) |
1365 |
|
|
1366 |
|
(defmacro maybe-check-cache (cache) |
1367 |
|
`(progn |
1368 |
|
(when *check-cache-p* |
1369 |
|
(check-cache ,cache)) |
1370 |
|
,cache)) |
1371 |
|
|
1372 |
|
(defun check-cache (cache) |
1373 |
|
(with-local-cache-functions (cache) |
1374 |
|
(let ((location (if (= (nkeys) 1) 0 1)) |
1375 |
|
(limit (funcall (limit-fn) (nlines)))) |
1376 |
|
(dotimes (i (nlines) cache) |
1377 |
|
(when (and (not (location-reserved-p location)) |
1378 |
|
(line-full-p i)) |
1379 |
|
(let* ((home-loc (compute-primary-cache-location-from-location |
1380 |
|
cache location)) |
1381 |
|
(home (location-line (if (location-reserved-p home-loc) |
1382 |
|
(next-location home-loc) |
1383 |
|
home-loc))) |
1384 |
|
(sep (when home (line-separation home i)))) |
1385 |
|
(when (and sep (> sep limit)) |
1386 |
|
(error "bad cache ~S ~@ |
1387 |
|
value at location ~D is ~D lines from its home. limit is ~D." |
1388 |
|
cache location sep limit)))) |
1389 |
|
(setq location (next-location location)))))) |
1390 |
|
|
1391 |
|
(defun probe-cache (cache wrappers &optional default limit-fn) |
1392 |
|
;;(declare (values value)) |
1393 |
|
(unless wrappers (error "probe-cache: wrappers arg is NIL!")) |
1394 |
|
(with-local-cache-functions (cache) |
1395 |
|
(let* ((location (compute-primary-cache-location (field) (mask) wrappers)) |
1396 |
|
(limit (funcall (or limit-fn (limit-fn)) (nlines)))) |
1397 |
|
(declare (type non-negative-fixnum location limit)) |
1398 |
|
(when (location-reserved-p location) |
1399 |
|
(setq location (next-location location))) |
1400 |
|
(dotimes (i (1+ limit)) |
1401 |
|
(when (location-matches-wrappers-p location wrappers) |
1402 |
|
(return-from probe-cache (or (not (valuep)) |
1403 |
|
(location-value location)))) |
1404 |
|
(setq location (next-location location))) |
1405 |
|
(dolist (entry (overflow)) |
1406 |
|
(when (equal (car entry) wrappers) |
1407 |
|
(return-from probe-cache (or (not (valuep)) |
1408 |
|
(cdr entry))))) |
1409 |
|
default))) |
1410 |
|
|
1411 |
|
(defun map-cache (function cache &optional set-p) |
1412 |
|
(with-local-cache-functions (cache) |
1413 |
|
(let ((set-p (and set-p (valuep)))) |
1414 |
|
(dotimes (i (nlines) cache) |
1415 |
|
(unless (or (line-reserved-p i) (not (line-valid-p i nil))) |
1416 |
|
(let ((value (funcall function (line-wrappers i) (line-value i)))) |
1417 |
|
(when set-p |
1418 |
|
(setf (cache-vector-ref (vector) (+ (line-location i) (nkeys))) |
1419 |
|
value))))) |
1420 |
|
(dolist (entry (overflow)) |
1421 |
|
(let ((value (funcall function (car entry) (cdr entry)))) |
1422 |
|
(when set-p |
1423 |
|
(setf (cdr entry) value)))))) |
1424 |
|
cache) |
1425 |
|
|
1426 |
|
(defun cache-count (cache) |
1427 |
|
(with-local-cache-functions (cache) |
1428 |
|
(let ((count 0)) |
1429 |
|
(declare (type non-negative-fixnum count)) |
1430 |
|
(dotimes (i (nlines) count) |
1431 |
|
(unless (line-reserved-p i) |
1432 |
|
(when (line-full-p i) |
1433 |
|
(incf count))))))) |
1434 |
|
|
1435 |
|
(defun entry-in-cache-p (cache wrappers value) |
1436 |
|
(declare (ignore value)) |
1437 |
|
(with-local-cache-functions (cache) |
1438 |
|
(dotimes (i (nlines)) |
1439 |
|
(unless (line-reserved-p i) |
1440 |
|
(when (equal (line-wrappers i) wrappers) |
1441 |
|
(return t)))))) |
1442 |
|
|
1443 |
|
;;; |
1444 |
|
;;; returns T or NIL |
1445 |
|
;;; |
1446 |
|
(defun fill-cache-p (forcep cache wrappers value) |
1447 |
|
(with-local-cache-functions (cache) |
1448 |
|
(let* ((location (compute-primary-cache-location (field) (mask) wrappers)) |
1449 |
|
(primary (location-line location))) |
1450 |
|
(declare (type non-negative-fixnum location primary)) |
1451 |
|
(multiple-value-bind (free emptyp) |
1452 |
|
(find-free-cache-line primary cache wrappers) |
1453 |
|
(when (or forcep emptyp) |
1454 |
|
(when (not emptyp) |
1455 |
|
(push (cons (line-wrappers free) (line-value free)) |
1456 |
|
(cache-overflow cache))) |
1457 |
|
;;(fill-line free wrappers value) |
1458 |
|
(let ((line free)) |
1459 |
|
(declare (type non-negative-fixnum line)) |
1460 |
|
(when (line-reserved-p line) |
1461 |
|
(error "Attempt to fill a reserved line.")) |
1462 |
|
(let ((loc (line-location line)) |
1463 |
|
(cache-vector (vector))) |
1464 |
|
(declare (type non-negative-fixnum loc) |
1465 |
|
(simple-vector cache-vector)) |
1466 |
|
(cond ((= (nkeys) 1) |
1467 |
|
(setf (cache-vector-ref cache-vector loc) wrappers) |
1468 |
|
(when (valuep) |
1469 |
|
(setf (cache-vector-ref cache-vector (1+ loc)) value))) |
1470 |
|
(t |
1471 |
|
(let ((i 0)) |
1472 |
|
(declare (type non-negative-fixnum i)) |
1473 |
|
(dolist (w wrappers) |
1474 |
|
(setf (cache-vector-ref cache-vector (+ loc i)) w) |
1475 |
|
(setq i (the non-negative-fixnum (1+ i))))) |
1476 |
|
(when (valuep) |
1477 |
|
(setf (cache-vector-ref cache-vector (+ loc (nkeys))) |
1478 |
|
value)))) |
1479 |
|
(maybe-check-cache cache)))))))) |
1480 |
|
|
1481 |
|
(defun fill-cache-from-cache-p (forcep cache from-cache from-line) |
1482 |
|
(declare (type non-negative-fixnum from-line)) |
1483 |
|
(with-local-cache-functions (cache) |
1484 |
|
(let ((primary (location-line (compute-primary-cache-location-from-location |
1485 |
|
cache (line-location from-line) from-cache)))) |
1486 |
|
(declare (type non-negative-fixnum primary)) |
1487 |
|
(multiple-value-bind (free emptyp) |
1488 |
|
(find-free-cache-line primary cache) |
1489 |
|
(when (or forcep emptyp) |
1490 |
|
(when (not emptyp) |
1491 |
|
(push (cons (line-wrappers free) (line-value free)) |
1492 |
|
(cache-overflow cache))) |
1493 |
|
;;(transfer-line from-cache-vector from-line cache-vector free) |
1494 |
|
(let ((from-cache-vector (cache-vector from-cache)) |
1495 |
|
(to-cache-vector (vector)) |
1496 |
|
(to-line free)) |
1497 |
|
(declare (type non-negative-fixnum to-line)) |
1498 |
|
(if (line-reserved-p to-line) |
1499 |
|
(error "transfering something into a reserved cache line.") |
1500 |
|
(let ((from-loc (line-location from-line)) |
1501 |
|
(to-loc (line-location to-line))) |
1502 |
|
(declare (type non-negative-fixnum from-loc to-loc)) |
1503 |
|
(modify-cache to-cache-vector |
1504 |
|
(dotimes (i (line-size)) |
1505 |
|
(setf (cache-vector-ref to-cache-vector |
1506 |
|
(+ to-loc i)) |
1507 |
|
(cache-vector-ref from-cache-vector |
1508 |
|
(+ from-loc i))))))) |
1509 |
|
(maybe-check-cache cache))))))) |
1510 |
|
|
1511 |
|
;;; |
1512 |
|
;;; Returns NIL or (values <field> <cache-vector>) |
1513 |
|
;;; |
1514 |
|
;;; This is only called when it isn't possible to put the entry in the cache |
1515 |
|
;;; the easy way. That is, this function assumes that FILL-CACHE-P has been |
1516 |
|
;;; called as returned NIL. |
1517 |
|
;;; |
1518 |
|
;;; If this returns NIL, it means that it wasn't possible to find a wrapper |
1519 |
|
;;; field for which all of the entries could be put in the cache (within the |
1520 |
|
;;; limit). |
1521 |
|
;;; |
1522 |
|
(defun adjust-cache (cache wrappers value free-old-cache-p) |
1523 |
|
(with-local-cache-functions (cache) |
1524 |
|
(let ((ncache (get-cache-from-cache cache (nlines) (field)))) |
1525 |
|
(do ((nfield (cache-field ncache) |
1526 |
|
(next-wrapper-cache-number-index nfield))) |
1527 |
|
((null nfield) (free-cache ncache) nil) |
1528 |
|
(let ((nfield nfield)) |
1529 |
|
(declare (type field-type nfield)) |
1530 |
|
(setf (cache-field ncache) nfield) |
1531 |
|
(labels ((try-one-fill-from-line (line) |
1532 |
|
(fill-cache-from-cache-p nil ncache cache line)) |
1533 |
|
(try-one-fill (wrappers value) |
1534 |
|
(fill-cache-p nil ncache wrappers value))) |
1535 |
|
(if (and (dotimes (i (nlines) t) |
1536 |
|
(when (and (null (line-reserved-p i)) |
1537 |
|
(line-valid-p i wrappers)) |
1538 |
|
(unless (try-one-fill-from-line i) (return nil)))) |
1539 |
|
(dolist (wrappers+value (cache-overflow cache) t) |
1540 |
|
(unless (try-one-fill (car wrappers+value) |
1541 |
|
(cdr wrappers+value)) |
1542 |
|
(return nil))) |
1543 |
|
(try-one-fill wrappers value)) |
1544 |
|
(progn (when free-old-cache-p (free-cache cache)) |
1545 |
|
(return (maybe-check-cache ncache))) |
1546 |
|
(flush-cache-vector-internal (cache-vector ncache))))))))) |
1547 |
|
|
1548 |
|
|
1549 |
|
;;; |
1550 |
|
;;; returns: (values <cache>) |
1551 |
|
;;; |
1552 |
|
(defun expand-cache (cache wrappers value free-old-cache-p) |
1553 |
|
;;(declare (values cache)) |
1554 |
|
(with-local-cache-functions (cache) |
1555 |
|
(let ((ncache (get-cache-from-cache cache (* (nlines) 2)))) |
1556 |
|
(labels ((do-one-fill-from-line (line) |
1557 |
|
(unless (fill-cache-from-cache-p nil ncache cache line) |
1558 |
|
(do-one-fill (line-wrappers line) (line-value line)))) |
1559 |
|
(do-one-fill (wrappers value) |
1560 |
|
(setq ncache (or (adjust-cache ncache wrappers value t) |
1561 |
|
(fill-cache-p t ncache wrappers value)))) |
1562 |
|
(try-one-fill (wrappers value) |
1563 |
|
(fill-cache-p nil ncache wrappers value))) |
1564 |
|
(dotimes (i (nlines)) |
1565 |
|
(when (and (null (line-reserved-p i)) |
1566 |
|
(line-valid-p i wrappers)) |
1567 |
|
(do-one-fill-from-line i))) |
1568 |
|
(dolist (wrappers+value (cache-overflow cache)) |
1569 |
|
(unless (try-one-fill (car wrappers+value) (cdr wrappers+value)) |
1570 |
|
(do-one-fill (car wrappers+value) (cdr wrappers+value)))) |
1571 |
|
(unless (try-one-fill wrappers value) |
1572 |
|
(do-one-fill wrappers value)) |
1573 |
|
(when free-old-cache-p (free-cache cache)) |
1574 |
|
(maybe-check-cache ncache))))) |
1575 |
|
|
1576 |
|
|
1577 |
|
;;; |
1578 |
|
;;; This is the heart of the cache filling mechanism. It implements the decisions |
1579 |
|
;;; about where entries are placed. |
1580 |
|
;;; |
1581 |
|
;;; Find a line in the cache at which a new entry can be inserted. |
1582 |
|
;;; |
1583 |
|
;;; <line> |
1584 |
|
;;; <empty?> is <line> in fact empty? |
1585 |
|
;;; |
1586 |
|
(defun find-free-cache-line (primary cache &optional wrappers) |
1587 |
|
;;(declare (values line empty?)) |
1588 |
|
(declare (type non-negative-fixnum primary)) |
1589 |
|
(with-local-cache-functions (cache) |
1590 |
|
(when (line-reserved-p primary) (setq primary (next-line primary))) |
1591 |
|
(let ((limit (funcall (limit-fn) (nlines))) |
1592 |
|
(wrappedp nil) |
1593 |
|
(lines nil) |
1594 |
|
(p primary) (s primary)) |
1595 |
|
(declare (type non-negative-fixnum p s limit)) |
1596 |
|
(block find-free |
1597 |
|
(loop |
1598 |
|
;; Try to find a free line starting at <s>. <p> is the |
1599 |
|
;; primary line of the entry we are finding a free |
1600 |
|
;; line for, it is used to compute the seperations. |
1601 |
|
(do* ((line s (next-line line)) |
1602 |
|
(nsep (line-separation p s) (1+ nsep))) |
1603 |
|
(()) |
1604 |
|
(declare (type non-negative-fixnum line nsep)) |
1605 |
|
(when (null (line-valid-p line wrappers)) ;If this line is empty or |
1606 |
|
(push line lines) ;invalid, just use it. |
1607 |
|
(return-from find-free)) |
1608 |
|
(when (and wrappedp (>= line primary)) |
1609 |
|
;; have gone all the way around the cache, time to quit |
1610 |
|
(return-from find-free-cache-line (values primary nil))) |
1611 |
|
(let ((osep (line-separation (line-primary line) line))) |
1612 |
|
(when (>= osep limit) |
1613 |
|
(return-from find-free-cache-line (values primary nil))) |
1614 |
|
(when (cond ((= nsep limit) t) |
1615 |
|
((= nsep osep) (zerop (random 2))) |
1616 |
|
((> nsep osep) t) |
1617 |
|
(t nil)) |
1618 |
|
;; See if we can displace what is in this line so that we |
1619 |
|
;; can use the line. |
1620 |
|
(when (= line (the fixnum (1- (nlines)))) (setq wrappedp t)) |
1621 |
|
(setq p (line-primary line)) |
1622 |
|
(setq s (next-line line)) |
1623 |
|
(push line lines) |
1624 |
|
(return nil))) |
1625 |
|
(when (= line (the fixnum (1- (nlines)))) (setq wrappedp t))))) |
1626 |
|
;; Do all the displacing. |
1627 |
|
(loop |
1628 |
|
(when (null (cdr lines)) (return nil)) |
1629 |
|
(let ((dline (pop lines)) |
1630 |
|
(line (car lines))) |
1631 |
|
(declare (type non-negative-fixnum dline line)) |
1632 |
|
;;Copy from line to dline (dline is known to be free). |
1633 |
|
(let ((from-loc (line-location line)) |
1634 |
|
(to-loc (line-location dline)) |
1635 |
|
(cache-vector (vector))) |
1636 |
|
(declare (type non-negative-fixnum from-loc to-loc) |
1637 |
|
(simple-vector cache-vector)) |
1638 |
|
(modify-cache cache-vector |
1639 |
|
(dotimes (i (line-size)) |
1640 |
|
(setf (cache-vector-ref cache-vector (+ to-loc i)) |
1641 |
|
(cache-vector-ref cache-vector (+ from-loc i))) |
1642 |
|
(setf (cache-vector-ref cache-vector (+ from-loc i)) |
1643 |
|
nil)))))) |
1644 |
|
(values (car lines) t)))) |
1645 |
|
|
1646 |
|
(defun default-limit-fn (nlines) |
1647 |
|
(case nlines |
1648 |
|
((1 2 4) 1) |
1649 |
|
((8 16) 4) |
1650 |
|
(otherwise 6))) |
1651 |
|
|
1652 |
|
(defvar *empty-cache* (make-cache)) ; for defstruct slot initial value forms |
1653 |
|
|
1654 |
|
;;; |
1655 |
|
;;; pre-allocate generic function caches. The hope is that this will put |
1656 |
|
;;; them nicely together in memory, and that that may be a win. Of course |
1657 |
|
;;; the first gc copy will probably blow that out, this really wants to be |
1658 |
|
;;; wrapped in something that declares the area static. |
1659 |
|
;;; |
1660 |
|
;;; This preallocation only creates about 25% more caches than PCL itself |
1661 |
|
;;; uses. Some ports may want to preallocate some more of these. |
1662 |
|
;;; |
1663 |
|
(eval-when (load) |
1664 |
|
(dolist (n-size '((1 513)(3 257)(3 129)(14 128)(6 65)(2 64)(7 33)(16 32) |
1665 |
|
(16 17)(32 16)(64 9)(64 8)(6 5)(128 4)(35 2))) |
1666 |
|
(let ((n (car n-size)) |
1667 |
|
(size (cadr n-size))) |
1668 |
|
(mapcar #'free-cache-vector |
1669 |
|
(mapcar #'get-cache-vector |
1670 |
|
(make-list n :initial-element size)))))) |
1671 |
|
|
1672 |
|
(defun caches-to-allocate () |
1673 |
|
(sort (let ((l nil)) |
1674 |
|
(maphash #'(lambda (size entry) |
1675 |
|
(push (list (car entry) size) l)) |
1676 |
|
pcl::*free-caches*) |
1677 |
|
l) |
1678 |
|
#'> :key #'cadr)) |
1679 |
|
|
1680 |
|
|