1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from software originally released by Xerox
5 ;;;; Corporation. Copyright and release statements follow. Later modifications
6 ;;;; to the software are in the public domain and are provided with
7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
10 ;;;; copyright information from original PCL sources:
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
15 ;;;; Use and copying of this software and preparation of derivative works based
16 ;;;; upon this software are permitted. Any distribution of this software or
17 ;;;; derivative works must comply with all applicable United States export
20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
21 ;;;; warranty about the software, its performance or its conformity to any
26 (defvar *!temporary-ensure-accessor-functions
* nil
)
27 (defun ensure-accessor (fun-name)
28 (when (member fun-name
*!temporary-ensure-accessor-functions
* :test
'equal
)
29 (error "ENSURE-ACCESSOR ~S called more than once!?" fun-name
))
30 (push fun-name
*!temporary-ensure-accessor-functions
*)
31 #| We don
't really need
"fast" global slot accessors while building PCL.
32 ;; With few exceptions, all methods use a permutation vector for slot access.
33 ;; In a pinch, these would suffice, should it become utterly necessary:
34 (destructuring-bind (slot-name method
) (cddr fun-name
)
35 (setf (fdefinition fun-name
)
37 (reader (lambda (object) (slot-value object slot-name
)))
38 (writer (lambda (newval object
) (setf (slot-value object slot-name
) newval
)))
39 (boundp (lambda (object) (slot-boundp object slot-name
))))))|
#
40 (setf (fdefinition fun-name
)
42 (error "Nooooo! ~S accidentally invoked on ~S" fun-name args
))))
44 (defun make-structure-slot-boundp-function (slotd)
45 (declare (ignore slotd
))
46 (named-lambda always-bound
(object)
47 (declare (ignore object
))
50 (define-condition instance-structure-protocol-error
51 (reference-condition error
)
52 ((slotd :initarg
:slotd
:reader instance-structure-protocol-error-slotd
)
53 (fun :initarg
:fun
:reader instance-structure-protocol-error-fun
))
56 (format s
"~@<The slot ~S has neither ~S nor ~S ~
57 allocation, so it can't be ~A by the default ~
59 (instance-structure-protocol-error-slotd c
)
62 ((member (instance-structure-protocol-error-fun c
)
63 '(slot-value-using-class slot-boundp-using-class
))
66 (instance-structure-protocol-error-fun c
)))))
68 (defun instance-structure-protocol-error (slotd fun
)
69 (error 'instance-structure-protocol-error
71 :references
`((:amop
:generic-function
,fun
)
72 (:amop
:section
(5 5 3)))))
74 (defun get-optimized-std-accessor-method-function (class slotd name
)
76 ((structure-class-p class
)
78 (reader (slot-definition-internal-reader-function slotd
))
79 (writer (slot-definition-internal-writer-function slotd
))
80 (boundp (make-structure-slot-boundp-function slotd
))))
81 ((condition-class-p class
)
82 (let ((info (the slot-info
(slot-definition-info slotd
))))
84 (reader (slot-info-reader info
))
85 (writer (slot-info-writer info
))
86 (boundp (slot-info-boundp info
)))))
88 (let* ((fsc-p (cond ((standard-class-p class
) nil
)
89 ((funcallable-standard-class-p class
) t
)
91 ;; Shouldn't be using the optimized-std-accessors
93 #+nil
(format t
"* warning: ~S ~S~% ~S~%"
96 (t (error "~S is not a STANDARD-CLASS." class
))))
97 (slot-name (slot-definition-name slotd
))
98 (location (slot-definition-location slotd
))
100 (reader #'make-optimized-std-reader-method-function
)
101 (writer #'make-optimized-std-writer-method-function
)
102 (boundp #'make-optimized-std-boundp-method-function
)))
103 ;; KLUDGE: we need this slightly hacky calling convention
104 ;; for these functions for bootstrapping reasons: see
105 ;; !BOOTSTRAP-MAKE-SLOT-DEFINITION in braid.lisp. -- CSR,
107 (value (funcall function fsc-p slotd slot-name location
)))
108 (declare (type function function
))
109 (values value
(slot-definition-location slotd
))))))
111 (defun make-optimized-std-reader-method-function
112 (fsc-p slotd slot-name location
)
118 (check-obsolete-instance instance
)
119 (let ((value (clos-slots-ref (fsc-instance-slots instance
)
121 (if (unbound-marker-p value
)
123 (slot-unbound (class-of instance
) instance slot-name
))
126 (check-obsolete-instance instance
)
127 (let ((value (clos-slots-ref (std-instance-slots instance
)
129 (if (unbound-marker-p value
)
131 (slot-unbound (class-of instance
) instance slot-name
))
135 (check-obsolete-instance instance
)
136 (let ((value (cdr location
)))
137 (if (unbound-marker-p value
)
138 (values (slot-unbound (class-of instance
) instance slot-name
))
142 (declare (ignore instance
))
143 (instance-structure-protocol-error slotd
'slot-value-using-class
))))
144 `(reader ,slot-name
)))
146 (defun make-optimized-std-writer-method-function (fsc-p slotd slot-name location
)
147 ;; The (WHEN SLOTD ...) gunk is for building early slot definitions.
148 (let* ((class (when slotd
(slot-definition-class slotd
)))
149 (safe-p (when slotd
(safe-p class
)))
150 (orig-wrapper (when safe-p
(class-wrapper class
)))
151 (info (when safe-p
(slot-definition-info slotd
)))
152 (writer-fun (etypecase location
153 ;; In SAFE-P case the typechecking already validated the instance.
157 (lambda (nv instance
)
158 (setf (clos-slots-ref (fsc-instance-slots instance
)
161 (lambda (nv instance
)
162 (check-obsolete-instance instance
)
163 (setf (clos-slots-ref (fsc-instance-slots instance
)
167 (lambda (nv instance
)
168 (setf (clos-slots-ref (std-instance-slots instance
)
171 (lambda (nv instance
)
172 (check-obsolete-instance instance
)
173 (setf (clos-slots-ref (std-instance-slots instance
)
178 (lambda (nv instance
)
179 (declare (ignore instance
))
180 (setf (cdr location
) nv
))
181 (lambda (nv instance
)
182 (check-obsolete-instance instance
)
183 (setf (cdr location
) nv
))))
185 (lambda (nv instance
)
186 (declare (ignore nv instance
))
187 (instance-structure-protocol-error
189 '(setf slot-value-using-class
))))))
190 (checking-fun (when safe-p
191 (lambda (new-value instance
)
192 ;; If we have a TYPE-CHECK-FUNCTION, call it.
193 (let* (;; Note that the class of INSTANCE here is not
194 ;; neccessarily the SLOT-DEFINITION-CLASS of
195 ;; the SLOTD passed to M-O-S-W-M-F, since it's
196 ;; e.g. possible for a subclass to define a
197 ;; slot of the same name but with no
198 ;; accessors. So we may need to fetch the
199 ;; right SLOT-INFO from the wrapper instead of
200 ;; just closing over it.
201 (wrapper (valid-wrapper-of instance
))
204 (if (eq wrapper orig-wrapper
)
206 (cdr (find-slot-cell wrapper slot-name
))))))
208 (funcall typecheck new-value
)))
209 ;; Then call the real writer.
210 (funcall writer-fun new-value instance
)))))
211 (set-fun-name (if safe-p
214 `(writer ,slot-name
))))
216 (defun make-optimized-std-boundp-method-function
217 (fsc-p slotd slot-name location
)
222 (check-obsolete-instance instance
)
223 (not (unbound-marker-p (clos-slots-ref (fsc-instance-slots instance
)
226 (check-obsolete-instance instance
)
227 (not (unbound-marker-p (clos-slots-ref (std-instance-slots instance
)
229 (cons (lambda (instance)
230 (check-obsolete-instance instance
)
231 (not (unbound-marker-p (cdr location
)))))
234 (declare (ignore instance
))
235 (instance-structure-protocol-error slotd
'slot-boundp-using-class
))))
236 `(boundp ,slot-name
)))
238 (defun make-optimized-structure-slot-value-using-class-method-function
240 (declare (type function function
))
241 (lambda (class object slotd
)
242 (declare (ignore class slotd
))
243 (funcall function object
)))
245 (defun make-optimized-structure-setf-slot-value-using-class-method-function
247 (declare (type function function
))
248 (lambda (nv class object slotd
)
249 (declare (ignore class slotd
))
250 (funcall function nv object
)))
252 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
253 (lambda (class object slotd
)
254 (declare (ignore class object slotd
))
257 (defun get-optimized-std-slot-value-using-class-method-function
260 ((structure-class-p class
)
262 (reader (make-optimized-structure-slot-value-using-class-method-function
263 (slot-definition-internal-reader-function slotd
)))
264 (writer (make-optimized-structure-setf-slot-value-using-class-method-function
265 (slot-definition-internal-writer-function slotd
)))
266 (boundp (make-optimized-structure-slot-boundp-using-class-method-function))))
267 ((condition-class-p class
)
268 (let ((info (slot-definition-info slotd
)))
271 (let ((fun (slot-info-reader info
)))
272 (lambda (class object slotd
)
273 (declare (ignore class slotd
))
274 (funcall fun object
))))
276 (let ((fun (slot-info-writer info
)))
277 (lambda (new-value class object slotd
)
278 (declare (ignore class slotd
))
279 (funcall fun new-value object
))))
281 (let ((fun (slot-info-boundp info
)))
282 (lambda (class object slotd
)
283 (declare (ignore class slotd
))
284 (funcall fun object
)))))))
286 (let* ((fsc-p (cond ((standard-class-p class
) nil
)
287 ((funcallable-standard-class-p class
) t
)
288 (t (error "~S is not a standard-class" class
))))
292 #'make-optimized-std-slot-value-using-class-method-function
)
294 #'make-optimized-std-setf-slot-value-using-class-method-function
)
296 #'make-optimized-std-slot-boundp-using-class-method-function
))))
297 (declare (type function function
))
298 (values (funcall function fsc-p slotd
)
299 (slot-definition-location slotd
))))))
301 (defun make-optimized-std-slot-value-using-class-method-function (fsc-p slotd
)
302 (let ((location (slot-definition-location slotd
))
303 (slot-name (slot-definition-name slotd
)))
306 (lambda (class instance slotd
)
307 (declare (ignore slotd
))
308 (check-obsolete-instance instance
)
309 (let ((value (clos-slots-ref (fsc-instance-slots instance
)
311 (if (unbound-marker-p value
)
312 (values (slot-unbound class instance slot-name
))
314 (lambda (class instance slotd
)
315 (declare (ignore slotd
))
316 (check-obsolete-instance instance
)
317 (let ((value (clos-slots-ref (std-instance-slots instance
)
319 (if (unbound-marker-p value
)
320 (values (slot-unbound class instance slot-name
))
322 (cons (lambda (class instance slotd
)
323 (declare (ignore slotd
))
324 (check-obsolete-instance instance
)
325 (let ((value (cdr location
)))
326 (if (unbound-marker-p value
)
327 (values (slot-unbound class instance slot-name
))
330 (lambda (class instance slotd
)
331 (declare (ignore class instance
))
332 (instance-structure-protocol-error slotd
'slot-value-using-class
))))))
334 (defun make-optimized-std-setf-slot-value-using-class-method-function
336 (let* ((location (slot-definition-location slotd
))
337 (class (slot-definition-class slotd
))
340 (slot-info-typecheck (slot-definition-info slotd
)))))
341 (macrolet ((make-mf-lambda (&body body
)
342 `(lambda (nv class instance slotd
)
343 (declare (ignore class slotd
))
344 (check-obsolete-instance instance
)
346 (make-mf-lambdas (&body body
)
347 ;; Having separate lambdas for the NULL / not-NULL cases of
348 ;; TYPE-CHECK-FUNCTION is done to avoid runtime overhead
349 ;; for CLOS typechecking when it's not in use.
352 (funcall (the function typecheck
) nv
)
360 (setf (clos-slots-ref (fsc-instance-slots instance
) location
)
363 (setf (clos-slots-ref (std-instance-slots instance
) location
)
366 (make-mf-lambdas (setf (cdr location
) nv
)))
367 (null (lambda (nv class instance slotd
)
368 (declare (ignore nv class instance
))
369 (instance-structure-protocol-error
370 slotd
'(setf slot-value-using-class
))))))))
372 (defun make-optimized-std-slot-boundp-using-class-method-function
374 (let ((location (slot-definition-location slotd
)))
378 (lambda (class instance slotd
)
379 (declare (ignore class slotd
))
380 (check-obsolete-instance instance
)
381 (not (unbound-marker-p
382 (clos-slots-ref (fsc-instance-slots instance
) location
))))
383 (lambda (class instance slotd
)
384 (declare (ignore class slotd
))
385 (check-obsolete-instance instance
)
386 (not (unbound-marker-p
387 (clos-slots-ref (std-instance-slots instance
) location
))))))
388 (cons (lambda (class instance slotd
)
389 (declare (ignore class slotd
))
390 (check-obsolete-instance instance
)
391 (not (unbound-marker-p (cdr location
)))))
393 (lambda (class instance slotd
)
394 (declare (ignore class instance
))
395 (instance-structure-protocol-error slotd
396 'slot-boundp-using-class
))))))
398 (defun get-accessor-from-svuc-method-function (class slotd sdfun name
)
399 (macrolet ((emf-funcall (emf &rest args
)
400 `(invoke-effective-method-function ,emf nil
401 :required-args
,args
)))
404 (reader (lambda (instance)
405 (emf-funcall sdfun class instance slotd
)))
406 (writer (lambda (nv instance
)
407 (emf-funcall sdfun nv class instance slotd
)))
408 (boundp (lambda (instance)
409 (emf-funcall sdfun class instance slotd
))))
410 `(,name
,(class-name class
) ,(slot-definition-name slotd
)))))
412 (defun maybe-class (class-or-name)
413 (when (eq **boot-state
** 'complete
)
414 (if (typep class-or-name
'class
)
416 (find-class class-or-name nil
))))
418 (flet ((make-initargs (slot-name kind method-function
)
419 (let ((initargs (copy-tree method-function
))
420 (slot-names (list slot-name
)))
421 (setf (getf (getf initargs
'plist
) :slot-name-lists
)
423 ((:reader
:boundp
) (list slot-names
))
424 (:writer
(list '() slot-names
))))
427 (defun make-std-reader-method-function (class-or-name slot-name
)
428 (let ((class (maybe-class class-or-name
)))
431 (ecase (slot-access-strategy class slot-name
'reader t
)
433 (make-method-function
435 (pv-binding1 ((bug "Please report this")
436 (instance) (instance-slots))
437 (instance-read-standard
438 .pv. instance-slots
0
439 (slot-value instance slot-name
))))))
441 (make-method-function
443 (pv-binding1 ((bug "Please report this")
445 (instance-read-custom .pv.
0 instance
)))))))))
447 (defun make-std-writer-method-function (class-or-name slot-name
)
448 (let ((class (maybe-class class-or-name
)))
451 (ecase (slot-access-strategy class slot-name
'writer t
)
453 (macrolet ((writer-method-function (safe)
454 `(make-method-function
455 (lambda (nv instance
)
456 (pv-binding1 ((bug "Please report this")
457 (instance) (instance-slots))
458 (instance-write-standard
459 .pv. instance-slots
0 nv
460 (setf (slot-value instance slot-name
)
462 ,@(when safe
'(nil t
))))))))
463 (if (and class
(safe-p class
))
464 (writer-method-function t
)
465 (writer-method-function nil
))))
467 (make-method-function
468 (lambda (nv instance
)
469 (pv-binding1 ((bug "Please report this")
471 (instance-write-custom .pv.
0 instance nv
)))))))))
473 (defun make-std-boundp-method-function (class-or-name slot-name
)
474 (let ((class (maybe-class class-or-name
)))
477 (ecase (slot-access-strategy class slot-name
'boundp t
)
479 (make-method-function
481 (pv-binding1 ((bug "Please report this")
482 (instance) (instance-slots))
483 (instance-boundp-standard
484 .pv. instance-slots
0
485 (slot-boundp instance slot-name
))))))
487 (make-method-function
489 (pv-binding1 ((bug "Please report this")
491 (instance-boundp-custom .pv.
0 instance
))))))))))
493 ;;;; FINDING SLOT DEFINITIONS
495 ;;; Historical PCL found slot definitions by iterating over
496 ;;; CLASS-SLOTS, which is O(N) for number of slots, and moreover
497 ;;; requires a GF call (for SLOT-DEFINITION-NAME) for each slot in
498 ;;; list up to the desired one.
500 ;;; Current SBCL hashes the effective slot definitions, and some
501 ;;; information pulled out from them into a simple-vector, with bucket
502 ;;; chains made out of plists keyed by the slot names. This fixes
503 ;;; gives O(1) performance, and avoid the GF calls.
505 ;;; MAKE-SLOT-TABLE constructs the hashed vector out of a list of
506 ;;; effective slot definitions and the class they pertain to, and
507 ;;; FIND-SLOT-DEFINITION knows how to look up slots in that vector.
509 ;;; The only bit of cleverness in the implementation is to make the
510 ;;; vectors fairly tight, but always longer then 0 elements:
512 ;;; -- We don't want to waste huge amounts of space no these vectors,
513 ;;; which are mostly required by things like SLOT-VALUE with a
514 ;;; variable slot name, so a constant extension over the minimum
515 ;;; size seems like a good choise.
517 ;;; -- As long as the vector always has a length > 0
518 ;;; FIND-SLOT-DEFINITION doesn't need to handle the rare case of an
519 ;;; empty vector separately: it just returns a NIL.
521 ;;; In addition to the slot-definition we also store the slot-location
522 ;;; and type-check function for instances of standard metaclasses, so
523 ;;; that SLOT-VALUE &co using variable slot names can get at them
524 ;;; without additional GF calls.
527 ;;; It would also be nice to have STANDARD-INSTANCE-STRUCTURE-P
528 ;;; generic instead of checking versus STANDARD-CLASS and
529 ;;; FUNCALLABLE-STANDARD-CLASS.
531 ;;; Uh, the comments above talking about how FIND-SLOT-DEFINITION
532 ;;; does something with slot vectors has no basis in reality.
533 ;;; Probably the comments need fixing, rather than the code.
535 (defun find-slot-definition (class slot-name
&optional errorp
)
536 (unless (class-finalized-p class
)
537 (or (try-finalize-inheritance class
)
539 (error "Cannot look up slot-definition for ~S in ~S (too early to finalize.)"
541 (return-from find-slot-definition
(values nil nil
)))))
542 (dolist (slotd (class-slots class
)
544 (error "No slot called ~S in ~S." slot-name class
)
546 (when (eq slot-name
(slot-definition-name slotd
))
547 (return (values slotd t
)))))
549 (defun find-slot-cell (wrapper slot-name
)
550 (declare (symbol slot-name
))
551 (declare (optimize (sb-c::insert-array-bounds-checks
0)))
552 (let* ((vector (layout-slot-table wrapper
))
553 (modulus (truly-the index
(svref vector
0)))
554 ;; Can elide the 'else' branch of (OR symbol-hash ensure-symbol-hash)
555 ;; because every symbol in the slot-table already got a nonzero hash.
556 (index (rem (symbol-hash slot-name
) modulus
))
557 (probe (svref vector
(1+ index
))))
558 (declare (simple-vector vector
) (index index
))
559 (cond ((fixnump probe
)
560 (do* ((count (svref vector
(1- (truly-the index probe
))))
561 (end (truly-the index
(+ probe count
)))
564 (declare (index count j
))
565 (when (eq (svref vector j
) slot-name
)
566 (return (svref vector
(truly-the index
(+ j count
)))))))
567 ((eq (car (truly-the list probe
)) slot-name
)
570 (defun make-slot-table (class slots
&optional bootstrap
)
572 ;; *** If changing this empty table value to something else,
573 ;; be sure to make a similar change to MAKE-COLD-LAYOUT in
574 ;; compiler/generic/genesis as well as in DEFSTRUCT LAYOUT.
575 ;; A DEFCONSTANT for this would only transfer the problem
576 ;; to cold-init in a different sort of way. :-(
577 (return-from make-slot-table
#(1 nil
)))
578 (let* ((n (+ (logior (length slots
) 1) 2)) ; an odd divisor is preferred
579 (vector (make-array n
:initial-element nil
)))
580 (flet ((add-to-vector (name slot
)
581 (declare (symbol name
)
582 (optimize (sb-c::insert-array-bounds-checks
0)))
583 (let ((index (rem (ensure-symbol-hash name
) n
)))
584 (setf (svref vector index
)
586 (cons (when (or bootstrap
587 (and (standard-class-p class
)
588 (slot-accessor-std-p slot
'all
)))
590 (early-slot-definition-location slot
)
591 (slot-definition-location slot
)))
594 (early-slot-definition-info slot
)
595 (slot-definition-info slot
))))
596 (svref vector index
))))))
597 (if (eq 'complete
**boot-state
**)
599 (add-to-vector (slot-definition-name slot
) slot
))
601 (add-to-vector (early-slot-definition-name slot
) slot
))))
602 ;; The VECTOR as computed above implements a hash table with chaining.
603 ;; Rather than store chains using cons cells, chains can be stored in the
604 ;; vector itself at the end, with the table entry pointing to another
605 ;; index in the vector. The chain length is stored first, then all keys,
606 ;; then all values. The resulting structure takes less memory than
607 ;; linked lists, and can be scanned faster. As an exception, for lists
608 ;; of length 1, the table cell holds a (key . value) pair directly.
611 ;; number of additional cells needed to represent linked lists
612 ;; as length-prefixed subsequences in the final vector.
613 (loop for cell across vector
614 for count
= (length cell
)
615 sum
(if (<= count
1) 0 (1+ (* count
2))))))
616 (final-vector (make-array final-n
))
617 (data-index (1+ n
))) ; after the hashtable portion of the vector
618 (setf (aref final-vector
0) n
) ; the modulus
619 (dotimes (i n final-vector
)
620 (let ((alist (aref vector i
)))
621 (if (not (cdr alist
)) ; store it in the final vector as-is
622 (setf (aref final-vector
(1+ i
)) (car alist
))
623 (let ((count (length alist
)))
624 ;; Probed cell holds the index of the first symbol.
625 ;; The symbol count precedes the first symbol cell.
626 (setf (aref final-vector
(1+ i
)) (1+ data-index
)
627 (aref final-vector data-index
) count
)
629 (setf (aref final-vector
(incf data-index
)) (car cell
)))
631 (setf (aref final-vector
(incf data-index
)) (cdr cell
)))
632 (incf data-index
))))))))