1.0.9.47: VALID-WRAPPER-OF
[sbcl/simd.git] / src / pcl / wrapper.lisp
blobc204e4f8b21b1b518db7debf000e28a46d7d2a4e
1 ;;;; Bits and pieces of the wrapper machninery. This used to live in cache.lisp,
2 ;;;; but doesn't really logically belong there.
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
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.
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.
27 (in-package "SB-PCL")
29 (defmacro wrapper-class (wrapper)
30 `(classoid-pcl-class (layout-classoid ,wrapper)))
31 (defmacro wrapper-no-of-instance-slots (wrapper)
32 `(layout-length ,wrapper))
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))
48 (make-wrapper-internal
49 :length length
50 :classoid (make-standard-classoid
51 :name name :pcl-class class))))))
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)
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))
85 (let ((name (slot-value class 'name)))
86 (make-standard-classoid :pcl-class class
87 :name (and (symbolp name) name))))))
89 (bug "Got to T branch in ~S" 'make-wrapper))))))
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))))
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)))))
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.
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.
118 (declaim (inline invalid-wrapper-p))
119 (defun invalid-wrapper-p (wrapper)
120 (not (null (layout-invalid wrapper))))
122 ;;; We only use this inside INVALIDATE-WRAPPER.
123 (defvar *previous-nwrappers* (make-hash-table))
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.
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))
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 (setf (layout-clos-hash owrapper) 0)
147 ;; FIXME: We could save a whopping cons by using (STATE . WRAPPER)
148 ;; instead
149 (push (setf (layout-invalid owrapper) (list state nwrapper))
150 new-previous)
152 (remhash owrapper *previous-nwrappers*)
153 (setf (gethash nwrapper *previous-nwrappers*) new-previous)))
155 ;;; FIXME: This is not a good name: part of the constract here is that
156 ;;; we return the valid wrapper, which is not obvious from the name
157 ;;; (or the names of our callees.)
158 (defun check-wrapper-validity (instance)
159 (let* ((owrapper (wrapper-of instance))
160 (state (layout-invalid owrapper)))
161 (aver (not (eq state :uninitialized)))
162 (cond ((not state)
163 owrapper)
164 ((not (layout-for-std-class-p owrapper))
165 ;; Obsolete structure trap.
166 (obsolete-instance-trap owrapper nil instance))
167 ((eq t state)
168 ;; FIXME: I can't help thinking that, while this does cure
169 ;; the symptoms observed from some class redefinitions,
170 ;; this isn't the place to be doing this flushing.
171 ;; Nevertheless... -- CSR, 2003-05-31
173 ;; CMUCL comment:
174 ;; We assume in this case, that the :INVALID is from a
175 ;; previous call to REGISTER-LAYOUT for a superclass of
176 ;; INSTANCE's class. See also the comment above
177 ;; FORCE-CACHE-FLUSHES. Paul Dietz has test cases for this.
178 (force-cache-flushes (class-of instance))
179 (check-wrapper-validity instance))
180 ((consp state)
181 (ecase (car state)
182 (:flush
183 (flush-cache-trap owrapper (cadr state) instance))
184 (:obsolete
185 (obsolete-instance-trap owrapper (cadr state) instance))))
187 (bug "Invalid LAYOUT-INVALID: ~S" state)))))
189 (declaim (inline check-obsolete-instance))
190 (defun check-obsolete-instance (instance)
191 (when (invalid-wrapper-p (layout-of instance))
192 (check-wrapper-validity instance)))
194 (defun valid-wrapper-of (instance)
195 (let ((wrapper (wrapper-of instance)))
196 (if (invalid-wrapper-p wrapper)
197 (check-wrapper-validity instance)
198 wrapper)))
200 ;;; NIL: means nothing so far, no actual arg info has NILs in the
201 ;;; metatype.
203 ;;; CLASS: seen all sorts of metaclasses (specifically, more than one
204 ;;; of the next 5 values) or else have seen something which doesn't
205 ;;; fall into a single category (SLOT-INSTANCE, FORWARD). Also used
206 ;;; when seen a non-standard specializer.
208 ;;; T: means everything so far is the class T.
210 ;;; The above three are the really important ones, as they affect how
211 ;;; discriminating functions are computed. There are some other
212 ;;; possible metatypes:
214 ;;; * STANDARD-INSTANCE: seen only standard classes
215 ;;; * BUILT-IN-INSTANCE: seen only built in classes
216 ;;; * STRUCTURE-INSTANCE: seen only structure classes
217 ;;; * CONDITION-INSTANCE: seen only condition classes
219 ;;; but these are largely unexploited as of 2007-05-10. The
220 ;;; distinction between STANDARD-INSTANCE and the others is used in
221 ;;; emitting wrapper/slot-getting code in accessor discriminating
222 ;;; functions (see EMIT-FETCH-WRAPPER and EMIT-READER/WRITER); it is
223 ;;; possible that there was an intention to use these metatypes to
224 ;;; specialize cache implementation or discrimination nets, but this
225 ;;; has not occurred as yet.
226 (defun raise-metatype (metatype new-specializer)
227 (let ((slot (find-class 'slot-class))
228 (standard (find-class 'standard-class))
229 (fsc (find-class 'funcallable-standard-class))
230 (condition (find-class 'condition-class))
231 (structure (find-class 'structure-class))
232 (built-in (find-class 'built-in-class))
233 (frc (find-class 'forward-referenced-class)))
234 (flet ((specializer->metatype (x)
235 (let* ((specializer-class (if (eq *boot-state* 'complete)
236 (specializer-class-or-nil x)
238 (meta-specializer (class-of specializer-class)))
239 (cond
240 ((eq x *the-class-t*) t)
241 ((not specializer-class) 'non-standard)
242 ((*subtypep meta-specializer standard) 'standard-instance)
243 ((*subtypep meta-specializer fsc) 'standard-instance)
244 ((*subtypep meta-specializer condition) 'condition-instance)
245 ((*subtypep meta-specializer structure) 'structure-instance)
246 ((*subtypep meta-specializer built-in) 'built-in-instance)
247 ((*subtypep meta-specializer slot) 'slot-instance)
248 ((*subtypep meta-specializer frc) 'forward)
249 (t (error "~@<PCL cannot handle the specializer ~S ~
250 (meta-specializer ~S).~@:>"
251 new-specializer meta-specializer))))))
252 ;; We implement the following table. The notation is
253 ;; that X and Y are distinct meta specializer names.
255 ;; NIL <anything> ===> <anything>
256 ;; X X ===> X
257 ;; X Y ===> CLASS
258 (let ((new-metatype (specializer->metatype new-specializer)))
259 (cond ((eq new-metatype 'slot-instance) 'class)
260 ((eq new-metatype 'forward) 'class)
261 ((eq new-metatype 'non-standard) 'class)
262 ((null metatype) new-metatype)
263 ((eq metatype new-metatype) new-metatype)
264 (t 'class))))))
266 (defmacro with-dfun-wrappers ((args metatypes)
267 (dfun-wrappers invalid-wrapper-p
268 &optional wrappers classes types)
269 invalid-arguments-form
270 &body body)
271 `(let* ((args-tail ,args) (,invalid-wrapper-p nil) (invalid-arguments-p nil)
272 (,dfun-wrappers nil) (dfun-wrappers-tail nil)
273 ,@(when wrappers
274 `((wrappers-rev nil) (types-rev nil) (classes-rev nil))))
275 (dolist (mt ,metatypes)
276 (unless args-tail
277 (setq invalid-arguments-p t)
278 (return nil))
279 (let* ((arg (pop args-tail))
280 (wrapper nil)
281 ,@(when wrappers
282 `((class *the-class-t*)
283 (type t))))
284 (unless (eq mt t)
285 (setq wrapper (wrapper-of arg))
286 (when (invalid-wrapper-p wrapper)
287 (setq ,invalid-wrapper-p t)
288 (setq wrapper (check-wrapper-validity arg)))
289 (cond ((null ,dfun-wrappers)
290 (setq ,dfun-wrappers wrapper))
291 ((not (consp ,dfun-wrappers))
292 (setq dfun-wrappers-tail (list wrapper))
293 (setq ,dfun-wrappers (cons ,dfun-wrappers dfun-wrappers-tail)))
295 (let ((new-dfun-wrappers-tail (list wrapper)))
296 (setf (cdr dfun-wrappers-tail) new-dfun-wrappers-tail)
297 (setf dfun-wrappers-tail new-dfun-wrappers-tail))))
298 ,@(when wrappers
299 `((setq class (wrapper-class* wrapper))
300 (setq type `(class-eq ,class)))))
301 ,@(when wrappers
302 `((push wrapper wrappers-rev)
303 (push class classes-rev)
304 (push type types-rev)))))
305 (if invalid-arguments-p
306 ,invalid-arguments-form
307 (let* (,@(when wrappers
308 `((,wrappers (nreverse wrappers-rev))
309 (,classes (nreverse classes-rev))
310 (,types (mapcar (lambda (class)
311 `(class-eq ,class))
312 ,classes)))))
313 ,@body))))