Declare COERCE and two helpers as EXPLICIT-CHECK.
[sbcl.git] / src / pcl / wrapper.lisp
bloba4d943c45ebed4eddb33e0cca6b2b6e637f2cb24
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 (declaim (inline make-wrapper-internal))
35 (defun make-wrapper-internal (&key length classoid)
36 (make-layout :length length :classoid classoid :invalid nil
37 :%for-std-class-b 1))
39 ;;; This is called in BRAID when we are making wrappers for classes
40 ;;; whose slots are not initialized yet, and which may be built-in
41 ;;; classes. We pass in the class name in addition to the class.
42 (defun !boot-make-wrapper (length name &optional class)
43 (let ((found (find-classoid name nil)))
44 (cond
45 (found
46 (unless (classoid-pcl-class found)
47 (setf (classoid-pcl-class found) class))
48 (aver (eq (classoid-pcl-class found) class))
49 (let ((layout (classoid-layout found)))
50 (aver layout)
51 layout))
53 (make-wrapper-internal
54 :length length
55 :classoid (make-standard-classoid
56 :name name :pcl-class class))))))
58 ;;; The following variable may be set to a STANDARD-CLASS that has
59 ;;; already been created by the lisp code and which is to be redefined
60 ;;; by PCL. This allows STANDARD-CLASSes to be defined and used for
61 ;;; type testing and dispatch before PCL is loaded.
62 (defvar *pcl-class-boot* nil)
64 ;;; In SBCL, as in CMU CL, the layouts (a.k.a wrappers) for built-in
65 ;;; and structure classes already exist when PCL is initialized, so we
66 ;;; don't necessarily always make a wrapper. Also, we help maintain
67 ;;; the mapping between CL:CLASS and SB-KERNEL:CLASSOID objects.
68 (defun make-wrapper (length class)
69 (cond
70 ((or (typep class 'std-class)
71 (typep class 'forward-referenced-class))
72 (make-wrapper-internal
73 :length length
74 :classoid
75 (let ((owrap (class-wrapper class)))
76 (cond (owrap
77 (layout-classoid owrap))
78 ((or (*subtypep (class-of class) *the-class-standard-class*)
79 (*subtypep (class-of class) *the-class-funcallable-standard-class*)
80 (typep class 'forward-referenced-class))
81 (cond ((and *pcl-class-boot*
82 (eq (slot-value class 'name) *pcl-class-boot*))
83 (let ((found (find-classoid
84 (slot-value class 'name))))
85 (unless (classoid-pcl-class found)
86 (setf (classoid-pcl-class found) class))
87 (aver (eq (classoid-pcl-class found) class))
88 found))
90 (let ((name (slot-value class 'name)))
91 (make-standard-classoid :pcl-class class
92 :name (and (symbolp name) name))))))
94 (bug "Got to T branch in ~S" 'make-wrapper))))))
96 (let* ((found (find-classoid (slot-value class 'name)))
97 (layout (classoid-layout found)))
98 (unless (classoid-pcl-class found)
99 (setf (classoid-pcl-class found) class))
100 (aver (eq (classoid-pcl-class found) class))
101 (aver layout)
102 layout))))
104 (declaim (inline wrapper-class*))
105 (defun wrapper-class* (wrapper)
106 (or (wrapper-class wrapper)
107 ;; FIXME: this branch seems unreachable.
108 ;; It would be nice to eliminate WRAPPER-CLASS* if we can show that it
109 ;; is only a holdover from an earlier way of bootstrapping that resulted
110 ;; in the temporary absence of a PCL-CLASS for some non-standard-class.
111 ;; Certainly no test gets here [changing it to (BUG "got here") worked].
112 ;; Note however that
113 ;; (CLASSOID-PCL-CLASS (FIND-CLASSOID 'STANDARD-INSTANCE)) => NIL
114 ;; which can be resolved by just ensuring one time that it has a CLASS.
115 ;; And nothing else seems to be problematic.
116 (let ((classoid (layout-classoid wrapper)))
117 (ensure-non-standard-class
118 (classoid-name classoid)
119 classoid))))
121 ;;; The wrapper cache machinery provides general mechanism for
122 ;;; trapping on the next access to any instance of a given class. This
123 ;;; mechanism is used to implement the updating of instances when the
124 ;;; class is redefined (MAKE-INSTANCES-OBSOLETE). The same mechanism
125 ;;; is also used to update generic function caches when there is a
126 ;;; change to the superclasses of a class.
128 ;;; Basically, a given wrapper can be valid or invalid. If it is
129 ;;; invalid, it means that any attempt to do a wrapper cache lookup
130 ;;; using the wrapper should trap. Also, methods on
131 ;;; SLOT-VALUE-USING-CLASS check the wrapper validity as well. This is
132 ;;; done by calling CHECK-WRAPPER-VALIDITY.
134 (declaim (inline invalid-wrapper-p))
135 (defun invalid-wrapper-p (wrapper)
136 (not (null (layout-invalid wrapper))))
138 ;;; We only use this inside INVALIDATE-WRAPPER.
139 (defvar *previous-nwrappers* (make-hash-table))
141 (defun %invalidate-wrapper (owrapper state nwrapper)
142 (aver (member state '(:flush :obsolete) :test #'eq))
143 (let ((new-previous ()))
144 ;; First off, a previous call to INVALIDATE-WRAPPER may have
145 ;; recorded OWRAPPER as an NWRAPPER to update to. Since OWRAPPER
146 ;; is about to be invalid, it no longer makes sense to update to
147 ;; it.
149 ;; We go back and change the previously invalidated wrappers so
150 ;; that they will now update directly to NWRAPPER. This
151 ;; corresponds to a kind of transitivity of wrapper updates.
152 (dolist (previous (gethash owrapper *previous-nwrappers*))
153 (when (eq state :obsolete)
154 (setf (car previous) :obsolete))
155 (setf (cadr previous) nwrapper)
156 (push previous new-previous))
158 ;; FIXME: We are here inside PCL lock, but might someone be
159 ;; accessing the wrapper at the same time from outside the lock?
160 (setf (layout-clos-hash owrapper) 0)
162 ;; FIXME: We could save a whopping cons by using (STATE . WRAPPER)
163 ;; instead
164 (push (setf (layout-invalid owrapper) (list state nwrapper))
165 new-previous)
167 (remhash owrapper *previous-nwrappers*)
168 (setf (gethash nwrapper *previous-nwrappers*) new-previous)))
170 ;;; FIXME: This is not a good name: part of the contract here is that
171 ;;; we return the valid wrapper, which is not obvious from the name
172 ;;; (or the names of our callees.)
173 (defun check-wrapper-validity (instance)
174 (with-world-lock ()
175 (let* ((owrapper (layout-of instance))
176 (state (layout-invalid owrapper)))
177 (aver (not (eq state :uninitialized)))
178 (cond ((not state)
179 owrapper)
180 ((not (layout-for-std-class-p owrapper))
181 ;; Obsolete structure trap.
182 (%obsolete-instance-trap owrapper nil instance))
183 ((eq t state)
184 ;; FIXME: I can't help thinking that, while this does cure
185 ;; the symptoms observed from some class redefinitions,
186 ;; this isn't the place to be doing this flushing.
187 ;; Nevertheless... -- CSR, 2003-05-31
189 ;; CMUCL comment:
190 ;; We assume in this case, that the :INVALID is from a
191 ;; previous call to REGISTER-LAYOUT for a superclass of
192 ;; INSTANCE's class. See also the comment above
193 ;; FORCE-CACHE-FLUSHES. Paul Dietz has test cases for this.
194 (let ((class (wrapper-class* owrapper)))
195 (%force-cache-flushes class)
196 ;; KLUDGE: avoid an infinite recursion, it's still better to
197 ;; bail out with an error for server softwares. see FIXME above.
198 ;; details: http://thread.gmane.org/gmane.lisp.steel-bank.devel/10175
200 ;; Error message here is trying to figure out a bit more about the
201 ;; situation, since we don't have anything approaching a test-case
202 ;; for the bug.
203 (let ((new-state (layout-invalid (layout-of instance))))
204 (when (eq new-state t)
205 (cerror "Nevermind and recurse." 'bug
206 :format-control "~@<~4IProblem forcing cache flushes. Please report ~
207 to sbcl-devel.~
208 ~% Owrapper: ~S~
209 ~% Wrapper-of: ~S~
210 ~% Class-wrapper: ~S~%~:@>"
211 :format-arguments (mapcar (lambda (x)
212 (cons x (layout-invalid x)))
213 (list owrapper
214 (layout-of instance)
215 (class-wrapper class)))))))
216 (check-wrapper-validity instance))
217 ((consp state)
218 (ecase (car state)
219 (:flush
220 (let ((new (cadr state)))
221 (cond ((std-instance-p instance)
222 (setf (std-instance-wrapper instance) new))
223 ((fsc-instance-p instance)
224 (setf (fsc-instance-wrapper instance) new))
226 (bug "unrecognized instance type")))))
227 (:obsolete
228 (%obsolete-instance-trap owrapper (cadr state) instance))))
230 (bug "Invalid LAYOUT-INVALID: ~S" state))))))
232 (declaim (inline check-obsolete-instance))
233 (defun check-obsolete-instance (instance)
234 (when (invalid-wrapper-p (layout-of instance))
235 (check-wrapper-validity instance)))
237 (defun valid-wrapper-of (instance)
238 (let ((wrapper (layout-of instance)))
239 (if (invalid-wrapper-p wrapper)
240 (check-wrapper-validity instance)
241 wrapper)))
243 ;;; NIL: means nothing so far, no actual arg info has NILs in the
244 ;;; metatype.
246 ;;; CLASS: seen all sorts of metaclasses (specifically, more than one
247 ;;; of the next 5 values) or else have seen something which doesn't
248 ;;; fall into a single category (SLOT-INSTANCE, FORWARD). Also used
249 ;;; when seen a non-standard specializer.
251 ;;; T: means everything so far is the class T.
253 ;;; The above three are the really important ones, as they affect how
254 ;;; discriminating functions are computed. There are some other
255 ;;; possible metatypes:
257 ;;; * STANDARD-INSTANCE: seen only standard classes
258 ;;; * BUILT-IN-INSTANCE: seen only built in classes
259 ;;; * STRUCTURE-INSTANCE: seen only structure classes
260 ;;; * CONDITION-INSTANCE: seen only condition classes
262 ;;; but these are largely unexploited as of 2007-05-10. The
263 ;;; distinction between STANDARD-INSTANCE and the others is used in
264 ;;; emitting wrapper/slot-getting code in accessor discriminating
265 ;;; functions (see EMIT-FETCH-WRAPPER and EMIT-READER/WRITER); it is
266 ;;; possible that there was an intention to use these metatypes to
267 ;;; specialize cache implementation or discrimination nets, but this
268 ;;; has not occurred as yet.
269 (defun raise-metatype (metatype new-specializer)
270 (let ((slot *the-class-slot-class*)
271 (standard *the-class-standard-class*)
272 (fsc *the-class-funcallable-standard-class*)
273 (condition *the-class-condition-class*)
274 (structure *the-class-structure-class*)
275 (system *the-class-system-class*)
276 (frc *the-class-forward-referenced-class*))
277 (flet ((specializer->metatype (x)
278 (let* ((specializer-class (if (eq **boot-state** 'complete)
279 (specializer-class-or-nil x)
281 (meta-specializer (class-of specializer-class)))
282 (cond
283 ((eq x *the-class-t*) t)
284 ((not specializer-class) 'non-standard)
285 ((*subtypep meta-specializer standard) 'standard-instance)
286 ((*subtypep meta-specializer fsc) 'standard-instance)
287 ((*subtypep meta-specializer condition) 'condition-instance)
288 ((*subtypep meta-specializer structure) 'structure-instance)
289 ((*subtypep meta-specializer system) 'system-instance)
290 ((*subtypep meta-specializer slot) 'slot-instance)
291 ((*subtypep meta-specializer frc) 'forward)
292 (t (error "~@<PCL cannot handle the specializer ~S ~
293 (meta-specializer ~S).~@:>"
294 new-specializer meta-specializer))))))
295 ;; We implement the following table. The notation is
296 ;; that X and Y are distinct meta specializer names.
298 ;; NIL <anything> ===> <anything>
299 ;; X X ===> X
300 ;; X Y ===> CLASS
301 (let ((new-metatype (specializer->metatype new-specializer)))
302 (cond ((eq new-metatype 'slot-instance) 'class)
303 ((eq new-metatype 'forward) 'class)
304 ((eq new-metatype 'non-standard) 'class)
305 ((null metatype) new-metatype)
306 ((eq metatype new-metatype) new-metatype)
307 (t 'class))))))
309 (defmacro with-dfun-wrappers ((args metatypes)
310 (dfun-wrappers invalid-wrapper-p
311 &optional wrappers classes types)
312 invalid-arguments-form
313 &body body)
314 `(let* ((args-tail ,args) (,invalid-wrapper-p nil) (invalid-arguments-p nil)
315 (,dfun-wrappers nil) (dfun-wrappers-tail nil)
316 ,@(when wrappers
317 `((wrappers-rev nil) (types-rev nil) (classes-rev nil))))
318 (dolist (mt ,metatypes)
319 (unless args-tail
320 (setq invalid-arguments-p t)
321 (return nil))
322 (let* ((arg (pop args-tail))
323 (wrapper nil)
324 ,@(when wrappers
325 `((class *the-class-t*)
326 (type t))))
327 (unless (eq mt t)
328 (setq wrapper (layout-of arg))
329 (when (invalid-wrapper-p wrapper)
330 (setq ,invalid-wrapper-p t)
331 (setq wrapper (check-wrapper-validity arg)))
332 (cond ((null ,dfun-wrappers)
333 (setq ,dfun-wrappers wrapper))
334 ((not (consp ,dfun-wrappers))
335 (setq dfun-wrappers-tail (list wrapper))
336 (setq ,dfun-wrappers (cons ,dfun-wrappers dfun-wrappers-tail)))
338 (let ((new-dfun-wrappers-tail (list wrapper)))
339 (setf (cdr dfun-wrappers-tail) new-dfun-wrappers-tail)
340 (setf dfun-wrappers-tail new-dfun-wrappers-tail))))
341 ,@(when wrappers
342 `((setq class (wrapper-class* wrapper))
343 (setq type `(class-eq ,class)))))
344 ,@(when wrappers
345 `((push wrapper wrappers-rev)
346 (push class classes-rev)
347 (push type types-rev)))))
348 (if invalid-arguments-p
349 ,invalid-arguments-form
350 (let* (,@(when wrappers
351 `((,wrappers (nreverse wrappers-rev))
352 (,classes (nreverse classes-rev))
353 (,types (mapcar (lambda (class)
354 `(class-eq ,class))
355 ,classes)))))
356 ,@body))))