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 (let ((reader-specializers '(slot-object))
  27       (writer-specializers '(t slot-object)))
  28   (defun ensure-accessor (fun-name) ; Make FUN-NAME exist as a GF if it doesn't
  29     (destructuring-bind (slot-name type) (cddr fun-name)
  30       (multiple-value-bind (lambda-list specializers method-class initargs doc)
  31           (ecase type
  32             ;; FIXME: change SLOT-OBJECT here to T to get SLOT-MISSING
  33             ;; behaviour for non-slot-objects too?
  34             (reader
  35              (values '(object) reader-specializers 'global-reader-method
  36                      (make-std-reader-method-function 'slot-object slot-name)
  37                      "automatically-generated reader method"))
  38             (writer
  39              (values '(new-value object) writer-specializers
  40                      'global-writer-method
  41                      (make-std-writer-method-function 'slot-object slot-name)
  42                      "automatically-generated writer method"))
  43             (boundp
  44              (values '(object) reader-specializers 'global-boundp-method
  45                      (make-std-boundp-method-function 'slot-object slot-name)
  46                      "automatically-generated boundp method")))
  47         (let ((gf (ensure-generic-function fun-name :lambda-list lambda-list)))
  48           (add-method gf (make-a-method method-class
  49                                         () lambda-list specializers
  50                                         initargs doc :slot-name slot-name))))))
  51   ;; KLUDGE: this is maybe PCL bootstrap mechanism #6 or #7, invented
  52   ;; by CSR in June 2007.  Making the bootstrap sane is getting higher
  53   ;; on the "TODO: URGENT" list.
  54   (defun !fix-ensure-accessor-specializers ()
  55     (setf reader-specializers (mapcar #'find-class reader-specializers))
  56     (setf writer-specializers (mapcar #'find-class writer-specializers))))
  57
  58 (defun make-structure-slot-boundp-function (slotd)
  59   (declare (ignore slotd))
  60   (named-lambda always-bound (object)
  61     (declare (ignore object))
  62     t))
  63
  64 (define-condition instance-structure-protocol-error
  65     (reference-condition error)
  66   ((slotd :initarg :slotd :reader instance-structure-protocol-error-slotd)
  67    (fun :initarg :fun :reader instance-structure-protocol-error-fun))
  68   (:report
  69    (lambda (c s)
  70      (format s "~@<The slot ~S has neither ~S nor ~S ~
  71                 allocation, so it can't be ~A by the default ~
  72                 ~S method.~@:>"
  73              (instance-structure-protocol-error-slotd c)
  74              :instance :class
  75              (cond
  76                ((member (instance-structure-protocol-error-fun c)
  77                         '(slot-value-using-class slot-boundp-using-class))
  78                 "read")
  79                (t "written"))
  80              (instance-structure-protocol-error-fun c)))))
  81
  82 (defun instance-structure-protocol-error (slotd fun)
  83   (error 'instance-structure-protocol-error
  84          :slotd slotd :fun fun
  85          :references (list `(:amop :generic-function ,fun)
  86                            '(:amop :section (5 5 3)))))
  87
  88 (defun get-optimized-std-accessor-method-function (class slotd name)
  89   (cond
  90     ((structure-class-p class)
  91      (ecase name
  92        (reader (slot-definition-internal-reader-function slotd))
  93        (writer (slot-definition-internal-writer-function slotd))
  94        (boundp (make-structure-slot-boundp-function slotd))))
  95     ((condition-class-p class)
  96      (let ((info (the slot-info (slot-definition-info slotd))))
  97        (ecase name
  98          (reader (slot-info-reader info))
  99          (writer (slot-info-writer info))
 100          (boundp (slot-info-boundp info)))))
 101     (t
 102      (let* ((fsc-p (cond ((standard-class-p class) nil)
 103                          ((funcallable-standard-class-p class) t)
 104                          ((std-class-p class)
 105                           ;; Shouldn't be using the optimized-std-accessors
 106                           ;; in this case.
 107                           #+nil (format t "* warning: ~S ~S~%   ~S~%"
 108                                         name slotd class)
 109                           nil)
 110                          (t (error "~S is not a STANDARD-CLASS." class))))
 111             (slot-name (slot-definition-name slotd))
 112             (location (slot-definition-location slotd))
 113             (function (ecase name
 114                         (reader #'make-optimized-std-reader-method-function)
 115                         (writer #'make-optimized-std-writer-method-function)
 116                         (boundp #'make-optimized-std-boundp-method-function)))
 117             ;; KLUDGE: we need this slightly hacky calling convention
 118             ;; for these functions for bootstrapping reasons: see
 119             ;; !BOOTSTRAP-MAKE-SLOT-DEFINITION in braid.lisp.  -- CSR,
 120             ;; 2004-07-12
 121             (value (funcall function fsc-p slotd slot-name location)))
 122        (declare (type function function))
 123        (values value (slot-definition-location slotd))))))
 124
 125 (defun make-optimized-std-reader-method-function
 126     (fsc-p slotd slot-name location)
 127   (set-fun-name
 128    (etypecase location
 129      (fixnum
 130       (if fsc-p
 131           (lambda (instance)
 132             (check-obsolete-instance instance)
 133             (let ((value (clos-slots-ref (fsc-instance-slots instance)
 134                                          location)))
 135               (if (eq value +slot-unbound+)
 136                   (values
 137                    (slot-unbound (class-of instance) instance slot-name))
 138                   value)))
 139           (lambda (instance)
 140             (check-obsolete-instance instance)
 141             (let ((value (clos-slots-ref (std-instance-slots instance)
 142                                          location)))
 143               (if (eq value +slot-unbound+)
 144                   (values
 145                    (slot-unbound (class-of instance) instance slot-name))
 146                   value)))))
 147      (cons
 148       (lambda (instance)
 149         (check-obsolete-instance instance)
 150         (let ((value (cdr location)))
 151           (if (eq value +slot-unbound+)
 152               (values (slot-unbound (class-of instance) instance slot-name))
 153               value))))
 154      (null
 155       (lambda (instance)
 156         (declare (ignore instance))
 157         (instance-structure-protocol-error slotd 'slot-value-using-class))))
 158    `(reader ,slot-name)))
 159
 160 (defun make-optimized-std-writer-method-function (fsc-p slotd slot-name location)
 161   ;; The (WHEN SLOTD ...) gunk is for building early slot definitions.
 162   (let* ((class (when slotd (slot-definition-class slotd)))
 163          (safe-p (when slotd (safe-p class)))
 164          (orig-wrapper (when safe-p (class-wrapper class)))
 165          (info (when safe-p (slot-definition-info slotd)))
 166          (writer-fun (etypecase location
 167                        ;; In SAFE-P case the typechecking already validated the instance.
 168                        (fixnum
 169                         (if fsc-p
 170                             (if safe-p
 171                                 (lambda (nv instance)
 172                                   (setf (clos-slots-ref (fsc-instance-slots instance)
 173                                                         location)
 174                                         nv))
 175                                 (lambda (nv instance)
 176                                   (check-obsolete-instance instance)
 177                                   (setf (clos-slots-ref (fsc-instance-slots instance)
 178                                                         location)
 179                                         nv)))
 180                             (if safe-p
 181                                 (lambda (nv instance)
 182                                   (setf (clos-slots-ref (std-instance-slots instance)
 183                                                         location)
 184                                         nv))
 185                                 (lambda (nv instance)
 186                                   (check-obsolete-instance instance)
 187                                   (setf (clos-slots-ref (std-instance-slots instance)
 188                                                         location)
 189                                         nv)))))
 190                        (cons
 191                         (if safe-p
 192                             (lambda (nv instance)
 193                               (declare (ignore instance))
 194                               (setf (cdr location) nv))
 195                             (lambda (nv instance)
 196                               (check-obsolete-instance instance)
 197                               (setf (cdr location) nv))))
 198                        (null
 199                         (lambda (nv instance)
 200                           (declare (ignore nv instance))
 201                           (instance-structure-protocol-error
 202                            slotd
 203                            '(setf slot-value-using-class))))))
 204          (checking-fun (when safe-p
 205                          (lambda (new-value instance)
 206                            ;; If we have a TYPE-CHECK-FUNCTION, call it.
 207                            (let* (;; Note that the class of INSTANCE here is not
 208                                   ;; neccessarily the SLOT-DEFINITION-CLASS of
 209                                   ;; the SLOTD passed to M-O-S-W-M-F, since it's
 210                                   ;; e.g. possible for a subclass to define a
 211                                   ;; slot of the same name but with no
 212                                   ;; accessors. So we may need to fetch the
 213                                   ;; right SLOT-INFO from the wrapper instead of
 214                                   ;; just closing over it.
 215                                   (wrapper (valid-wrapper-of instance))
 216                                   (typecheck
 217                                    (slot-info-typecheck
 218                                     (if (eq wrapper orig-wrapper)
 219                                         info
 220                                         (cdr (find-slot-cell wrapper slot-name))))))
 221                              (when typecheck
 222                                (funcall typecheck new-value)))
 223                            ;; Then call the real writer.
 224                            (funcall writer-fun new-value instance)))))
 225     (set-fun-name (if safe-p
 226                       checking-fun
 227                       writer-fun)
 228                   `(writer ,slot-name))))
 229
 230 (defun make-optimized-std-boundp-method-function
 231     (fsc-p slotd slot-name location)
 232   (set-fun-name
 233    (etypecase location
 234      (fixnum (if fsc-p
 235                  (lambda (instance)
 236                    (check-obsolete-instance instance)
 237                    (not (eq (clos-slots-ref (fsc-instance-slots instance)
 238                                             location)
 239                             +slot-unbound+)))
 240                  (lambda (instance)
 241                    (check-obsolete-instance instance)
 242                    (not (eq (clos-slots-ref (std-instance-slots instance)
 243                                             location)
 244                             +slot-unbound+)))))
 245      (cons (lambda (instance)
 246              (check-obsolete-instance instance)
 247              (not (eq (cdr location) +slot-unbound+))))
 248      (null
 249       (lambda (instance)
 250         (declare (ignore instance))
 251         (instance-structure-protocol-error slotd 'slot-boundp-using-class))))
 252    `(boundp ,slot-name)))
 253
 254 (defun make-optimized-structure-slot-value-using-class-method-function
 255     (function)
 256   (declare (type function function))
 257   (lambda (class object slotd)
 258     (declare (ignore class slotd))
 259     (funcall function object)))
 260
 261 (defun make-optimized-structure-setf-slot-value-using-class-method-function
 262     (function)
 263   (declare (type function function))
 264   (lambda (nv class object slotd)
 265     (declare (ignore class slotd))
 266     (funcall function nv object)))
 267
 268 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
 269   (lambda (class object slotd)
 270     (declare (ignore class object slotd))
 271     t))
 272
 273 (defun get-optimized-std-slot-value-using-class-method-function
 274     (class slotd name)
 275   (cond
 276     ((structure-class-p class)
 277      (ecase name
 278        (reader (make-optimized-structure-slot-value-using-class-method-function
 279                 (slot-definition-internal-reader-function slotd)))
 280        (writer (make-optimized-structure-setf-slot-value-using-class-method-function
 281                 (slot-definition-internal-writer-function slotd)))
 282        (boundp (make-optimized-structure-slot-boundp-using-class-method-function))))
 283     ((condition-class-p class)
 284      (let ((info (slot-definition-info slotd)))
 285        (ecase name
 286          (reader
 287           (let ((fun (slot-info-reader info)))
 288             (lambda (class object slotd)
 289               (declare (ignore class slotd))
 290               (funcall fun object))))
 291          (writer
 292           (let ((fun (slot-info-writer info)))
 293             (lambda (new-value class object slotd)
 294               (declare (ignore class slotd))
 295               (funcall fun new-value object))))
 296          (boundp
 297           (let ((fun (slot-info-boundp info)))
 298             (lambda (class object slotd)
 299               (declare (ignore class slotd))
 300               (funcall fun object)))))))
 301     (t
 302      (let* ((fsc-p (cond ((standard-class-p class) nil)
 303                          ((funcallable-standard-class-p class) t)
 304                          (t (error "~S is not a standard-class" class))))
 305             (function
 306              (ecase name
 307                (reader
 308                 #'make-optimized-std-slot-value-using-class-method-function)
 309                (writer
 310                 #'make-optimized-std-setf-slot-value-using-class-method-function)
 311                (boundp
 312                 #'make-optimized-std-slot-boundp-using-class-method-function))))
 313        (declare (type function function))
 314        (values (funcall function fsc-p slotd)
 315                (slot-definition-location slotd))))))
 316
 317 (defun make-optimized-std-slot-value-using-class-method-function (fsc-p slotd)
 318   (let ((location (slot-definition-location slotd))
 319         (slot-name (slot-definition-name slotd)))
 320     (etypecase location
 321       (fixnum (if fsc-p
 322                   (lambda (class instance slotd)
 323                     (declare (ignore slotd))
 324                     (check-obsolete-instance instance)
 325                     (let ((value (clos-slots-ref (fsc-instance-slots instance)
 326                                                  location)))
 327                       (if (eq value +slot-unbound+)
 328                           (values (slot-unbound class instance slot-name))
 329                           value)))
 330                   (lambda (class instance slotd)
 331                     (declare (ignore slotd))
 332                     (check-obsolete-instance instance)
 333                     (let ((value (clos-slots-ref (std-instance-slots instance)
 334                                                  location)))
 335                       (if (eq value +slot-unbound+)
 336                           (values (slot-unbound class instance slot-name))
 337                           value)))))
 338       (cons (lambda (class instance slotd)
 339               (declare (ignore slotd))
 340               (check-obsolete-instance instance)
 341               (let ((value (cdr location)))
 342                 (if (eq value +slot-unbound+)
 343                     (values (slot-unbound class instance slot-name))
 344                     value))))
 345       (null
 346        (lambda (class instance slotd)
 347          (declare (ignore class instance))
 348          (instance-structure-protocol-error slotd 'slot-value-using-class))))))
 349
 350 (defun make-optimized-std-setf-slot-value-using-class-method-function
 351     (fsc-p slotd)
 352   (let* ((location (slot-definition-location slotd))
 353          (class (slot-definition-class slotd))
 354          (typecheck
 355           (when (safe-p class)
 356             (slot-info-typecheck (slot-definition-info slotd)))))
 357     (macrolet ((make-mf-lambda (&body body)
 358                  `(lambda (nv class instance slotd)
 359                     (declare (ignore class slotd))
 360                     (check-obsolete-instance instance)
 361                     ,@body))
 362                (make-mf-lambdas (&body body)
 363                  ;; Having separate lambdas for the NULL / not-NULL cases of
 364                  ;; TYPE-CHECK-FUNCTION is done to avoid runtime overhead
 365                  ;; for CLOS typechecking when it's not in use.
 366                  `(if typecheck
 367                       (make-mf-lambda
 368                        (funcall (the function typecheck) nv)
 369                        ,@body)
 370                       (make-mf-lambda
 371                        ,@body))))
 372       (etypecase location
 373         (fixnum
 374          (if fsc-p
 375              (make-mf-lambdas
 376               (setf (clos-slots-ref (fsc-instance-slots instance) location)
 377                     nv))
 378              (make-mf-lambdas
 379               (setf (clos-slots-ref (std-instance-slots instance) location)
 380                     nv))))
 381         (cons
 382          (make-mf-lambdas (setf (cdr location) nv)))
 383         (null (lambda (nv class instance slotd)
 384                 (declare (ignore nv class instance))
 385                 (instance-structure-protocol-error
 386                  slotd '(setf slot-value-using-class))))))))
 387
 388 (defun make-optimized-std-slot-boundp-using-class-method-function
 389     (fsc-p slotd)
 390   (let ((location (slot-definition-location slotd)))
 391     (etypecase location
 392       (fixnum
 393        (if fsc-p
 394            (lambda (class instance slotd)
 395              (declare (ignore class slotd))
 396              (check-obsolete-instance instance)
 397              (not (eq (clos-slots-ref (fsc-instance-slots instance) location)
 398                       +slot-unbound+)))
 399            (lambda (class instance slotd)
 400              (declare (ignore class slotd))
 401              (check-obsolete-instance instance)
 402              (not (eq (clos-slots-ref (std-instance-slots instance) location)
 403                       +slot-unbound+)))))
 404       (cons (lambda (class instance slotd)
 405               (declare (ignore class slotd))
 406               (check-obsolete-instance instance)
 407               (not (eq (cdr location) +slot-unbound+))))
 408       (null
 409        (lambda (class instance slotd)
 410          (declare (ignore class instance))
 411          (instance-structure-protocol-error slotd
 412                                             'slot-boundp-using-class))))))
 413
 414 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
 415   (macrolet ((emf-funcall (emf &rest args)
 416                `(invoke-effective-method-function ,emf nil
 417                                                   :required-args ,args)))
 418     (set-fun-name
 419      (case name
 420        (reader (lambda (instance)
 421                  (emf-funcall sdfun class instance slotd)))
 422        (writer (lambda (nv instance)
 423                  (emf-funcall sdfun nv class instance slotd)))
 424        (boundp (lambda (instance)
 425                  (emf-funcall sdfun class instance slotd))))
 426      `(,name ,(class-name class) ,(slot-definition-name slotd)))))
 427 \f
 428 (defun maybe-class (class-or-name)
 429   (when (eq **boot-state** 'complete)
 430     (if (typep class-or-name 'class)
 431         class-or-name
 432         (find-class class-or-name nil))))
 433
 434 (flet ((make-initargs (slot-name kind method-function)
 435          (let ((initargs (copy-tree method-function))
 436                (slot-names (list slot-name)))
 437            (setf (getf (getf initargs 'plist) :slot-name-lists)
 438                  (ecase kind
 439                    ((:reader :boundp) (list slot-names))
 440                    (:writer (list '() slot-names))))
 441            initargs)))
 442
 443   (defun make-std-reader-method-function (class-or-name slot-name)
 444     (let ((class (maybe-class class-or-name)))
 445       (make-initargs
 446        slot-name :reader
 447        (ecase (slot-access-strategy class slot-name 'reader t)
 448          (:standard
 449           (make-method-function
 450            (lambda (instance)
 451              (pv-binding1 ((bug "Please report this")
 452                            (instance) (instance-slots))
 453                (instance-read-standard
 454                 .pv. instance-slots 0
 455                 (slot-value instance slot-name))))))
 456          ((:custom :accessor)
 457           (make-method-function
 458            (lambda (instance)
 459              (pv-binding1 ((bug "Please report this")
 460                            (instance) nil)
 461                (instance-read-custom .pv. 0 instance)))))))))
 462
 463   (defun make-std-writer-method-function (class-or-name slot-name)
 464     (let ((class (maybe-class class-or-name)))
 465       (make-initargs
 466        slot-name :writer
 467        (ecase (slot-access-strategy class slot-name 'writer t)
 468          (:standard
 469           (macrolet ((writer-method-function (safe)
 470                        `(make-method-function
 471                          (lambda (nv instance)
 472                            (pv-binding1 ((bug "Please report this")
 473                                          (instance) (instance-slots))
 474                              (instance-write-standard
 475                               .pv. instance-slots 0 nv
 476                               (setf (slot-value instance slot-name)
 477                                     .good-new-value.)
 478                               ,@(when safe '(nil t))))))))
 479             (if (and class (safe-p class))
 480                 (writer-method-function t)
 481                 (writer-method-function nil))))
 482          ((:custom :accessor)
 483           (make-method-function
 484            (lambda (nv instance)
 485              (pv-binding1 ((bug "Please report this")
 486                            (instance) nil)
 487                (instance-write-custom .pv. 0 instance nv)))))))))
 488
 489   (defun make-std-boundp-method-function (class-or-name slot-name)
 490     (let ((class (maybe-class class-or-name)))
 491       (make-initargs
 492        slot-name :boundp
 493        (ecase (slot-access-strategy class slot-name 'boundp t)
 494          (:standard
 495           (make-method-function
 496            (lambda (instance)
 497              (pv-binding1 ((bug "Please report this")
 498                            (instance) (instance-slots))
 499                (instance-boundp-standard
 500                 .pv. instance-slots 0
 501                 (slot-boundp instance slot-name))))))
 502          ((:custom :accessor)
 503           (make-method-function
 504            (lambda (instance)
 505              (pv-binding1 ((bug "Please report this")
 506                            (instance) nil)
 507                (instance-boundp-custom .pv. 0 instance))))))))))
 508 \f
 509 ;;;; FINDING SLOT DEFINITIONS
 510 ;;;
 511 ;;; Historical PCL found slot definitions by iterating over
 512 ;;; CLASS-SLOTS, which is O(N) for number of slots, and moreover
 513 ;;; requires a GF call (for SLOT-DEFINITION-NAME) for each slot in
 514 ;;; list up to the desired one.
 515 ;;;
 516 ;;; Current SBCL hashes the effective slot definitions, and some
 517 ;;; information pulled out from them into a simple-vector, with bucket
 518 ;;; chains made out of plists keyed by the slot names. This fixes
 519 ;;; gives O(1) performance, and avoid the GF calls.
 520 ;;;
 521 ;;; MAKE-SLOT-TABLE constructs the hashed vector out of a list of
 522 ;;; effective slot definitions and the class they pertain to, and
 523 ;;; FIND-SLOT-DEFINITION knows how to look up slots in that vector.
 524 ;;;
 525 ;;; The only bit of cleverness in the implementation is to make the
 526 ;;; vectors fairly tight, but always longer then 0 elements:
 527 ;;;
 528 ;;; -- We don't want to waste huge amounts of space no these vectors,
 529 ;;;    which are mostly required by things like SLOT-VALUE with a
 530 ;;;    variable slot name, so a constant extension over the minimum
 531 ;;;    size seems like a good choise.
 532 ;;;
 533 ;;; -- As long as the vector always has a length > 0
 534 ;;;    FIND-SLOT-DEFINITION doesn't need to handle the rare case of an
 535 ;;;    empty vector separately: it just returns a NIL.
 536 ;;;
 537 ;;; In addition to the slot-definition we also store the slot-location
 538 ;;; and type-check function for instances of standard metaclasses, so
 539 ;;; that SLOT-VALUE &co using variable slot names can get at them
 540 ;;; without additional GF calls.
 541 ;;;
 542 ;;; Notes:
 543 ;;;   It would also be nice to have STANDARD-INSTANCE-STRUCTURE-P
 544 ;;;   generic instead of checking versus STANDARD-CLASS and
 545 ;;;   FUNCALLABLE-STANDARD-CLASS.
 546 ;;;
 547 ;;;   Uh, the comments above talking about how FIND-SLOT-DEFINITION
 548 ;;;   does something with slot vectors has no basis in reality.
 549 ;;;   Probably the comments need fixing, rather than the code.
 550
 551 (defun find-slot-definition (class slot-name &optional errorp)
 552   (unless (class-finalized-p class)
 553     (or (try-finalize-inheritance class)
 554         (if errorp
 555             (error "Cannot look up slot-definition for ~S in ~S (too early to finalize.)"
 556                    slot-name class)
 557             (return-from find-slot-definition (values nil nil)))))
 558   (dolist (slotd (class-slots class)
 559            (if errorp
 560                (error "No slot called ~S in ~S." slot-name class)
 561                (values nil t)))
 562     (when (eq slot-name (slot-definition-name slotd))
 563       (return (values slotd t)))))
 564
 565 (defun find-slot-cell (wrapper slot-name)
 566   (declare (symbol slot-name))
 567   (declare (optimize (sb-c::insert-array-bounds-checks 0)))
 568   (let* ((vector (layout-slot-table wrapper))
 569          (modulus (truly-the index (svref vector 0)))
 570          ;; Can elide the 'else' branch of (OR symbol-hash ensure-symbol-hash)
 571          ;; because every symbol in the slot-table already got a nonzero hash.
 572          (index (rem (symbol-hash slot-name) modulus))
 573          (probe (svref vector (1+ index))))
 574     (declare (simple-vector vector) (index index))
 575     (cond ((fixnump probe)
 576            (do* ((count (svref vector (1- (truly-the index probe))))
 577                  (end (truly-the index (+ probe count)))
 578                  (j probe (1+ j)))
 579                 ((>= j end))
 580              (declare (index count j))
 581              (when (eq (svref vector j) slot-name)
 582                (return (svref vector (truly-the index (+ j count)))))))
 583           ((eq (car (truly-the list probe)) slot-name)
 584            (cdr probe)))))
 585
 586 (defun make-slot-table (class slots &optional bootstrap)
 587   (unless slots
 588     ;; *** If changing this empty table value to something else,
 589     ;;     be sure to make a similar change to MAKE-COLD-LAYOUT in
 590     ;;     compiler/generic/genesis as well as in DEFSTRUCT LAYOUT.
 591     ;;     A DEFCONSTANT for this would only transfer the problem
 592     ;;     to cold-init in a different sort of way. :-(
 593     (return-from make-slot-table #(1 nil)))
 594   (let* ((n (+ (logior (length slots) 1) 2)) ; an odd divisor is preferred
 595          (vector (make-array n :initial-element nil)))
 596     (flet ((add-to-vector (name slot)
 597              (declare (symbol name)
 598                       (optimize (sb-c::insert-array-bounds-checks 0)))
 599              (let ((index (rem (ensure-symbol-hash name) n)))
 600                (setf (svref vector index)
 601                      (acons name
 602                             (cons (when (or bootstrap
 603                                             (and (standard-class-p class)
 604                                                  (slot-accessor-std-p slot 'all)))
 605                                     (if bootstrap
 606                                         (early-slot-definition-location slot)
 607                                         (slot-definition-location slot)))
 608                                   (the slot-info
 609                                     (if bootstrap
 610                                         (early-slot-definition-info slot)
 611                                         (slot-definition-info slot))))
 612                             (svref vector index))))))
 613       (if (eq 'complete **boot-state**)
 614           (dolist (slot slots)
 615             (add-to-vector (slot-definition-name slot) slot))
 616           (dolist (slot slots)
 617             (add-to-vector (early-slot-definition-name slot) slot))))
 618     ;; The VECTOR as computed above implements a hash table with chaining.
 619     ;; Rather than store chains using cons cells, chains can be stored in the
 620     ;; vector itself at the end, with the table entry pointing to another
 621     ;; index in the vector. The chain length is stored first, then all keys,
 622     ;; then all values. The resulting structure takes less memory than
 623     ;; linked lists, and can be scanned faster. As an exception, for lists
 624     ;; of length 1, the table cell holds a (key . value) pair directly.
 625     (let* ((final-n
 626             (+ 1 n
 627                ;; number of additional cells needed to represent linked lists
 628                ;; as length-prefixed subsequences in the final vector.
 629                (loop for cell across vector
 630                      for count = (length cell)
 631                      sum (if (<= count 1) 0 (1+ (* count 2))))))
 632            (final-vector (make-array final-n))
 633            (data-index (1+ n))) ; after the hashtable portion of the vector
 634       (setf (aref final-vector 0) n) ; the modulus
 635       (dotimes (i n final-vector)
 636         (let ((alist (aref vector i)))
 637           (if (not (cdr alist)) ; store it in the final vector as-is
 638               (setf (aref final-vector (1+ i)) (car alist))
 639               (let ((count (length alist)))
 640                 ;; Probed cell holds the index of the first symbol.
 641                 ;; The symbol count precedes the first symbol cell.
 642                 (setf (aref final-vector (1+ i)) (1+ data-index)
 643                       (aref final-vector data-index) count)
 644                 (dolist (cell alist)
 645                   (setf (aref final-vector (incf data-index)) (car cell)))
 646                 (dolist (cell alist)
 647                   (setf (aref final-vector (incf data-index)) (cdr cell)))
 648                 (incf data-index))))))))