1.0.5.50: some compare-and-swap changes
[sbcl.git] / src / pcl / wrapper.lisp
1 ;;;; Bits and pieces of the wrapper machninery. This used to live in cache.lisp,
2 ;;;; but doesn't really logically belong there.
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6
7 ;;;; This software is derived from software originally released by Xerox
8 ;;;; Corporation. Copyright and release statements follow. Later modifications
9 ;;;; to the software are in the public domain and are provided with
10 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
11 ;;;; information.
12
13 ;;;; copyright information from original PCL sources:
14 ;;;;
15 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
16 ;;;; All rights reserved.
17 ;;;;
18 ;;;; Use and copying of this software and preparation of derivative works based
19 ;;;; upon this software are permitted. Any distribution of this software or
20 ;;;; derivative works must comply with all applicable United States export
21 ;;;; control laws.
22 ;;;;
23 ;;;; This software is made available AS IS, and Xerox Corporation makes no
24 ;;;; warranty about the software, its performance or its conformity to any
25 ;;;; specification.
26
27 (in-package "SB-PCL")
28
29 (defmacro wrapper-class (wrapper)
30   `(classoid-pcl-class (layout-classoid ,wrapper)))
31 (defmacro wrapper-no-of-instance-slots (wrapper)
32   `(layout-length ,wrapper))
33
34 ;;; This is called in BRAID when we are making wrappers for classes
35 ;;; whose slots are not initialized yet, and which may be built-in
36 ;;; classes. We pass in the class name in addition to the class.
37 (defun boot-make-wrapper (length name &optional class)
38   (let ((found (find-classoid name nil)))
39     (cond
40      (found
41       (unless (classoid-pcl-class found)
42         (setf (classoid-pcl-class found) class))
43       (aver (eq (classoid-pcl-class found) class))
44       (let ((layout (classoid-layout found)))
45         (aver layout)
46         layout))
47      (t
48       (make-wrapper-internal
49        :length length
50        :classoid (make-standard-classoid
51                   :name name :pcl-class class))))))
52
53 ;;; The following variable may be set to a STANDARD-CLASS that has
54 ;;; already been created by the lisp code and which is to be redefined
55 ;;; by PCL. This allows STANDARD-CLASSes to be defined and used for
56 ;;; type testing and dispatch before PCL is loaded.
57 (defvar *pcl-class-boot* nil)
58
59 ;;; In SBCL, as in CMU CL, the layouts (a.k.a wrappers) for built-in
60 ;;; and structure classes already exist when PCL is initialized, so we
61 ;;; don't necessarily always make a wrapper. Also, we help maintain
62 ;;; the mapping between CL:CLASS and SB-KERNEL:CLASSOID objects.
63 (defun make-wrapper (length class)
64   (cond
65     ((or (typep class 'std-class)
66          (typep class 'forward-referenced-class))
67      (make-wrapper-internal
68       :length length
69       :classoid
70       (let ((owrap (class-wrapper class)))
71         (cond (owrap
72                (layout-classoid owrap))
73               ((or (*subtypep (class-of class) *the-class-standard-class*)
74                    (*subtypep (class-of class) *the-class-funcallable-standard-class*)
75                    (typep class 'forward-referenced-class))
76                (cond ((and *pcl-class-boot*
77                            (eq (slot-value class 'name) *pcl-class-boot*))
78                       (let ((found (find-classoid
79                                     (slot-value class 'name))))
80                         (unless (classoid-pcl-class found)
81                           (setf (classoid-pcl-class found) class))
82                         (aver (eq (classoid-pcl-class found) class))
83                         found))
84                      (t
85                       (let ((name (slot-value class 'name)))
86                         (make-standard-classoid :pcl-class class
87                                                 :name (and (symbolp name) name))))))
88               (t
89                (bug "Got to T branch in ~S" 'make-wrapper))))))
90     (t
91      (let* ((found (find-classoid (slot-value class 'name)))
92             (layout (classoid-layout found)))
93        (unless (classoid-pcl-class found)
94          (setf (classoid-pcl-class found) class))
95        (aver (eq (classoid-pcl-class found) class))
96        (aver layout)
97        layout))))
98
99 (declaim (inline wrapper-class*))
100 (defun wrapper-class* (wrapper)
101   (or (wrapper-class wrapper)
102       (ensure-non-standard-class
103        (classoid-name (layout-classoid wrapper)))))
104
105 ;;; The wrapper cache machinery provides general mechanism for
106 ;;; trapping on the next access to any instance of a given class. This
107 ;;; mechanism is used to implement the updating of instances when the
108 ;;; class is redefined (MAKE-INSTANCES-OBSOLETE). The same mechanism
109 ;;; is also used to update generic function caches when there is a
110 ;;; change to the superclasses of a class.
111 ;;;
112 ;;; Basically, a given wrapper can be valid or invalid. If it is
113 ;;; invalid, it means that any attempt to do a wrapper cache lookup
114 ;;; using the wrapper should trap. Also, methods on
115 ;;; SLOT-VALUE-USING-CLASS check the wrapper validity as well. This is
116 ;;; done by calling CHECK-WRAPPER-VALIDITY.
117
118 (declaim (inline invalid-wrapper-p))
119 (defun invalid-wrapper-p (wrapper)
120   (not (null (layout-invalid wrapper))))
121
122 ;;; We only use this inside INVALIDATE-WRAPPER.
123 (defvar *previous-nwrappers* (make-hash-table))
124
125 ;;; We always call this inside WITH-PCL-LOCK.
126 (defun invalidate-wrapper (owrapper state nwrapper)
127   (aver (member state '(:flush :obsolete) :test #'eq))
128   (let ((new-previous ()))
129     ;; First off, a previous call to INVALIDATE-WRAPPER may have
130     ;; recorded OWRAPPER as an NWRAPPER to update to. Since OWRAPPER
131     ;; is about to be invalid, it no longer makes sense to update to
132     ;; it.
133     ;;
134     ;; We go back and change the previously invalidated wrappers so
135     ;; that they will now update directly to NWRAPPER. This
136     ;; corresponds to a kind of transitivity of wrapper updates.
137     (dolist (previous (gethash owrapper *previous-nwrappers*))
138       (when (eq state :obsolete)
139         (setf (car previous) :obsolete))
140       (setf (cadr previous) nwrapper)
141       (push previous new-previous))
142
143     ;; FIXME: We are here inside PCL lock, but might someone be
144     ;; accessing the wrapper at the same time from outside the lock?
145     ;; Can it matter that they get 0 from one slot and a valid value
146     ;; from another?
147     (dotimes (i layout-clos-hash-length)
148       (setf (layout-clos-hash owrapper i) 0))
149
150     ;; FIXME: We could save a whopping cons by using (STATE . WRAPPER)
151     ;; instead
152     (push (setf (layout-invalid owrapper) (list state nwrapper))
153           new-previous)
154
155     (remhash owrapper *previous-nwrappers*)
156     (setf (gethash nwrapper *previous-nwrappers*) new-previous)))
157
158 (defun check-wrapper-validity (instance)
159   (let* ((owrapper (wrapper-of instance))
160          (state (layout-invalid owrapper)))
161     (aver (not (eq state :uninitialized)))
162     (etypecase state
163       (null owrapper)
164       ;; FIXME: I can't help thinking that, while this does cure the
165       ;; symptoms observed from some class redefinitions, this isn't
166       ;; the place to be doing this flushing.  Nevertheless...  --
167       ;; CSR, 2003-05-31
168       ;;
169       ;; CMUCL comment:
170       ;;    We assume in this case, that the :INVALID is from a
171       ;;    previous call to REGISTER-LAYOUT for a superclass of
172       ;;    INSTANCE's class.  See also the comment above
173       ;;    FORCE-CACHE-FLUSHES.  Paul Dietz has test cases for this.
174       ((member t)
175        (force-cache-flushes (class-of instance))
176        (check-wrapper-validity instance))
177       (cons
178        (ecase (car state)
179          (:flush
180           (flush-cache-trap owrapper (cadr state) instance))
181          (:obsolete
182           (obsolete-instance-trap owrapper (cadr state) instance)))))))
183
184 (declaim (inline check-obsolete-instance))
185 (defun check-obsolete-instance (instance)
186   (when (invalid-wrapper-p (layout-of instance))
187     (check-wrapper-validity instance)))
188 \f
189 ;;;  NIL: means nothing so far, no actual arg info has NILs in the
190 ;;;  metatype.
191 ;;;
192 ;;;  CLASS: seen all sorts of metaclasses (specifically, more than one
193 ;;;  of the next 5 values) or else have seen something which doesn't
194 ;;;  fall into a single category (SLOT-INSTANCE, FORWARD).  Also used
195 ;;;  when seen a non-standard specializer.
196 ;;;
197 ;;;  T: means everything so far is the class T.
198 ;;;
199 ;;;  The above three are the really important ones, as they affect how
200 ;;;  discriminating functions are computed.  There are some other
201 ;;;  possible metatypes:
202 ;;;
203 ;;;  * STANDARD-INSTANCE: seen only standard classes
204 ;;;  * BUILT-IN-INSTANCE: seen only built in classes
205 ;;;  * STRUCTURE-INSTANCE: seen only structure classes
206 ;;;  * CONDITION-INSTANCE: seen only condition classes
207 ;;;
208 ;;;  but these are largely unexploited as of 2007-05-10.  The
209 ;;;  distinction between STANDARD-INSTANCE and the others is used in
210 ;;;  emitting wrapper/slot-getting code in accessor discriminating
211 ;;;  functions (see EMIT-FETCH-WRAPPER and EMIT-READER/WRITER); it is
212 ;;;  possible that there was an intention to use these metatypes to
213 ;;;  specialize cache implementation or discrimination nets, but this
214 ;;;  has not occurred as yet.
215 (defun raise-metatype (metatype new-specializer)
216   (let ((slot      (find-class 'slot-class))
217         (standard  (find-class 'standard-class))
218         (fsc       (find-class 'funcallable-standard-class))
219         (condition (find-class 'condition-class))
220         (structure (find-class 'structure-class))
221         (built-in  (find-class 'built-in-class))
222         (frc       (find-class 'forward-referenced-class)))
223     (flet ((specializer->metatype (x)
224              (let* ((specializer-class (if (eq *boot-state* 'complete)
225                                            (specializer-class-or-nil x)
226                                            x))
227                    (meta-specializer (class-of specializer-class)))
228                (cond
229                  ((eq x *the-class-t*) t)
230                  ((not specializer-class) 'non-standard)
231                  ((*subtypep meta-specializer standard) 'standard-instance)
232                  ((*subtypep meta-specializer fsc) 'standard-instance)
233                  ((*subtypep meta-specializer condition) 'condition-instance)
234                  ((*subtypep meta-specializer structure) 'structure-instance)
235                  ((*subtypep meta-specializer built-in) 'built-in-instance)
236                  ((*subtypep meta-specializer slot) 'slot-instance)
237                  ((*subtypep meta-specializer frc) 'forward)
238                  (t (error "~@<PCL cannot handle the specializer ~S ~
239                             (meta-specializer ~S).~@:>"
240                            new-specializer meta-specializer))))))
241       ;; We implement the following table. The notation is
242       ;; that X and Y are distinct meta specializer names.
243       ;;
244       ;;    NIL    <anything>    ===>  <anything>
245       ;;    X      X             ===>  X
246       ;;    X      Y             ===>  CLASS
247       (let ((new-metatype (specializer->metatype new-specializer)))
248         (cond ((eq new-metatype 'slot-instance) 'class)
249               ((eq new-metatype 'forward) 'class)
250               ((eq new-metatype 'non-standard) 'class)
251               ((null metatype) new-metatype)
252               ((eq metatype new-metatype) new-metatype)
253               (t 'class))))))
254
255 (defmacro with-dfun-wrappers ((args metatypes)
256                               (dfun-wrappers invalid-wrapper-p
257                                              &optional wrappers classes types)
258                               invalid-arguments-form
259                               &body body)
260   `(let* ((args-tail ,args) (,invalid-wrapper-p nil) (invalid-arguments-p nil)
261           (,dfun-wrappers nil) (dfun-wrappers-tail nil)
262           ,@(when wrappers
263               `((wrappers-rev nil) (types-rev nil) (classes-rev nil))))
264      (dolist (mt ,metatypes)
265        (unless args-tail
266          (setq invalid-arguments-p t)
267          (return nil))
268        (let* ((arg (pop args-tail))
269               (wrapper nil)
270               ,@(when wrappers
271                   `((class *the-class-t*)
272                     (type t))))
273          (unless (eq mt t)
274            (setq wrapper (wrapper-of arg))
275            (when (invalid-wrapper-p wrapper)
276              (setq ,invalid-wrapper-p t)
277              (setq wrapper (check-wrapper-validity arg)))
278            (cond ((null ,dfun-wrappers)
279                   (setq ,dfun-wrappers wrapper))
280                  ((not (consp ,dfun-wrappers))
281                   (setq dfun-wrappers-tail (list wrapper))
282                   (setq ,dfun-wrappers (cons ,dfun-wrappers dfun-wrappers-tail)))
283                  (t
284                   (let ((new-dfun-wrappers-tail (list wrapper)))
285                     (setf (cdr dfun-wrappers-tail) new-dfun-wrappers-tail)
286                     (setf dfun-wrappers-tail new-dfun-wrappers-tail))))
287            ,@(when wrappers
288                `((setq class (wrapper-class* wrapper))
289                  (setq type `(class-eq ,class)))))
290          ,@(when wrappers
291              `((push wrapper wrappers-rev)
292                (push class classes-rev)
293                (push type types-rev)))))
294      (if invalid-arguments-p
295          ,invalid-arguments-form
296          (let* (,@(when wrappers
297                     `((,wrappers (nreverse wrappers-rev))
298                       (,classes (nreverse classes-rev))
299                       (,types (mapcar (lambda (class)
300                                         `(class-eq ,class))
301                                       ,classes)))))
302            ,@body))))