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
)))
32 (declaim (inline make-wrapper-internal
))
33 (defun make-wrapper-internal (&key
(bitmap -
1) length classoid
)
34 (make-layout :length length
:classoid classoid
:invalid nil
35 :%for-std-class-b
1 :bitmap bitmap
))
37 ;;; With compact-instance-header and immobile-code, the primitive object has
38 ;;; 2 descriptor slots (fin-fun and CLOS slot vector) and 2 non-desriptor slots
39 ;;; containing machine instructions, after the self-pointer (trampoline) slot.
40 ;;; Scavenging the self-pointer is unnecessary though harmless.
41 ;;; This intricate calculation of #b110 makes it insensitive to the
42 ;;; index of the trampoline slot.
43 #+(and immobile-code compact-instance-header
)
44 (defconstant +fsc-layout-bitmap
+
45 (logxor (1- (ash 1 sb-vm
:funcallable-instance-info-offset
))
46 (ash 1 (1- sb-vm
:funcallable-instance-trampoline-slot
))))
48 ;;; This is called in BRAID when we are making wrappers for classes
49 ;;; whose slots are not initialized yet, and which may be built-in
50 ;;; classes. We pass in the class name in addition to the class.
51 (defun !boot-make-wrapper
(length name
&optional class
)
52 (let ((found (find-classoid name nil
)))
55 (unless (classoid-pcl-class found
)
56 (setf (classoid-pcl-class found
) class
))
57 (aver (eq (classoid-pcl-class found
) class
))
58 (let ((layout (classoid-layout found
)))
62 (make-wrapper-internal
63 :bitmap
(cond #+(and immobile-code compact-instance-header
)
64 ((member name
'(generic-function
65 standard-generic-function
))
69 :classoid
(make-standard-classoid
70 :name name
:pcl-class class
))))))
72 ;;; In SBCL, as in CMU CL, the layouts (a.k.a wrappers) for built-in
73 ;;; and structure classes already exist when PCL is initialized, so we
74 ;;; don't necessarily always make a wrapper. Also, we help maintain
75 ;;; the mapping between CL:CLASS and SB-KERNEL:CLASSOID objects.
76 (defun make-wrapper (length class
)
77 ;; SLOT-VALUE can't be inlined because we don't have the machinery
78 ;; to perform ENSURE-ACCESSOR as yet.
79 (declare (notinline slot-value
))
81 ((or (typep class
'std-class
)
82 (typep class
'forward-referenced-class
))
83 (make-wrapper-internal
84 :bitmap
(cond #+(and immobile-code compact-instance-header
)
85 ((eq (class-of class
) *the-class-funcallable-standard-class
*)
90 (let ((owrap (class-wrapper class
)))
92 (layout-classoid owrap
))
93 ((or (*subtypep
(class-of class
) *the-class-standard-class
*)
94 (*subtypep
(class-of class
) *the-class-funcallable-standard-class
*)
95 (typep class
'forward-referenced-class
))
96 (let ((name (slot-value class
'name
)))
97 (make-standard-classoid :pcl-class class
98 :name
(and (symbolp name
) name
))))
100 (bug "Got to T branch in ~S" 'make-wrapper
))))))
102 (let* ((found (find-classoid (slot-value class
'name
)))
103 (layout (classoid-layout found
)))
104 (unless (classoid-pcl-class found
)
105 (setf (classoid-pcl-class found
) class
))
106 (aver (eq (classoid-pcl-class found
) class
))
110 (declaim (inline wrapper-class
*))
111 (defun wrapper-class* (wrapper)
112 (or (wrapper-class wrapper
)
113 ;; FIXME: this branch seems unreachable.
114 ;; It would be nice to eliminate WRAPPER-CLASS* if we can show that it
115 ;; is only a holdover from an earlier way of bootstrapping that resulted
116 ;; in the temporary absence of a PCL-CLASS for some non-standard-class.
117 ;; Certainly no test gets here [changing it to (BUG "got here") worked].
119 ;; (CLASSOID-PCL-CLASS (FIND-CLASSOID 'STANDARD-INSTANCE)) => NIL
120 ;; which can be resolved by just ensuring one time that it has a CLASS.
121 ;; And nothing else seems to be problematic.
122 (let ((classoid (layout-classoid wrapper
)))
123 (ensure-non-standard-class
124 (classoid-name classoid
)
127 ;;; The wrapper cache machinery provides general mechanism for
128 ;;; trapping on the next access to any instance of a given class. This
129 ;;; mechanism is used to implement the updating of instances when the
130 ;;; class is redefined (MAKE-INSTANCES-OBSOLETE). The same mechanism
131 ;;; is also used to update generic function caches when there is a
132 ;;; change to the superclasses of a class.
134 ;;; Basically, a given wrapper can be valid or invalid. If it is
135 ;;; invalid, it means that any attempt to do a wrapper cache lookup
136 ;;; using the wrapper should trap. Also, methods on
137 ;;; SLOT-VALUE-USING-CLASS check the wrapper validity as well. This is
138 ;;; done by calling CHECK-WRAPPER-VALIDITY.
140 (declaim (inline invalid-wrapper-p
))
141 (defun invalid-wrapper-p (wrapper)
142 (not (null (layout-invalid wrapper
))))
144 ;;; We only use this inside INVALIDATE-WRAPPER.
145 (defvar *previous-nwrappers
* (make-hash-table :test
#'eq
))
147 (defun %invalidate-wrapper
(owrapper state nwrapper
)
148 (aver (member state
'(:flush
:obsolete
) :test
#'eq
))
149 (let ((new-previous ()))
150 ;; First off, a previous call to INVALIDATE-WRAPPER may have
151 ;; recorded OWRAPPER as an NWRAPPER to update to. Since OWRAPPER
152 ;; is about to be invalid, it no longer makes sense to update to
155 ;; We go back and change the previously invalidated wrappers so
156 ;; that they will now update directly to NWRAPPER. This
157 ;; corresponds to a kind of transitivity of wrapper updates.
158 (dolist (previous (gethash owrapper
*previous-nwrappers
*))
159 (when (eq state
:obsolete
)
160 (setf (car previous
) :obsolete
))
161 (setf (cadr previous
) nwrapper
)
162 (push previous new-previous
))
164 ;; FIXME: We are here inside PCL lock, but might someone be
165 ;; accessing the wrapper at the same time from outside the lock?
166 (setf (layout-clos-hash owrapper
) 0)
168 ;; FIXME: We could save a whopping cons by using (STATE . WRAPPER)
170 (push (setf (layout-invalid owrapper
) (list state nwrapper
))
173 (remhash owrapper
*previous-nwrappers
*)
174 (setf (gethash nwrapper
*previous-nwrappers
*) new-previous
)))
176 ;;; FIXME: This is not a good name: part of the contract here is that
177 ;;; we return the valid wrapper, which is not obvious from the name
178 ;;; (or the names of our callees.)
179 (defun check-wrapper-validity (instance)
181 (let* ((owrapper (layout-of instance
))
182 (state (layout-invalid owrapper
)))
183 (aver (not (eq state
:uninitialized
)))
186 ((not (layout-for-std-class-p owrapper
))
187 ;; Obsolete structure trap.
188 (%obsolete-instance-trap owrapper nil instance
))
190 ;; FIXME: I can't help thinking that, while this does cure
191 ;; the symptoms observed from some class redefinitions,
192 ;; this isn't the place to be doing this flushing.
193 ;; Nevertheless... -- CSR, 2003-05-31
196 ;; We assume in this case, that the :INVALID is from a
197 ;; previous call to REGISTER-LAYOUT for a superclass of
198 ;; INSTANCE's class. See also the comment above
199 ;; FORCE-CACHE-FLUSHES. Paul Dietz has test cases for this.
200 (let ((class (wrapper-class* owrapper
)))
201 (%force-cache-flushes class
)
202 ;; KLUDGE: avoid an infinite recursion, it's still better to
203 ;; bail out with an error for server softwares. see FIXME above.
204 ;; details: http://thread.gmane.org/gmane.lisp.steel-bank.devel/10175
206 ;; Error message here is trying to figure out a bit more about the
207 ;; situation, since we don't have anything approaching a test-case
209 (let ((new-state (layout-invalid (layout-of instance
))))
210 (when (eq new-state t
)
211 (cerror "Nevermind and recurse." 'bug
212 :format-control
"~@<~4IProblem forcing cache flushes. Please report ~
216 ~% Class-wrapper: ~S~%~:@>"
217 :format-arguments
(mapcar (lambda (x)
218 (cons x
(layout-invalid x
)))
221 (class-wrapper class
)))))))
222 (check-wrapper-validity instance
))
226 (let ((new (cadr state
)))
227 (cond ((std-instance-p instance
)
228 (setf (%instance-layout instance
) new
))
229 ((fsc-instance-p instance
)
230 (setf (%funcallable-instance-layout instance
) new
))
232 (bug "unrecognized instance type")))))
234 (%obsolete-instance-trap owrapper
(cadr state
) instance
))))))))
236 (declaim (inline check-obsolete-instance
))
237 (defun check-obsolete-instance (instance)
238 (when (invalid-wrapper-p (layout-of instance
))
239 (check-wrapper-validity instance
)))
241 (defun valid-wrapper-of (instance)
242 (let ((wrapper (layout-of instance
)))
243 (if (invalid-wrapper-p wrapper
)
244 (check-wrapper-validity instance
)
247 ;;; NIL: means nothing so far, no actual arg info has NILs in the
250 ;;; CLASS: seen all sorts of metaclasses (specifically, more than one
251 ;;; of the next 5 values) or else have seen something which doesn't
252 ;;; fall into a single category (SLOT-INSTANCE, FORWARD). Also used
253 ;;; when seen a non-standard specializer.
255 ;;; T: means everything so far is the class T.
257 ;;; The above three are the really important ones, as they affect how
258 ;;; discriminating functions are computed. There are some other
259 ;;; possible metatypes:
261 ;;; * STANDARD-INSTANCE: seen only standard classes
262 ;;; * BUILT-IN-INSTANCE: seen only built in classes
263 ;;; * STRUCTURE-INSTANCE: seen only structure classes
264 ;;; * CONDITION-INSTANCE: seen only condition classes
266 ;;; but these are largely unexploited as of 2007-05-10. The
267 ;;; distinction between STANDARD-INSTANCE and the others is used in
268 ;;; emitting wrapper/slot-getting code in accessor discriminating
269 ;;; functions (see EMIT-FETCH-WRAPPER and EMIT-READER/WRITER); it is
270 ;;; possible that there was an intention to use these metatypes to
271 ;;; specialize cache implementation or discrimination nets, but this
272 ;;; has not occurred as yet.
273 (defun raise-metatype (metatype new-specializer
)
274 (let ((slot *the-class-slot-class
*)
275 (standard *the-class-standard-class
*)
276 (fsc *the-class-funcallable-standard-class
*)
277 (condition *the-class-condition-class
*)
278 (structure *the-class-structure-class
*)
279 (system *the-class-system-class
*)
280 (frc *the-class-forward-referenced-class
*))
281 (flet ((specializer->metatype
(x)
282 (let* ((specializer-class (if (eq **boot-state
** 'complete
)
283 (specializer-class-or-nil x
)
285 (meta-specializer (class-of specializer-class
)))
287 ((eq x
*the-class-t
*) t
)
288 ((not specializer-class
) 'non-standard
)
289 ((*subtypep meta-specializer standard
) 'standard-instance
)
290 ((*subtypep meta-specializer fsc
) 'standard-instance
)
291 ((*subtypep meta-specializer condition
) 'condition-instance
)
292 ((*subtypep meta-specializer structure
) 'structure-instance
)
293 ((*subtypep meta-specializer system
) 'system-instance
)
294 ((*subtypep meta-specializer slot
) 'slot-instance
)
295 ((*subtypep meta-specializer frc
) 'forward
)
296 (t (error "~@<PCL cannot handle the specializer ~S ~
297 (meta-specializer ~S).~@:>"
298 new-specializer meta-specializer
))))))
299 ;; We implement the following table. The notation is
300 ;; that X and Y are distinct meta specializer names.
302 ;; NIL <anything> ===> <anything>
305 (let ((new-metatype (specializer->metatype new-specializer
)))
306 (cond ((eq new-metatype
'slot-instance
) 'class
)
307 ((eq new-metatype
'forward
) 'class
)
308 ((eq new-metatype
'non-standard
) 'class
)
309 ((null metatype
) new-metatype
)
310 ((eq metatype new-metatype
) new-metatype
)
313 (defmacro with-dfun-wrappers
((args metatypes
)
314 (dfun-wrappers invalid-wrapper-p
315 &optional wrappers classes types
)
316 invalid-arguments-form
318 `(let* ((args-tail ,args
) (,invalid-wrapper-p nil
) (invalid-arguments-p nil
)
319 (,dfun-wrappers nil
) (dfun-wrappers-tail nil
)
321 `((wrappers-rev nil
) (types-rev nil
) (classes-rev nil
))))
322 (dolist (mt ,metatypes
)
324 (setq invalid-arguments-p t
)
326 (let* ((arg (pop args-tail
))
329 `((class *the-class-t
*)
332 (setq wrapper
(layout-of arg
))
333 (when (invalid-wrapper-p wrapper
)
334 (setq ,invalid-wrapper-p t
)
335 (setq wrapper
(check-wrapper-validity arg
)))
336 (cond ((null ,dfun-wrappers
)
337 (setq ,dfun-wrappers wrapper
))
338 ((not (consp ,dfun-wrappers
))
339 (setq dfun-wrappers-tail
(list wrapper
))
340 (setq ,dfun-wrappers
(cons ,dfun-wrappers dfun-wrappers-tail
)))
342 (let ((new-dfun-wrappers-tail (list wrapper
)))
343 (setf (cdr dfun-wrappers-tail
) new-dfun-wrappers-tail
)
344 (setf dfun-wrappers-tail new-dfun-wrappers-tail
))))
346 `((setq class
(wrapper-class* wrapper
))
347 (setq type
`(class-eq ,class
)))))
349 `((push wrapper wrappers-rev
)
350 (push class classes-rev
)
351 (push type types-rev
)))))
352 (if invalid-arguments-p
353 ,invalid-arguments-form
354 (let* (,@(when wrappers
355 `((,wrappers
(nreverse wrappers-rev
))
356 (,classes
(nreverse classes-rev
))
357 (,types
(mapcar (lambda (class)