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