1 ;;;; This file was split out from braid.lisp so that we could do some
2 ;;;; of the work of building the meta-braid at cold initialization
5 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; This software is derived from software originally released by Xerox
9 ;;;; Corporation. Copyright and release statements follow. Later modifications
10 ;;;; to the software are in the public domain and are provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
14 ;;;; copyright information from original PCL sources:
16 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
17 ;;;; All rights reserved.
19 ;;;; Use and copying of this software and preparation of derivative works based
20 ;;;; upon this software are permitted. Any distribution of this software or
21 ;;;; derivative works must comply with all applicable United States export
24 ;;;; This software is made available AS IS, and Xerox Corporation makes no
25 ;;;; warranty about the software, its performance or its conformity to any
30 (declaim (list **standard-method-classes
**))
31 (defglobal **standard-method-classes
** nil
)
33 (defconstant-eqx +standard-method-class-names
+
34 '(standard-method standard-reader-method
35 standard-writer-method
36 global-reader-method global-writer-method
38 global-makunbound-method
)
41 (define-load-time-global *sgf-wrapper
*
42 (!boot-make-wrapper
(!early-class-size
'standard-generic-function
)
43 'standard-generic-function
44 sb-kernel
::funinstance-layout-bitmap
))
47 (defun allocate-standard-instance (wrapper)
48 (let* ((instance (%new-instance wrapper
(1+ sb-vm
:instance-data-start
)))
49 (slots (make-array (layout-length wrapper
) :initial-element
+slot-unbound
+)))
50 (%instance-set instance sb-vm
:instance-data-start slots
)
53 (define-condition unset-funcallable-instance-function
54 (reference-condition simple-error
)
57 :references
'((:amop
:generic-function allocate-instance
)
58 (:amop
:function set-funcallable-instance-function
))))
60 (defmacro error-no-implementation-function
(fin)
61 `(error 'unset-funcallable-instance-function
62 :format-control
"~@<The function of funcallable instance ~
63 ~S has not been set.~@:>"
64 :format-arguments
(list ,fin
)))
66 (defun allocate-standard-funcallable-instance (wrapper name
)
67 (declare (layout wrapper
))
69 ;; Named functions have a predictable hash
70 (mix (sxhash name
) (symbol-hash :generic-function
)) ; arb. constant
71 (sb-kernel::quasi-random-address-based-hash
72 (load-time-value (make-array 1 :element-type
'(and fixnum unsigned-byte
)))
73 most-positive-fixnum
)))
74 (slots (make-array (layout-length wrapper
) :initial-element
+slot-unbound
+))
75 (fin (truly-the funcallable-instance
76 (%make-standard-funcallable-instance
77 slots
#-executable-funinstances hash
))))
78 (setf (%fun-layout fin
) wrapper
)
79 #+executable-funinstances
81 ;; don't know how good our hash is, so use all N-FIXNUM-BITS of it
82 ;; as input to murmur-hash, which should definitely affect all bits,
83 ;; and then take 32 bits of that result.
84 (ldb (byte 32 0) (sb-impl::murmur3-fmix-word hash
))))
85 (sb-sys:with-pinned-objects
(fin)
86 (setf (sb-vm::compact-fsc-instance-hash fin
) 32-bit-hash
)))
87 (setf (%funcallable-instance-fun fin
)
89 (declare (ignore args
))
90 (error-no-implementation-function fin
)))
93 (defun classify-slotds (slotds)
94 (let (instance-slots class-slots custom-slots bootp
)
95 (dolist (slotd slotds
)
96 (let ((alloc (cond ((consp slotd
) ; bootstrap
100 (slot-definition-allocation slotd
)))))
103 (push slotd instance-slots
))
105 (push slotd class-slots
))
107 (push slotd custom-slots
)))))
109 (nreverse instance-slots
)
111 (sort instance-slots
#'< :key
#'slot-definition-location
)))
116 ;;;; BOOTSTRAP-META-BRAID
118 ;;;; This function builds the base metabraid from the early class definitions.
120 (defmacro wrapper-info
(x) `(sb-kernel::layout-%info
,x
))
121 (declaim (inline wrapper-slot-list
))
122 (defun wrapper-slot-list (wrapper)
123 (let ((info (wrapper-info wrapper
)))
124 (if (listp info
) info
)))
125 (defun (setf wrapper-slot-list
) (newval wrapper
)
126 ;; The current value must be a list, otherwise we'd clobber
127 ;; a defstruct-description.
128 (aver (listp (wrapper-info wrapper
)))
129 (setf (wrapper-info wrapper
) newval
))
132 ((with-initial-classes-and-wrappers ((&rest classes
) &body body
)
133 `(let* ((*create-classes-from-internal-structure-definitions-p
* nil
)
134 ,@(mapcar (lambda (class)
135 `(,(symbolicate class
"-WRAPPER")
136 ,(if (eq class
'standard-generic-function
)
138 `(!boot-make-wrapper
(!early-class-size
',class
)
141 ,@(mapcar (lambda (class)
142 `(,class
(allocate-standard-instance
143 ,(if (eq class
'standard-generic-function
)
144 'funcallable-standard-class-wrapper
145 'standard-class-wrapper
))))
147 ,@(mapcan (lambda (class &aux
(wr (symbolicate class
"-WRAPPER")))
148 `((setf (wrapper-class ,wr
) ,class
149 (find-class ',class
) ,class
)))
152 (defun !bootstrap-meta-braid
()
153 (with-initial-classes-and-wrappers
154 (standard-class funcallable-standard-class
155 slot-class system-class built-in-class structure-class condition-class
156 standard-direct-slot-definition standard-effective-slot-definition
157 class-eq-specializer standard-generic-function
)
158 ;; First, make a class metaobject for each of the early classes. For
159 ;; each metaobject we also set its wrapper. Except for the class T,
160 ;; the wrapper is always that of STANDARD-CLASS.
161 (dolist (definition *!early-class-definitions
*)
162 (let* ((name (ecd-class-name definition
))
163 (meta (ecd-metaclass definition
))
165 (slot-class slot-class-wrapper
)
166 (standard-class standard-class-wrapper
)
167 (funcallable-standard-class
168 funcallable-standard-class-wrapper
)
169 (built-in-class built-in-class-wrapper
)
170 (system-class system-class-wrapper
)
171 (structure-class structure-class-wrapper
)
172 (condition-class condition-class-wrapper
)))
173 (class (or (find-class name nil
)
174 (allocate-standard-instance wrapper
))))
175 (setf (find-class name
) class
)))
176 (dolist (definition *!early-class-definitions
*)
177 (let ((name (ecd-class-name definition
))
178 (meta (ecd-metaclass definition
))
179 (source (ecd-source-location definition
))
180 (direct-supers (ecd-superclass-names definition
))
181 (direct-slots (ecd-canonical-slots definition
))
182 (other-initargs (ecd-other-initargs definition
)))
183 (let ((direct-default-initargs
184 (getf other-initargs
:direct-default-initargs
)))
185 (multiple-value-bind (slots cpl default-initargs direct-subclasses
)
186 (!early-collect-inheritance name
)
187 (let* ((class (find-class name
))
188 ;; All funcallable instances have the same bitmap
189 ;; This is checked in verify_range() of gencgc.
190 (bitmap (if (memq name
'(standard-generic-function
191 funcallable-standard-object
193 sb-kernel
::funinstance-layout-bitmap
194 +layout-all-tagged
+))
195 (wrapper (cond ((eq class slot-class
)
197 ((eq class standard-class
)
198 standard-class-wrapper
)
199 ((eq class funcallable-standard-class
)
200 funcallable-standard-class-wrapper
)
201 ((eq class standard-direct-slot-definition
)
202 standard-direct-slot-definition-wrapper
)
204 standard-effective-slot-definition
)
205 standard-effective-slot-definition-wrapper
)
206 ((eq class system-class
) system-class-wrapper
)
207 ((eq class built-in-class
)
208 built-in-class-wrapper
)
209 ((eq class structure-class
)
210 structure-class-wrapper
)
211 ((eq class condition-class
)
212 condition-class-wrapper
)
213 ((eq class class-eq-specializer
)
214 class-eq-specializer-wrapper
)
215 ((eq class standard-generic-function
)
216 standard-generic-function-wrapper
)
218 (!boot-make-wrapper
(length slots
) name bitmap
))))
220 (let ((symbol (make-class-symbol name
)))
221 (when (eq (info :variable
:kind symbol
) :global
)
224 (unless (eq (getf slot
:allocation
:instance
) :instance
)
225 (error "Slot allocation ~S is not supported in bootstrap."
226 (getf slot
:allocation
))))
228 (when (layout-for-pcl-obj-p wrapper
)
229 (setf (wrapper-slot-list wrapper
) slots
))
232 (cond ((eq name t
) nil
)
233 ((eq meta
'funcallable-standard-class
)
234 (allocate-standard-funcallable-instance wrapper name
))
236 (allocate-standard-instance wrapper
))))
239 (!bootstrap-make-slot-definitions
240 name class direct-slots
241 standard-direct-slot-definition-wrapper nil
))
243 (!bootstrap-make-slot-definitions
245 standard-effective-slot-definition-wrapper t
))
247 (setf (layout-slot-table wrapper
) (make-slot-table class slots t
))
248 (when (layout-for-pcl-obj-p wrapper
)
249 (setf (wrapper-slot-list wrapper
) slots
))
252 ((standard-class funcallable-standard-class
)
253 (!bootstrap-initialize-class
255 class name class-eq-specializer-wrapper source
256 direct-supers direct-subclasses cpl wrapper proto
257 direct-slots slots direct-default-initargs default-initargs
))
258 (built-in-class ; *the-class-t*
259 (!bootstrap-initialize-class
261 class name class-eq-specializer-wrapper source
262 direct-supers direct-subclasses cpl wrapper proto
))
264 (!bootstrap-initialize-class
266 class name class-eq-specializer-wrapper source
267 direct-supers direct-subclasses cpl wrapper proto
))
268 (slot-class ; *the-class-slot-object*
269 (!bootstrap-initialize-class
271 class name class-eq-specializer-wrapper source
272 direct-supers direct-subclasses cpl wrapper proto
))
273 (structure-class ; *the-class-structure-object*
274 (!bootstrap-initialize-class
276 class name class-eq-specializer-wrapper source
277 direct-supers direct-subclasses cpl wrapper
))
279 (!bootstrap-initialize-class
281 class name class-eq-specializer-wrapper source
282 direct-supers direct-subclasses cpl wrapper
))))))))
284 (setq **standard-method-classes
**
285 (mapcar (lambda (name)
286 (symbol-value (make-class-symbol name
)))
287 +standard-method-class-names
+))
289 (flet ((make-method-combination (class-name)
290 (let* ((class (find-class class-name
))
291 (wrapper (!bootstrap-get-slot
292 'standard-class class
'wrapper
))
293 (instance (allocate-standard-instance wrapper
)))
294 (flet ((set-slot (name value
)
295 (!bootstrap-set-slot class-name instance name value
)))
296 (values instance
#'set-slot
)))))
297 ;; Create the STANDARD method combination object.
298 (multiple-value-bind (method-combination set-slot
)
299 (make-method-combination 'standard-method-combination
)
300 (funcall set-slot
'source nil
)
301 (funcall set-slot
'type-name
'standard
)
302 (funcall set-slot
'options
'())
303 (funcall set-slot
'%generic-functions
(make-gf-hashset))
304 (funcall set-slot
'%documentation
"The standard method combination.")
305 (setq *standard-method-combination
* method-combination
))
306 ;; Create an OR method combination object.
307 (multiple-value-bind (method-combination set-slot
)
308 (make-method-combination 'short-method-combination
)
309 (funcall set-slot
'source
'nil
)
310 (funcall set-slot
'type-name
'or
)
311 (funcall set-slot
'operator
'or
)
312 (funcall set-slot
'identity-with-one-argument t
)
313 (funcall set-slot
'%generic-functions
(make-gf-hashset))
314 (funcall set-slot
'%documentation nil
)
315 (funcall set-slot
'options
'(:most-specific-first
))
316 (setq *or-method-combination
* method-combination
))))))
318 (defun !bootstrap-built-in-classes
()
320 ;; First make sure that all the supers listed in
321 ;; *BUILT-IN-CLASS-LATTICE* are themselves defined by
322 ;; *BUILT-IN-CLASS-LATTICE*. This is just to check for typos and
323 ;; other sorts of brainos. (The exceptions, T and SEQUENCE, are
324 ;; those classes which are SYSTEM-CLASSes which nevertheless have
325 ;; BUILT-IN-CLASS subclasses.)
326 (dolist (e *built-in-classes
*)
327 (dolist (super (cadr e
))
328 (unless (or (eq super t
)
330 (assq super
*built-in-classes
*))
331 (error "in *BUILT-IN-CLASSES*: ~S has ~S as a super,~%~
332 but ~S is not itself a class in *BUILT-IN-CLASSES*."
333 (car e
) super super
))))
335 ;; In the first pass, we create a skeletal object to be bound to the
337 (let* ((built-in-class (find-class 'built-in-class
))
338 (built-in-class-wrapper (!bootstrap-get-slot
'standard-class built-in-class
'wrapper
)))
339 (dolist (e *built-in-classes
*)
340 (let ((class (allocate-standard-instance built-in-class-wrapper
)))
341 (setf (find-class (car e
)) class
))))
343 ;; In the second pass, we initialize the class objects.
344 (let ((class-eq-wrapper (!bootstrap-get-slot
'standard-class
(find-class 'class-eq-specializer
) 'wrapper
)))
345 (dolist (e *built-in-classes
*)
346 (destructuring-bind (name supers subs cpl prototype
) e
347 (let* ((class (find-class name
))
348 (lclass (find-classoid name
))
349 (wrapper (classoid-layout lclass
)))
350 (setf (classoid-pcl-class lclass
) class
)
352 (!bootstrap-initialize-class
'built-in-class class
353 name class-eq-wrapper nil
356 wrapper prototype
))))))
358 ;;; I have no idea why we care so much about being able to create an instance
359 ;;; of STRUCTURE-OBJECT, when (almost) no other structure class in the system
360 ;;; begins life such that MAKE-INSTANCE works on it.
361 ;;; And ALLOCATE-INSTANCE seems to work fine anyway. e.g. you can call
362 ;;; (ALLOCATE-INSTANCE (FIND-CLASS 'HASH-TABLE)).
363 ;;; Anyway, see below in !BOOTSTRAP-INITIALIZE-CLASS where we refer to
364 ;;; the name of this seemingly useless constructor function.
365 (defun |STRUCTURE-OBJECT class constructor|
()
366 (sb-kernel:%make-structure-instance
367 #.
(sb-kernel:find-defstruct-description
'structure-object
)
370 ;;; Initialize a class metaobject.
371 (defun !bootstrap-initialize-class
372 (metaclass-name class name
373 class-eq-wrapper source direct-supers direct-subclasses cpl wrapper
376 direct-slots slots direct-default-initargs default-initargs
)
377 (flet ((classes (names) (mapcar #'find-class names
))
378 (set-slot (slot-name value
)
379 (!bootstrap-set-slot metaclass-name class slot-name value
)))
380 (set-slot 'name name
)
381 (set-slot 'finalized-p t
)
382 (set-slot 'source source
)
383 (set-slot 'safe-p nil
)
384 (set-slot '%type
(if (eq class
(find-class t
))
386 ;; FIXME: Could this just be CLASS instead
387 ;; of `(CLASS ,CLASS)? If not, why not?
388 ;; (See also similar expression in
389 ;; SHARED-INITIALIZE :BEFORE (CLASS).)
391 (set-slot 'class-eq-specializer
392 (let ((spec (allocate-standard-instance class-eq-wrapper
)))
393 (!bootstrap-set-slot
'class-eq-specializer spec
'%type
395 (!bootstrap-set-slot
'class-eq-specializer spec
'object
398 (set-slot '%class-precedence-list
(classes cpl
))
399 (set-slot 'cpl-available-p t
)
400 (set-slot 'can-precede-list
(classes (cdr cpl
)))
401 (set-slot 'incompatible-superclass-list nil
)
402 (set-slot 'direct-superclasses
(classes direct-supers
))
403 (set-slot 'direct-subclasses
(classes direct-subclasses
))
404 (set-slot 'direct-methods
(cons nil nil
))
405 (set-slot 'wrapper wrapper
)
406 (set-slot '%documentation nil
)
408 `(,@(and direct-default-initargs
409 `(direct-default-initargs ,direct-default-initargs
))
410 ,@(and default-initargs
411 `(default-initargs ,default-initargs
))))
412 (when (memq metaclass-name
'(standard-class funcallable-standard-class
413 structure-class condition-class
415 (set-slot 'direct-slots direct-slots
)
416 (set-slot 'slots slots
)
417 (setf (layout-slot-table wrapper
)
418 (make-slot-table class slots
419 (member metaclass-name
420 '(standard-class funcallable-standard-class
))))
421 (when (layout-for-pcl-obj-p wrapper
)
422 (setf (wrapper-slot-list wrapper
) slots
)))
424 ;; For all direct superclasses SUPER of CLASS, make sure CLASS is
425 ;; a direct subclass of SUPER. Note that METACLASS-NAME doesn't
426 ;; matter here for the slot DIRECT-SUBCLASSES, since every class
427 ;; inherits the slot from class CLASS.
428 (dolist (super direct-supers
)
429 (let* ((super (find-class super
))
430 (subclasses (!bootstrap-get-slot metaclass-name super
431 'direct-subclasses
)))
432 (cond ((unbound-marker-p subclasses
)
433 (!bootstrap-set-slot metaclass-name super
'direct-subclasses
435 ((not (memq class subclasses
))
436 (!bootstrap-set-slot metaclass-name super
'direct-subclasses
437 (cons class subclasses
))))))
442 (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|
))
443 (set-slot 'defstruct-form
444 `(defstruct (structure-object (:constructor
447 (set-slot 'defstruct-constructor constructor-sym
)
448 (set-slot 'from-defclass-p t
)
449 (set-slot 'plist nil
)
450 (set-slot 'prototype
(funcall constructor-sym
))))
453 (set-slot 'prototype
(make-condition name
)))
456 (unless (eq name
't
) (set-slot 'prototype proto
))))
459 (defun !bootstrap-make-slot-definitions
(name class slots wrapper effective-p
)
461 (mapcar (lambda (slot)
463 (!bootstrap-make-slot-definition
464 name class slot wrapper effective-p index
))
467 (defun !bootstrap-make-slot-definition
468 (name class slot wrapper effective-p index
)
469 (let* ((slotd-class-name (if effective-p
470 'standard-effective-slot-definition
471 'standard-direct-slot-definition
))
472 (slotd (allocate-standard-instance wrapper
))
473 (slot-name (getf slot
:name
)))
474 (flet ((get-val (name) (getf slot name
))
476 (!bootstrap-set-slot slotd-class-name slotd name val
)))
477 (set-val 'name slot-name
)
478 (set-val 'initform
(get-val :initform
))
479 (set-val 'initfunction
(get-val :initfunction
))
480 (set-val 'initargs
(get-val :initargs
))
482 (set-val 'readers
(get-val :readers
))
483 (set-val 'writers
(get-val :writers
)))
484 (set-val 'allocation
:instance
)
485 (set-val '%type
(or (get-val :type
) t
))
486 (set-val '%documentation
(or (get-val :documentation
) ""))
487 (set-val '%class class
)
489 (set-val 'location index
)
490 (set-val 'accessor-flags
7)
495 (make-optimized-std-reader-method-function nil nil slot-name index
)
497 (make-optimized-std-writer-method-function nil nil slot-name index
)
499 (make-optimized-std-boundp-method-function nil nil slot-name index
)
501 (make-optimized-std-makunbound-method-function nil nil slot-name index
))))
502 (when (and (eq name
'standard-class
)
503 (eq slot-name
'slots
) effective-p
)
504 (setq *the-eslotd-standard-class-slots
* slotd
))
505 (when (and (eq name
'funcallable-standard-class
)
506 (eq slot-name
'slots
) effective-p
)
507 (setq *the-eslotd-funcallable-standard-class-slots
* slotd
))
510 ;;;; from slots-boot.lisp
512 (defun make-optimized-std-reader-method-function
513 (fsc-p slotd slot-name location
)
519 (check-obsolete-instance instance
)
520 (let ((value (clos-slots-ref (fsc-instance-slots instance
)
522 (if (unbound-marker-p value
)
524 (slot-unbound (class-of instance
) instance slot-name
))
527 (check-obsolete-instance instance
)
528 (let ((value (clos-slots-ref (std-instance-slots instance
)
530 (if (unbound-marker-p value
)
532 (slot-unbound (class-of instance
) instance slot-name
))
536 (check-obsolete-instance instance
)
537 (let ((value (cdr location
)))
538 (if (unbound-marker-p value
)
539 (values (slot-unbound (class-of instance
) instance slot-name
))
543 (declare (ignore instance
))
544 (instance-structure-protocol-error slotd
'slot-value-using-class
))))
545 `(reader ,slot-name
)))
547 (defun make-optimized-std-writer-method-function (fsc-p slotd slot-name location
)
548 ;; The (WHEN SLOTD ...) gunk is for building early slot definitions.
549 (let* ((class (when slotd
(slot-definition-class slotd
)))
550 (safe-p (when slotd
(safe-p class
)))
551 (orig-wrapper (when safe-p
(class-wrapper class
)))
552 (info (when safe-p
(slot-definition-info slotd
)))
553 (writer-fun (etypecase location
554 ;; In SAFE-P case the typechecking already validated the instance.
558 (lambda (nv instance
)
559 (setf (clos-slots-ref (fsc-instance-slots instance
)
562 (lambda (nv instance
)
563 (check-obsolete-instance instance
)
564 (setf (clos-slots-ref (fsc-instance-slots instance
)
568 (lambda (nv instance
)
569 (setf (clos-slots-ref (std-instance-slots instance
)
572 (lambda (nv instance
)
573 (check-obsolete-instance instance
)
574 (setf (clos-slots-ref (std-instance-slots instance
)
579 (lambda (nv instance
)
580 (declare (ignore instance
))
581 (setf (cdr location
) nv
))
582 (lambda (nv instance
)
583 (check-obsolete-instance instance
)
584 (setf (cdr location
) nv
))))
586 (lambda (nv instance
)
587 (declare (ignore nv instance
))
588 (instance-structure-protocol-error
590 '(setf slot-value-using-class
))))))
591 (checking-fun (when safe-p
592 (lambda (new-value instance
)
593 ;; If we have a TYPE-CHECK-FUNCTION, call it.
594 (let* (;; Note that the class of INSTANCE here is not
595 ;; neccessarily the SLOT-DEFINITION-CLASS of
596 ;; the SLOTD passed to M-O-S-W-M-F, since it's
597 ;; e.g. possible for a subclass to define a
598 ;; slot of the same name but with no
599 ;; accessors. So we may need to fetch the
600 ;; right SLOT-INFO from the wrapper instead of
601 ;; just closing over it.
602 (wrapper (valid-wrapper-of instance
))
605 (if (eq wrapper orig-wrapper
)
607 (cdr (find-slot-cell wrapper slot-name
))))))
609 (setf new-value
(funcall typecheck new-value
))))
610 ;; Then call the real writer.
611 (funcall writer-fun new-value instance
)))))
612 (set-fun-name (if safe-p
615 `(writer ,slot-name
))))
617 (defun make-optimized-std-boundp-method-function
618 (fsc-p slotd slot-name location
)
623 (check-obsolete-instance instance
)
624 (not (unbound-marker-p (clos-slots-ref (fsc-instance-slots instance
)
627 (check-obsolete-instance instance
)
628 (not (unbound-marker-p (clos-slots-ref (std-instance-slots instance
)
630 (cons (lambda (instance)
631 (check-obsolete-instance instance
)
632 (not (unbound-marker-p (cdr location
)))))
635 (declare (ignore instance
))
636 (instance-structure-protocol-error slotd
'slot-boundp-using-class
))))
637 `(boundp ,slot-name
)))
639 (defun make-optimized-std-makunbound-method-function
640 (fsc-p slotd slot-name location
)
645 (check-obsolete-instance instance
)
646 (setf (clos-slots-ref (fsc-instance-slots instance
) location
)
650 (check-obsolete-instance instance
)
651 (setf (clos-slots-ref (std-instance-slots instance
) location
)
654 (cons (lambda (instance)
655 (check-obsolete-instance instance
)
656 (setf (cdr location
) +slot-unbound
+)
660 (declare (ignore instance
))
661 (instance-structure-protocol-error slotd
'slot-makunbound-using-class
))))
662 `(makunbound ,slot-name
)))
664 ;;;; FINDING SLOT DEFINITIONS
666 ;;; Historical PCL found slot definitions by iterating over
667 ;;; CLASS-SLOTS, which is O(N) for number of slots, and moreover
668 ;;; requires a GF call (for SLOT-DEFINITION-NAME) for each slot in
669 ;;; list up to the desired one.
671 ;;; Current SBCL hashes the effective slot definitions, and some
672 ;;; information pulled out from them into a simple-vector, with bucket
673 ;;; chains made out of plists keyed by the slot names. This fixes
674 ;;; gives O(1) performance, and avoid the GF calls.
676 ;;; MAKE-SLOT-TABLE constructs the hashed vector out of a list of
677 ;;; effective slot definitions and the class they pertain to, and
678 ;;; FIND-SLOT-DEFINITION knows how to look up slots in that vector.
680 ;;; The only bit of cleverness in the implementation is to make the
681 ;;; vectors fairly tight, but always longer then 0 elements:
683 ;;; -- We don't want to waste huge amounts of space no these vectors,
684 ;;; which are mostly required by things like SLOT-VALUE with a
685 ;;; variable slot name, so a constant extension over the minimum
686 ;;; size seems like a good choise.
688 ;;; -- As long as the vector always has a length > 0
689 ;;; FIND-SLOT-DEFINITION doesn't need to handle the rare case of an
690 ;;; empty vector separately: it just returns a NIL.
692 ;;; In addition to the slot-definition we also store the slot-location
693 ;;; and type-check function for instances of standard metaclasses, so
694 ;;; that SLOT-VALUE &co using variable slot names can get at them
695 ;;; without additional GF calls.
698 ;;; It would also be nice to have STANDARD-INSTANCE-STRUCTURE-P
699 ;;; generic instead of checking versus STANDARD-CLASS and
700 ;;; FUNCALLABLE-STANDARD-CLASS.
702 ;;; Uh, the comments above talking about how FIND-SLOT-DEFINITION
703 ;;; does something with slot vectors has no basis in reality.
704 ;;; Probably the comments need fixing, rather than the code.
706 (defun find-slot-definition (class slot-name
&optional errorp
)
707 (unless (class-finalized-p class
)
708 (or (try-finalize-inheritance class
)
710 (error "Cannot look up slot-definition for ~S in ~S (too early to finalize.)"
712 (return-from find-slot-definition
(values nil nil
)))))
713 (dolist (slotd (class-slots class
)
715 (error "No slot called ~S in ~S." slot-name class
)
717 (when (eq slot-name
(slot-definition-name slotd
))
718 (return (values slotd t
)))))
720 (defun find-slot-cell (wrapper slot-name
)
721 (declare (symbol slot-name
))
722 (declare (optimize (sb-c:insert-array-bounds-checks
0)))
723 (let* ((vector (layout-slot-table wrapper
))
724 (modulus (truly-the index
(svref vector
0)))
725 (index (rem (symbol-hash slot-name
) modulus
))
726 (probe (svref vector
(1+ index
))))
727 (declare (simple-vector vector
) (index index
))
728 (cond ((fixnump probe
)
729 (do* ((count (svref vector
(1- (truly-the index probe
))))
730 (end (truly-the index
(+ probe count
)))
733 (declare (index count j
))
734 (when (eq (svref vector j
) slot-name
)
735 (return (svref vector
(truly-the index
(+ j count
)))))))
736 ((eq (car (truly-the list probe
)) slot-name
)
739 ;;; TODO: this should just be a call to MAKE-HASH-BASED-SLOT-MAPPER.
740 (defun make-slot-table (class slots
&optional bootstrap
)
742 ;; *** If changing this empty table value to something else,
743 ;; be sure to make a similar change to MAKE-COLD-LAYOUT in
744 ;; compiler/generic/genesis as well as in DEFSTRUCT LAYOUT.
745 ;; A DEFCONSTANT for this would only transfer the problem
746 ;; to cold-init in a different sort of way. :-(
747 (return-from make-slot-table
#(1 nil
)))
748 (let* ((n (+ (logior (length slots
) 1) 2)) ; an odd divisor is preferred
749 (vector (make-array n
:initial-element nil
)))
750 (flet ((add-to-vector (name slot
)
751 (declare (symbol name
)
752 (optimize (sb-c:insert-array-bounds-checks
0)))
753 (let ((index (rem (symbol-hash name
) n
)))
754 (setf (svref vector index
)
756 (cons (when (or bootstrap
757 (and (or (standard-class-p class
)
758 (funcallable-standard-class-p class
))
759 (slot-accessor-std-p slot
'all
)))
761 (early-slot-definition-location slot
)
762 (slot-definition-location slot
)))
765 (early-slot-definition-info slot
)
766 (slot-definition-info slot
))))
767 (svref vector index
))))))
768 (if (eq 'complete
**boot-state
**)
770 (add-to-vector (slot-definition-name slot
) slot
))
772 (add-to-vector (early-slot-definition-name slot
) slot
))))
773 ;; The VECTOR as computed above implements a hash table with chaining.
774 ;; Rather than store chains using cons cells, chains can be stored in the
775 ;; vector itself at the end, with the table entry pointing to another
776 ;; index in the vector. The chain length is stored first, then all keys,
777 ;; then all values. The resulting structure takes less memory than
778 ;; linked lists, and can be scanned faster. As an exception, for lists
779 ;; of length 1, the table cell holds a (key . value) pair directly.
782 ;; number of additional cells needed to represent linked lists
783 ;; as length-prefixed subsequences in the final vector.
784 (loop for cell across vector
785 for count
= (length cell
)
786 sum
(if (<= count
1) 0 (1+ (* count
2))))))
787 (final-vector (make-array final-n
))
788 (data-index (1+ n
))) ; after the hashtable portion of the vector
789 (setf (aref final-vector
0) n
) ; the modulus
790 (dotimes (i n final-vector
)
791 (let ((alist (aref vector i
)))
792 (if (not (cdr alist
)) ; store it in the final vector as-is
793 (setf (aref final-vector
(1+ i
)) (car alist
))
794 (let ((count (length alist
)))
795 ;; Probed cell holds the index of the first symbol.
796 ;; The symbol count precedes the first symbol cell.
797 (setf (aref final-vector
(1+ i
)) (1+ data-index
)
798 (aref final-vector data-index
) count
)
800 (setf (aref final-vector
(incf data-index
)) (car cell
)))
802 (setf (aref final-vector
(incf data-index
)) (cdr cell
)))
803 (incf data-index
))))))))
806 ;;;; initialize the initial class hierarchy
808 (!bootstrap-meta-braid
)
809 (!bootstrap-built-in-classes
)