src/pcl/slots-boot.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3
   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
   8 ;;;; information.
   9
  10 ;;;; copyright information from original PCL sources:
  11 ;;;;
  12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  13 ;;;; All rights reserved.
  14 ;;;;
  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
  18 ;;;; control laws.
  19 ;;;;
  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
  22 ;;;; specification.
  23
  24 (in-package "SB-PCL")
  25 \f
  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)
  36           (ecase method
  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)
  41         (lambda (&rest args)
  42           (error "Nooooo! ~S accidentally invoked on ~S" fun-name args))))
  43
  44 (defun make-structure-slot-boundp-function (slotd)
  45   (declare (ignore slotd))
  46   (named-lambda always-bound (object)
  47     (declare (ignore object))
  48     t))
  49
  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))
  54   (:report
  55    (lambda (c s)
  56      (format s "~@<The slot ~S has neither ~S nor ~S ~
  57                 allocation, so it can't be ~A by the default ~
  58                 ~S method.~@:>"
  59              (instance-structure-protocol-error-slotd c)
  60              :instance :class
  61              (cond
  62                ((member (instance-structure-protocol-error-fun c)
  63                         '(slot-value-using-class slot-boundp-using-class))
  64                 "read")
  65                (t "written"))
  66              (instance-structure-protocol-error-fun c)))))
  67
  68 (defun instance-structure-protocol-error (slotd fun)
  69   (error 'instance-structure-protocol-error
  70          :slotd slotd :fun fun
  71          :references (list `(:amop :generic-function ,fun)
  72                            '(:amop :section (5 5 3)))))
  73
  74 (defun get-optimized-std-accessor-method-function (class slotd name)
  75   (cond
  76     ((structure-class-p class)
  77      (ecase name
  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))))
  83        (ecase name
  84          (reader (slot-info-reader info))
  85          (writer (slot-info-writer info))
  86          (boundp (slot-info-boundp info)))))
  87     (t
  88      (let* ((fsc-p (cond ((standard-class-p class) nil)
  89                          ((funcallable-standard-class-p class) t)
  90                          ((std-class-p class)
  91                           ;; Shouldn't be using the optimized-std-accessors
  92                           ;; in this case.
  93                           #+nil (format t "* warning: ~S ~S~%   ~S~%"
  94                                         name slotd class)
  95                           nil)
  96                          (t (error "~S is not a STANDARD-CLASS." class))))
  97             (slot-name (slot-definition-name slotd))
  98             (location (slot-definition-location slotd))
  99             (function (ecase name
 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,
 106             ;; 2004-07-12
 107             (value (funcall function fsc-p slotd slot-name location)))
 108        (declare (type function function))
 109        (values value (slot-definition-location slotd))))))
 110
 111 (defun make-optimized-std-reader-method-function
 112     (fsc-p slotd slot-name location)
 113   (set-fun-name
 114    (etypecase location
 115      (fixnum
 116       (if fsc-p
 117           (lambda (instance)
 118             (check-obsolete-instance instance)
 119             (let ((value (clos-slots-ref (fsc-instance-slots instance)
 120                                          location)))
 121               (if (eq value +slot-unbound+)
 122                   (values
 123                    (slot-unbound (class-of instance) instance slot-name))
 124                   value)))
 125           (lambda (instance)
 126             (check-obsolete-instance instance)
 127             (let ((value (clos-slots-ref (std-instance-slots instance)
 128                                          location)))
 129               (if (eq value +slot-unbound+)
 130                   (values
 131                    (slot-unbound (class-of instance) instance slot-name))
 132                   value)))))
 133      (cons
 134       (lambda (instance)
 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))
 139               value))))
 140      (null
 141       (lambda (instance)
 142         (declare (ignore instance))
 143         (instance-structure-protocol-error slotd 'slot-value-using-class))))
 144    `(reader ,slot-name)))
 145
 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.
 154                        (fixnum
 155                         (if fsc-p
 156                             (if safe-p
 157                                 (lambda (nv instance)
 158                                   (setf (clos-slots-ref (fsc-instance-slots instance)
 159                                                         location)
 160                                         nv))
 161                                 (lambda (nv instance)
 162                                   (check-obsolete-instance instance)
 163                                   (setf (clos-slots-ref (fsc-instance-slots instance)
 164                                                         location)
 165                                         nv)))
 166                             (if safe-p
 167                                 (lambda (nv instance)
 168                                   (setf (clos-slots-ref (std-instance-slots instance)
 169                                                         location)
 170                                         nv))
 171                                 (lambda (nv instance)
 172                                   (check-obsolete-instance instance)
 173                                   (setf (clos-slots-ref (std-instance-slots instance)
 174                                                         location)
 175                                         nv)))))
 176                        (cons
 177                         (if safe-p
 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))))
 184                        (null
 185                         (lambda (nv instance)
 186                           (declare (ignore nv instance))
 187                           (instance-structure-protocol-error
 188                            slotd
 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))
 202                                   (typecheck
 203                                    (slot-info-typecheck
 204                                     (if (eq wrapper orig-wrapper)
 205                                         info
 206                                         (cdr (find-slot-cell wrapper slot-name))))))
 207                              (when typecheck
 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
 212                       checking-fun
 213                       writer-fun)
 214                   `(writer ,slot-name))))
 215
 216 (defun make-optimized-std-boundp-method-function
 217     (fsc-p slotd slot-name location)
 218   (set-fun-name
 219    (etypecase location
 220      (fixnum (if fsc-p
 221                  (lambda (instance)
 222                    (check-obsolete-instance instance)
 223                    (not (eq (clos-slots-ref (fsc-instance-slots instance)
 224                                             location)
 225                             +slot-unbound+)))
 226                  (lambda (instance)
 227                    (check-obsolete-instance instance)
 228                    (not (eq (clos-slots-ref (std-instance-slots instance)
 229                                             location)
 230                             +slot-unbound+)))))
 231      (cons (lambda (instance)
 232              (check-obsolete-instance instance)
 233              (not (eq (cdr location) +slot-unbound+))))
 234      (null
 235       (lambda (instance)
 236         (declare (ignore instance))
 237         (instance-structure-protocol-error slotd 'slot-boundp-using-class))))
 238    `(boundp ,slot-name)))
 239
 240 (defun make-optimized-structure-slot-value-using-class-method-function
 241     (function)
 242   (declare (type function function))
 243   (lambda (class object slotd)
 244     (declare (ignore class slotd))
 245     (funcall function object)))
 246
 247 (defun make-optimized-structure-setf-slot-value-using-class-method-function
 248     (function)
 249   (declare (type function function))
 250   (lambda (nv class object slotd)
 251     (declare (ignore class slotd))
 252     (funcall function nv object)))
 253
 254 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
 255   (lambda (class object slotd)
 256     (declare (ignore class object slotd))
 257     t))
 258
 259 (defun get-optimized-std-slot-value-using-class-method-function
 260     (class slotd name)
 261   (cond
 262     ((structure-class-p class)
 263      (ecase name
 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)))
 271        (ecase name
 272          (reader
 273           (let ((fun (slot-info-reader info)))
 274             (lambda (class object slotd)
 275               (declare (ignore class slotd))
 276               (funcall fun object))))
 277          (writer
 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))))
 282          (boundp
 283           (let ((fun (slot-info-boundp info)))
 284             (lambda (class object slotd)
 285               (declare (ignore class slotd))
 286               (funcall fun object)))))))
 287     (t
 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))))
 291             (function
 292              (ecase name
 293                (reader
 294                 #'make-optimized-std-slot-value-using-class-method-function)
 295                (writer
 296                 #'make-optimized-std-setf-slot-value-using-class-method-function)
 297                (boundp
 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))))))
 302
 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)))
 306     (etypecase location
 307       (fixnum (if fsc-p
 308                   (lambda (class instance slotd)
 309                     (declare (ignore slotd))
 310                     (check-obsolete-instance instance)
 311                     (let ((value (clos-slots-ref (fsc-instance-slots instance)
 312                                                  location)))
 313                       (if (eq value +slot-unbound+)
 314                           (values (slot-unbound class instance slot-name))
 315                           value)))
 316                   (lambda (class instance slotd)
 317                     (declare (ignore slotd))
 318                     (check-obsolete-instance instance)
 319                     (let ((value (clos-slots-ref (std-instance-slots instance)
 320                                                  location)))
 321                       (if (eq value +slot-unbound+)
 322                           (values (slot-unbound class instance slot-name))
 323                           value)))))
 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))
 330                     value))))
 331       (null
 332        (lambda (class instance slotd)
 333          (declare (ignore class instance))
 334          (instance-structure-protocol-error slotd 'slot-value-using-class))))))
 335
 336 (defun make-optimized-std-setf-slot-value-using-class-method-function
 337     (fsc-p slotd)
 338   (let* ((location (slot-definition-location slotd))
 339          (class (slot-definition-class slotd))
 340          (typecheck
 341           (when (safe-p class)
 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)
 347                     ,@body))
 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.
 352                  `(if typecheck
 353                       (make-mf-lambda
 354                        (funcall (the function typecheck) nv)
 355                        ,@body)
 356                       (make-mf-lambda
 357                        ,@body))))
 358       (etypecase location
 359         (fixnum
 360          (if fsc-p
 361              (make-mf-lambdas
 362               (setf (clos-slots-ref (fsc-instance-slots instance) location)
 363                     nv))
 364              (make-mf-lambdas
 365               (setf (clos-slots-ref (std-instance-slots instance) location)
 366                     nv))))
 367         (cons
 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))))))))
 373
 374 (defun make-optimized-std-slot-boundp-using-class-method-function
 375     (fsc-p slotd)
 376   (let ((location (slot-definition-location slotd)))
 377     (etypecase location
 378       (fixnum
 379        (if fsc-p
 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)
 384                       +slot-unbound+)))
 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)
 389                       +slot-unbound+)))))
 390       (cons (lambda (class instance slotd)
 391               (declare (ignore class slotd))
 392               (check-obsolete-instance instance)
 393               (not (eq (cdr location) +slot-unbound+))))
 394       (null
 395        (lambda (class instance slotd)
 396          (declare (ignore class instance))
 397          (instance-structure-protocol-error slotd
 398                                             'slot-boundp-using-class))))))
 399
 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)))
 404     (set-fun-name
 405      (case name
 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)))))
 413 \f
 414 (defun maybe-class (class-or-name)
 415   (when (eq **boot-state** 'complete)
 416     (if (typep class-or-name 'class)
 417         class-or-name
 418         (find-class class-or-name nil))))
 419
 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)
 424                  (ecase kind
 425                    ((:reader :boundp) (list slot-names))
 426                    (:writer (list '() slot-names))))
 427            initargs)))
 428
 429   (defun make-std-reader-method-function (class-or-name slot-name)
 430     (let ((class (maybe-class class-or-name)))
 431       (make-initargs
 432        slot-name :reader
 433        (ecase (slot-access-strategy class slot-name 'reader t)
 434          (:standard
 435           (make-method-function
 436            (lambda (instance)
 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))))))
 442          ((:custom :accessor)
 443           (make-method-function
 444            (lambda (instance)
 445              (pv-binding1 ((bug "Please report this")
 446                            (instance) nil)
 447                (instance-read-custom .pv. 0 instance)))))))))
 448
 449   (defun make-std-writer-method-function (class-or-name slot-name)
 450     (let ((class (maybe-class class-or-name)))
 451       (make-initargs
 452        slot-name :writer
 453        (ecase (slot-access-strategy class slot-name 'writer t)
 454          (:standard
 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)
 463                                     .good-new-value.)
 464                               ,@(when safe '(nil t))))))))
 465             (if (and class (safe-p class))
 466                 (writer-method-function t)
 467                 (writer-method-function nil))))
 468          ((:custom :accessor)
 469           (make-method-function
 470            (lambda (nv instance)
 471              (pv-binding1 ((bug "Please report this")
 472                            (instance) nil)
 473                (instance-write-custom .pv. 0 instance nv)))))))))
 474
 475   (defun make-std-boundp-method-function (class-or-name slot-name)
 476     (let ((class (maybe-class class-or-name)))
 477       (make-initargs
 478        slot-name :boundp
 479        (ecase (slot-access-strategy class slot-name 'boundp t)
 480          (:standard
 481           (make-method-function
 482            (lambda (instance)
 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))))))
 488          ((:custom :accessor)
 489           (make-method-function
 490            (lambda (instance)
 491              (pv-binding1 ((bug "Please report this")
 492                            (instance) nil)
 493                (instance-boundp-custom .pv. 0 instance))))))))))
 494 \f
 495 ;;;; FINDING SLOT DEFINITIONS
 496 ;;;
 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.
 501 ;;;
 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.
 506 ;;;
 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.
 510 ;;;
 511 ;;; The only bit of cleverness in the implementation is to make the
 512 ;;; vectors fairly tight, but always longer then 0 elements:
 513 ;;;
 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.
 518 ;;;
 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.
 522 ;;;
 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.
 527 ;;;
 528 ;;; Notes:
 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.
 532 ;;;
 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.
 536
 537 (defun find-slot-definition (class slot-name &optional errorp)
 538   (unless (class-finalized-p class)
 539     (or (try-finalize-inheritance class)
 540         (if errorp
 541             (error "Cannot look up slot-definition for ~S in ~S (too early to finalize.)"
 542                    slot-name class)
 543             (return-from find-slot-definition (values nil nil)))))
 544   (dolist (slotd (class-slots class)
 545            (if errorp
 546                (error "No slot called ~S in ~S." slot-name class)
 547                (values nil t)))
 548     (when (eq slot-name (slot-definition-name slotd))
 549       (return (values slotd t)))))
 550
 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)))
 564                  (j probe (1+ j)))
 565                 ((>= j end))
 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)
 570            (cdr probe)))))
 571
 572 (defun make-slot-table (class slots &optional bootstrap)
 573   (unless slots
 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)
 587                      (acons name
 588                             (cons (when (or bootstrap
 589                                             (and (standard-class-p class)
 590                                                  (slot-accessor-std-p slot 'all)))
 591                                     (if bootstrap
 592                                         (early-slot-definition-location slot)
 593                                         (slot-definition-location slot)))
 594                                   (the slot-info
 595                                     (if bootstrap
 596                                         (early-slot-definition-info slot)
 597                                         (slot-definition-info slot))))
 598                             (svref vector index))))))
 599       (if (eq 'complete **boot-state**)
 600           (dolist (slot slots)
 601             (add-to-vector (slot-definition-name slot) slot))
 602           (dolist (slot slots)
 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.
 611     (let* ((final-n
 612             (+ 1 n
 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)
 630                 (dolist (cell alist)
 631                   (setf (aref final-vector (incf data-index)) (car cell)))
 632                 (dolist (cell alist)
 633                   (setf (aref final-vector (incf data-index)) (cdr cell)))
 634                 (incf data-index))))))))