/[gcl]/gcl/pcl/gcl_pcl_cache.lisp
ViewVC logotype

Diff of /gcl/pcl/gcl_pcl_cache.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Fri May 6 21:56:56 2005 UTC revision 1.2 by camm, Sat May 7 02:52:30 2005 UTC
# Line 0  Line 1 
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    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26