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
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
13 ;;;; copyright information from original PCL sources:
15 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
16 ;;;; All rights reserved.
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
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
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
)))
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
)))
48 (make-wrapper-internal
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
)
65 ((or (typep class
'std-class
)
66 (typep class
'forward-referenced-class
))
67 (make-wrapper-internal
70 (let ((owrap (class-wrapper class
)))
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
))
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
))
99 (declaim (inline wrapper-class
*))
100 (defun wrapper-class* (wrapper)
101 (or (wrapper-class wrapper
)
102 (let ((classoid (layout-classoid wrapper
)))
103 (ensure-non-standard-class
104 (classoid-name classoid
)
107 ;;; The wrapper cache machinery provides general mechanism for
108 ;;; trapping on the next access to any instance of a given class. This
109 ;;; mechanism is used to implement the updating of instances when the
110 ;;; class is redefined (MAKE-INSTANCES-OBSOLETE). The same mechanism
111 ;;; is also used to update generic function caches when there is a
112 ;;; change to the superclasses of a class.
114 ;;; Basically, a given wrapper can be valid or invalid. If it is
115 ;;; invalid, it means that any attempt to do a wrapper cache lookup
116 ;;; using the wrapper should trap. Also, methods on
117 ;;; SLOT-VALUE-USING-CLASS check the wrapper validity as well. This is
118 ;;; done by calling CHECK-WRAPPER-VALIDITY.
120 (declaim (inline invalid-wrapper-p
))
121 (defun invalid-wrapper-p (wrapper)
122 (not (null (layout-invalid wrapper
))))
124 ;;; We only use this inside INVALIDATE-WRAPPER.
125 (defvar *previous-nwrappers
* (make-hash-table))
127 ;;; We always call this inside WITH-PCL-LOCK.
128 (defun invalidate-wrapper (owrapper state nwrapper
)
129 (aver (member state
'(:flush
:obsolete
) :test
#'eq
))
130 (let ((new-previous ()))
131 ;; First off, a previous call to INVALIDATE-WRAPPER may have
132 ;; recorded OWRAPPER as an NWRAPPER to update to. Since OWRAPPER
133 ;; is about to be invalid, it no longer makes sense to update to
136 ;; We go back and change the previously invalidated wrappers so
137 ;; that they will now update directly to NWRAPPER. This
138 ;; corresponds to a kind of transitivity of wrapper updates.
139 (dolist (previous (gethash owrapper
*previous-nwrappers
*))
140 (when (eq state
:obsolete
)
141 (setf (car previous
) :obsolete
))
142 (setf (cadr previous
) nwrapper
)
143 (push previous new-previous
))
145 ;; FIXME: We are here inside PCL lock, but might someone be
146 ;; accessing the wrapper at the same time from outside the lock?
147 (setf (layout-clos-hash owrapper
) 0)
149 ;; FIXME: We could save a whopping cons by using (STATE . WRAPPER)
151 (push (setf (layout-invalid owrapper
) (list state nwrapper
))
154 (remhash owrapper
*previous-nwrappers
*)
155 (setf (gethash nwrapper
*previous-nwrappers
*) new-previous
)))
157 ;;; FIXME: This is not a good name: part of the constract here is that
158 ;;; we return the valid wrapper, which is not obvious from the name
159 ;;; (or the names of our callees.)
160 (defun check-wrapper-validity (instance)
161 (let* ((owrapper (wrapper-of instance
))
162 (state (layout-invalid owrapper
)))
163 (aver (not (eq state
:uninitialized
)))
166 ((not (layout-for-std-class-p owrapper
))
167 ;; Obsolete structure trap.
168 (obsolete-instance-trap owrapper nil instance
))
170 ;; FIXME: I can't help thinking that, while this does cure
171 ;; the symptoms observed from some class redefinitions,
172 ;; this isn't the place to be doing this flushing.
173 ;; Nevertheless... -- CSR, 2003-05-31
176 ;; We assume in this case, that the :INVALID is from a
177 ;; previous call to REGISTER-LAYOUT for a superclass of
178 ;; INSTANCE's class. See also the comment above
179 ;; FORCE-CACHE-FLUSHES. Paul Dietz has test cases for this.
180 (force-cache-flushes (class-of instance
))
181 ;; KLUDGE avoid an infinite recursion, it's still better to
182 ;; bail out with an AVER for server softwares. see FIXME above.
183 ;; details: http://thread.gmane.org/gmane.lisp.steel-bank.devel/10175
184 (aver (not (eq (layout-invalid (wrapper-of instance
)) t
)))
185 (check-wrapper-validity instance
))
189 (flush-cache-trap owrapper
(cadr state
) instance
))
191 (obsolete-instance-trap owrapper
(cadr state
) instance
))))
193 (bug "Invalid LAYOUT-INVALID: ~S" state
)))))
195 (declaim (inline check-obsolete-instance
))
196 (defun check-obsolete-instance (instance)
197 (when (invalid-wrapper-p (layout-of instance
))
198 (check-wrapper-validity instance
)))
200 (defun valid-wrapper-of (instance)
201 (let ((wrapper (wrapper-of instance
)))
202 (if (invalid-wrapper-p wrapper
)
203 (check-wrapper-validity instance
)
206 ;;; NIL: means nothing so far, no actual arg info has NILs in the
209 ;;; CLASS: seen all sorts of metaclasses (specifically, more than one
210 ;;; of the next 5 values) or else have seen something which doesn't
211 ;;; fall into a single category (SLOT-INSTANCE, FORWARD). Also used
212 ;;; when seen a non-standard specializer.
214 ;;; T: means everything so far is the class T.
216 ;;; The above three are the really important ones, as they affect how
217 ;;; discriminating functions are computed. There are some other
218 ;;; possible metatypes:
220 ;;; * STANDARD-INSTANCE: seen only standard classes
221 ;;; * BUILT-IN-INSTANCE: seen only built in classes
222 ;;; * STRUCTURE-INSTANCE: seen only structure classes
223 ;;; * CONDITION-INSTANCE: seen only condition classes
225 ;;; but these are largely unexploited as of 2007-05-10. The
226 ;;; distinction between STANDARD-INSTANCE and the others is used in
227 ;;; emitting wrapper/slot-getting code in accessor discriminating
228 ;;; functions (see EMIT-FETCH-WRAPPER and EMIT-READER/WRITER); it is
229 ;;; possible that there was an intention to use these metatypes to
230 ;;; specialize cache implementation or discrimination nets, but this
231 ;;; has not occurred as yet.
232 (defun raise-metatype (metatype new-specializer
)
233 (let ((slot (find-class 'slot-class
))
234 (standard (find-class 'standard-class
))
235 (fsc (find-class 'funcallable-standard-class
))
236 (condition (find-class 'condition-class
))
237 (structure (find-class 'structure-class
))
238 (built-in (find-class 'built-in-class
))
239 (frc (find-class 'forward-referenced-class
)))
240 (flet ((specializer->metatype
(x)
241 (let* ((specializer-class (if (eq *boot-state
* 'complete
)
242 (specializer-class-or-nil x
)
244 (meta-specializer (class-of specializer-class
)))
246 ((eq x
*the-class-t
*) t
)
247 ((not specializer-class
) 'non-standard
)
248 ((*subtypep meta-specializer standard
) 'standard-instance
)
249 ((*subtypep meta-specializer fsc
) 'standard-instance
)
250 ((*subtypep meta-specializer condition
) 'condition-instance
)
251 ((*subtypep meta-specializer structure
) 'structure-instance
)
252 ((*subtypep meta-specializer built-in
) 'built-in-instance
)
253 ((*subtypep meta-specializer slot
) 'slot-instance
)
254 ((*subtypep meta-specializer frc
) 'forward
)
255 (t (error "~@<PCL cannot handle the specializer ~S ~
256 (meta-specializer ~S).~@:>"
257 new-specializer meta-specializer
))))))
258 ;; We implement the following table. The notation is
259 ;; that X and Y are distinct meta specializer names.
261 ;; NIL <anything> ===> <anything>
264 (let ((new-metatype (specializer->metatype new-specializer
)))
265 (cond ((eq new-metatype
'slot-instance
) 'class
)
266 ((eq new-metatype
'forward
) 'class
)
267 ((eq new-metatype
'non-standard
) 'class
)
268 ((null metatype
) new-metatype
)
269 ((eq metatype new-metatype
) new-metatype
)
272 (defmacro with-dfun-wrappers
((args metatypes
)
273 (dfun-wrappers invalid-wrapper-p
274 &optional wrappers classes types
)
275 invalid-arguments-form
277 `(let* ((args-tail ,args
) (,invalid-wrapper-p nil
) (invalid-arguments-p nil
)
278 (,dfun-wrappers nil
) (dfun-wrappers-tail nil
)
280 `((wrappers-rev nil
) (types-rev nil
) (classes-rev nil
))))
281 (dolist (mt ,metatypes
)
283 (setq invalid-arguments-p t
)
285 (let* ((arg (pop args-tail
))
288 `((class *the-class-t
*)
291 (setq wrapper
(wrapper-of arg
))
292 (when (invalid-wrapper-p wrapper
)
293 (setq ,invalid-wrapper-p t
)
294 (setq wrapper
(check-wrapper-validity arg
)))
295 (cond ((null ,dfun-wrappers
)
296 (setq ,dfun-wrappers wrapper
))
297 ((not (consp ,dfun-wrappers
))
298 (setq dfun-wrappers-tail
(list wrapper
))
299 (setq ,dfun-wrappers
(cons ,dfun-wrappers dfun-wrappers-tail
)))
301 (let ((new-dfun-wrappers-tail (list wrapper
)))
302 (setf (cdr dfun-wrappers-tail
) new-dfun-wrappers-tail
)
303 (setf dfun-wrappers-tail new-dfun-wrappers-tail
))))
305 `((setq class
(wrapper-class* wrapper
))
306 (setq type
`(class-eq ,class
)))))
308 `((push wrapper wrappers-rev
)
309 (push class classes-rev
)
310 (push type types-rev
)))))
311 (if invalid-arguments-p
312 ,invalid-arguments-form
313 (let* (,@(when wrappers
314 `((,wrappers
(nreverse wrappers-rev
))
315 (,classes
(nreverse classes-rev
))
316 (,types
(mapcar (lambda (class)