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
(list `(: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 (eq value
+slot-unbound
+)
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 (eq value
+slot-unbound
+)
131 (slot-unbound (class-of instance
) instance slot-name
))
135 (check-obsolete-instance instance
)
136 (let ((value (cdr location
)))
137 (if (eq value
+slot-unbound
+)
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 (eq (clos-slots-ref (fsc-instance-slots instance
)
227 (check-obsolete-instance instance
)
228 (not (eq (clos-slots-ref (std-instance-slots instance
)
231 (cons (lambda (instance)
232 (check-obsolete-instance instance
)
233 (not (eq (cdr location
) +slot-unbound
+))))
236 (declare (ignore instance
))
237 (instance-structure-protocol-error slotd
'slot-boundp-using-class
))))
238 `(boundp ,slot-name
)))
240 (defun make-optimized-structure-slot-value-using-class-method-function
242 (declare (type function function
))
243 (lambda (class object slotd
)
244 (declare (ignore class slotd
))
245 (funcall function object
)))
247 (defun make-optimized-structure-setf-slot-value-using-class-method-function
249 (declare (type function function
))
250 (lambda (nv class object slotd
)
251 (declare (ignore class slotd
))
252 (funcall function nv object
)))
254 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
255 (lambda (class object slotd
)
256 (declare (ignore class object slotd
))
259 (defun get-optimized-std-slot-value-using-class-method-function
262 ((structure-class-p class
)
264 (reader (make-optimized-structure-slot-value-using-class-method-function
265 (slot-definition-internal-reader-function slotd
)))
266 (writer (make-optimized-structure-setf-slot-value-using-class-method-function
267 (slot-definition-internal-writer-function slotd
)))
268 (boundp (make-optimized-structure-slot-boundp-using-class-method-function))))
269 ((condition-class-p class
)
270 (let ((info (slot-definition-info slotd
)))
273 (let ((fun (slot-info-reader info
)))
274 (lambda (class object slotd
)
275 (declare (ignore class slotd
))
276 (funcall fun object
))))
278 (let ((fun (slot-info-writer info
)))
279 (lambda (new-value class object slotd
)
280 (declare (ignore class slotd
))
281 (funcall fun new-value object
))))
283 (let ((fun (slot-info-boundp info
)))
284 (lambda (class object slotd
)
285 (declare (ignore class slotd
))
286 (funcall fun object
)))))))
288 (let* ((fsc-p (cond ((standard-class-p class
) nil
)
289 ((funcallable-standard-class-p class
) t
)
290 (t (error "~S is not a standard-class" class
))))
294 #'make-optimized-std-slot-value-using-class-method-function
)
296 #'make-optimized-std-setf-slot-value-using-class-method-function
)
298 #'make-optimized-std-slot-boundp-using-class-method-function
))))
299 (declare (type function function
))
300 (values (funcall function fsc-p slotd
)
301 (slot-definition-location slotd
))))))
303 (defun make-optimized-std-slot-value-using-class-method-function (fsc-p slotd
)
304 (let ((location (slot-definition-location slotd
))
305 (slot-name (slot-definition-name slotd
)))
308 (lambda (class instance slotd
)
309 (declare (ignore slotd
))
310 (check-obsolete-instance instance
)
311 (let ((value (clos-slots-ref (fsc-instance-slots instance
)
313 (if (eq value
+slot-unbound
+)
314 (values (slot-unbound class instance slot-name
))
316 (lambda (class instance slotd
)
317 (declare (ignore slotd
))
318 (check-obsolete-instance instance
)
319 (let ((value (clos-slots-ref (std-instance-slots instance
)
321 (if (eq value
+slot-unbound
+)
322 (values (slot-unbound class instance slot-name
))
324 (cons (lambda (class instance slotd
)
325 (declare (ignore slotd
))
326 (check-obsolete-instance instance
)
327 (let ((value (cdr location
)))
328 (if (eq value
+slot-unbound
+)
329 (values (slot-unbound class instance slot-name
))
332 (lambda (class instance slotd
)
333 (declare (ignore class instance
))
334 (instance-structure-protocol-error slotd
'slot-value-using-class
))))))
336 (defun make-optimized-std-setf-slot-value-using-class-method-function
338 (let* ((location (slot-definition-location slotd
))
339 (class (slot-definition-class slotd
))
342 (slot-info-typecheck (slot-definition-info slotd
)))))
343 (macrolet ((make-mf-lambda (&body body
)
344 `(lambda (nv class instance slotd
)
345 (declare (ignore class slotd
))
346 (check-obsolete-instance instance
)
348 (make-mf-lambdas (&body body
)
349 ;; Having separate lambdas for the NULL / not-NULL cases of
350 ;; TYPE-CHECK-FUNCTION is done to avoid runtime overhead
351 ;; for CLOS typechecking when it's not in use.
354 (funcall (the function typecheck
) nv
)
362 (setf (clos-slots-ref (fsc-instance-slots instance
) location
)
365 (setf (clos-slots-ref (std-instance-slots instance
) location
)
368 (make-mf-lambdas (setf (cdr location
) nv
)))
369 (null (lambda (nv class instance slotd
)
370 (declare (ignore nv class instance
))
371 (instance-structure-protocol-error
372 slotd
'(setf slot-value-using-class
))))))))
374 (defun make-optimized-std-slot-boundp-using-class-method-function
376 (let ((location (slot-definition-location slotd
)))
380 (lambda (class instance slotd
)
381 (declare (ignore class slotd
))
382 (check-obsolete-instance instance
)
383 (not (eq (clos-slots-ref (fsc-instance-slots instance
) location
)
385 (lambda (class instance slotd
)
386 (declare (ignore class slotd
))
387 (check-obsolete-instance instance
)
388 (not (eq (clos-slots-ref (std-instance-slots instance
) location
)
390 (cons (lambda (class instance slotd
)
391 (declare (ignore class slotd
))
392 (check-obsolete-instance instance
)
393 (not (eq (cdr location
) +slot-unbound
+))))
395 (lambda (class instance slotd
)
396 (declare (ignore class instance
))
397 (instance-structure-protocol-error slotd
398 'slot-boundp-using-class
))))))
400 (defun get-accessor-from-svuc-method-function (class slotd sdfun name
)
401 (macrolet ((emf-funcall (emf &rest args
)
402 `(invoke-effective-method-function ,emf nil
403 :required-args
,args
)))
406 (reader (lambda (instance)
407 (emf-funcall sdfun class instance slotd
)))
408 (writer (lambda (nv instance
)
409 (emf-funcall sdfun nv class instance slotd
)))
410 (boundp (lambda (instance)
411 (emf-funcall sdfun class instance slotd
))))
412 `(,name
,(class-name class
) ,(slot-definition-name slotd
)))))
414 (defun maybe-class (class-or-name)
415 (when (eq **boot-state
** 'complete
)
416 (if (typep class-or-name
'class
)
418 (find-class class-or-name nil
))))
420 (flet ((make-initargs (slot-name kind method-function
)
421 (let ((initargs (copy-tree method-function
))
422 (slot-names (list slot-name
)))
423 (setf (getf (getf initargs
'plist
) :slot-name-lists
)
425 ((:reader
:boundp
) (list slot-names
))
426 (:writer
(list '() slot-names
))))
429 (defun make-std-reader-method-function (class-or-name slot-name
)
430 (let ((class (maybe-class class-or-name
)))
433 (ecase (slot-access-strategy class slot-name
'reader t
)
435 (make-method-function
437 (pv-binding1 ((bug "Please report this")
438 (instance) (instance-slots))
439 (instance-read-standard
440 .pv. instance-slots
0
441 (slot-value instance slot-name
))))))
443 (make-method-function
445 (pv-binding1 ((bug "Please report this")
447 (instance-read-custom .pv.
0 instance
)))))))))
449 (defun make-std-writer-method-function (class-or-name slot-name
)
450 (let ((class (maybe-class class-or-name
)))
453 (ecase (slot-access-strategy class slot-name
'writer t
)
455 (macrolet ((writer-method-function (safe)
456 `(make-method-function
457 (lambda (nv instance
)
458 (pv-binding1 ((bug "Please report this")
459 (instance) (instance-slots))
460 (instance-write-standard
461 .pv. instance-slots
0 nv
462 (setf (slot-value instance slot-name
)
464 ,@(when safe
'(nil t
))))))))
465 (if (and class
(safe-p class
))
466 (writer-method-function t
)
467 (writer-method-function nil
))))
469 (make-method-function
470 (lambda (nv instance
)
471 (pv-binding1 ((bug "Please report this")
473 (instance-write-custom .pv.
0 instance nv
)))))))))
475 (defun make-std-boundp-method-function (class-or-name slot-name
)
476 (let ((class (maybe-class class-or-name
)))
479 (ecase (slot-access-strategy class slot-name
'boundp t
)
481 (make-method-function
483 (pv-binding1 ((bug "Please report this")
484 (instance) (instance-slots))
485 (instance-boundp-standard
486 .pv. instance-slots
0
487 (slot-boundp instance slot-name
))))))
489 (make-method-function
491 (pv-binding1 ((bug "Please report this")
493 (instance-boundp-custom .pv.
0 instance
))))))))))
495 ;;;; FINDING SLOT DEFINITIONS
497 ;;; Historical PCL found slot definitions by iterating over
498 ;;; CLASS-SLOTS, which is O(N) for number of slots, and moreover
499 ;;; requires a GF call (for SLOT-DEFINITION-NAME) for each slot in
500 ;;; list up to the desired one.
502 ;;; Current SBCL hashes the effective slot definitions, and some
503 ;;; information pulled out from them into a simple-vector, with bucket
504 ;;; chains made out of plists keyed by the slot names. This fixes
505 ;;; gives O(1) performance, and avoid the GF calls.
507 ;;; MAKE-SLOT-TABLE constructs the hashed vector out of a list of
508 ;;; effective slot definitions and the class they pertain to, and
509 ;;; FIND-SLOT-DEFINITION knows how to look up slots in that vector.
511 ;;; The only bit of cleverness in the implementation is to make the
512 ;;; vectors fairly tight, but always longer then 0 elements:
514 ;;; -- We don't want to waste huge amounts of space no these vectors,
515 ;;; which are mostly required by things like SLOT-VALUE with a
516 ;;; variable slot name, so a constant extension over the minimum
517 ;;; size seems like a good choise.
519 ;;; -- As long as the vector always has a length > 0
520 ;;; FIND-SLOT-DEFINITION doesn't need to handle the rare case of an
521 ;;; empty vector separately: it just returns a NIL.
523 ;;; In addition to the slot-definition we also store the slot-location
524 ;;; and type-check function for instances of standard metaclasses, so
525 ;;; that SLOT-VALUE &co using variable slot names can get at them
526 ;;; without additional GF calls.
529 ;;; It would also be nice to have STANDARD-INSTANCE-STRUCTURE-P
530 ;;; generic instead of checking versus STANDARD-CLASS and
531 ;;; FUNCALLABLE-STANDARD-CLASS.
533 ;;; Uh, the comments above talking about how FIND-SLOT-DEFINITION
534 ;;; does something with slot vectors has no basis in reality.
535 ;;; Probably the comments need fixing, rather than the code.
537 (defun find-slot-definition (class slot-name
&optional errorp
)
538 (unless (class-finalized-p class
)
539 (or (try-finalize-inheritance class
)
541 (error "Cannot look up slot-definition for ~S in ~S (too early to finalize.)"
543 (return-from find-slot-definition
(values nil nil
)))))
544 (dolist (slotd (class-slots class
)
546 (error "No slot called ~S in ~S." slot-name class
)
548 (when (eq slot-name
(slot-definition-name slotd
))
549 (return (values slotd t
)))))
551 (defun find-slot-cell (wrapper slot-name
)
552 (declare (symbol slot-name
))
553 (declare (optimize (sb-c::insert-array-bounds-checks
0)))
554 (let* ((vector (layout-slot-table wrapper
))
555 (modulus (truly-the index
(svref vector
0)))
556 ;; Can elide the 'else' branch of (OR symbol-hash ensure-symbol-hash)
557 ;; because every symbol in the slot-table already got a nonzero hash.
558 (index (rem (symbol-hash slot-name
) modulus
))
559 (probe (svref vector
(1+ index
))))
560 (declare (simple-vector vector
) (index index
))
561 (cond ((fixnump probe
)
562 (do* ((count (svref vector
(1- (truly-the index probe
))))
563 (end (truly-the index
(+ probe count
)))
566 (declare (index count j
))
567 (when (eq (svref vector j
) slot-name
)
568 (return (svref vector
(truly-the index
(+ j count
)))))))
569 ((eq (car (truly-the list probe
)) slot-name
)
572 (defun make-slot-table (class slots
&optional bootstrap
)
574 ;; *** If changing this empty table value to something else,
575 ;; be sure to make a similar change to MAKE-COLD-LAYOUT in
576 ;; compiler/generic/genesis as well as in DEFSTRUCT LAYOUT.
577 ;; A DEFCONSTANT for this would only transfer the problem
578 ;; to cold-init in a different sort of way. :-(
579 (return-from make-slot-table
#(1 nil
)))
580 (let* ((n (+ (logior (length slots
) 1) 2)) ; an odd divisor is preferred
581 (vector (make-array n
:initial-element nil
)))
582 (flet ((add-to-vector (name slot
)
583 (declare (symbol name
)
584 (optimize (sb-c::insert-array-bounds-checks
0)))
585 (let ((index (rem (ensure-symbol-hash name
) n
)))
586 (setf (svref vector index
)
588 (cons (when (or bootstrap
589 (and (standard-class-p class
)
590 (slot-accessor-std-p slot
'all
)))
592 (early-slot-definition-location slot
)
593 (slot-definition-location slot
)))
596 (early-slot-definition-info slot
)
597 (slot-definition-info slot
))))
598 (svref vector index
))))))
599 (if (eq 'complete
**boot-state
**)
601 (add-to-vector (slot-definition-name slot
) slot
))
603 (add-to-vector (early-slot-definition-name slot
) slot
))))
604 ;; The VECTOR as computed above implements a hash table with chaining.
605 ;; Rather than store chains using cons cells, chains can be stored in the
606 ;; vector itself at the end, with the table entry pointing to another
607 ;; index in the vector. The chain length is stored first, then all keys,
608 ;; then all values. The resulting structure takes less memory than
609 ;; linked lists, and can be scanned faster. As an exception, for lists
610 ;; of length 1, the table cell holds a (key . value) pair directly.
613 ;; number of additional cells needed to represent linked lists
614 ;; as length-prefixed subsequences in the final vector.
615 (loop for cell across vector
616 for count
= (length cell
)
617 sum
(if (<= count
1) 0 (1+ (* count
2))))))
618 (final-vector (make-array final-n
))
619 (data-index (1+ n
))) ; after the hashtable portion of the vector
620 (setf (aref final-vector
0) n
) ; the modulus
621 (dotimes (i n final-vector
)
622 (let ((alist (aref vector i
)))
623 (if (not (cdr alist
)) ; store it in the final vector as-is
624 (setf (aref final-vector
(1+ i
)) (car alist
))
625 (let ((count (length alist
)))
626 ;; Probed cell holds the index of the first symbol.
627 ;; The symbol count precedes the first symbol cell.
628 (setf (aref final-vector
(1+ i
)) (1+ data-index
)
629 (aref final-vector data-index
) count
)
631 (setf (aref final-vector
(incf data-index
)) (car cell
)))
633 (setf (aref final-vector
(incf data-index
)) (cdr cell
)))
634 (incf data-index
))))))))