src/pcl/dlisp.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
  26 ;;;; some support stuff for getting a hold of symbols that we need when
  27 ;;;; building the discriminator codes. It's OK for these to be interned
  28 ;;;; symbols because we don't capture any user code in the scope in which
  29 ;;;; these symbols are bound.
  30
  31 (declaim (list *dfun-arg-symbols*))
  32 (defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.))
  33
  34 (defun dfun-arg-symbol (arg-number)
  35   (or (nth arg-number *dfun-arg-symbols*)
  36       (format-symbol *pcl-package* ".ARG~A." arg-number)))
  37
  38 (declaim (list *slot-vector-symbols*))
  39 (defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.))
  40
  41 (defun slot-vector-symbol (arg-number)
  42   (or (nth arg-number *slot-vector-symbols*)
  43       (format-symbol *pcl-package* ".SLOTS~A." arg-number)))
  44
  45 (declaim (inline make-dfun-required-args))
  46 (defun make-dfun-required-args (count)
  47   (declare (type index count))
  48   (let (result)
  49     (dotimes (i count (nreverse result))
  50       (push (dfun-arg-symbol i) result))))
  51
  52 (defun make-dfun-lambda-list (nargs applyp)
  53   (let ((required (make-dfun-required-args nargs)))
  54     (if applyp
  55         (nconc required
  56                ;; Use &MORE arguments to avoid consing up an &REST list
  57                ;; that we might not need at all. See MAKE-EMF-CALL and
  58                ;; INVOKE-EFFECTIVE-METHOD-FUNCTION for the other
  59                ;; pieces.
  60                '(&more .dfun-more-context. .dfun-more-count.))
  61         required)))
  62
  63 (defun make-dlap-lambda-list (nargs applyp)
  64   (let* ((required (make-dfun-required-args nargs))
  65          (lambda-list (if applyp
  66                           (append required '(&more .more-context. .more-count.))
  67                           required)))
  68     ;; Return the full lambda list, the required arguments, a form
  69     ;; that will generate a rest-list, and a list of the &MORE
  70     ;; parameters used.
  71     (values lambda-list
  72             required
  73             (when applyp
  74               '((sb-c::%listify-rest-args
  75                  .more-context.
  76                  (the (and unsigned-byte fixnum)
  77                    .more-count.))))
  78             (when applyp
  79               '(.more-context. .more-count.)))))
  80
  81 (defun make-emf-call (nargs applyp fn-variable &optional emf-type)
  82   (let ((required (make-dfun-required-args nargs)))
  83     `(,(if (eq emf-type 'fast-method-call)
  84            'invoke-effective-method-function-fast
  85            'invoke-effective-method-function)
  86        ,fn-variable
  87        ,applyp
  88        :required-args ,required
  89        ;; INVOKE-EFFECTIVE-METHOD-FUNCTION will decide whether to use
  90        ;; the :REST-ARG version or the :MORE-ARG version depending on
  91        ;; the type of the EMF.
  92        :rest-arg ,(if applyp
  93                       ;; Creates a list from the &MORE arguments.
  94                       '((sb-c::%listify-rest-args
  95                          .dfun-more-context.
  96                          (the (and unsigned-byte fixnum)
  97                            .dfun-more-count.)))
  98                       nil)
  99        :more-arg ,(when applyp
 100                     '(.dfun-more-context. .dfun-more-count.)))))
 101
 102 (defun make-fast-method-call-lambda-list (nargs applyp)
 103   (list* '.pv-cell. '.next-method-call. (make-dfun-lambda-list nargs applyp)))
 104 \f
 105 ;;; Emitting various accessors.
 106
 107 (defun emit-one-class-reader (class-slot-p)
 108   (emit-reader/writer :reader 1 class-slot-p))
 109
 110 (defun emit-one-class-boundp (class-slot-p)
 111   (emit-reader/writer :boundp 1 class-slot-p))
 112
 113 (defun emit-one-class-writer (class-slot-p)
 114   (emit-reader/writer :writer 1 class-slot-p))
 115
 116 (defun emit-two-class-reader (class-slot-p)
 117   (emit-reader/writer :reader 2 class-slot-p))
 118
 119 (defun emit-two-class-boundp (class-slot-p)
 120   (emit-reader/writer :boundp 2 class-slot-p))
 121
 122 (defun emit-two-class-writer (class-slot-p)
 123   (emit-reader/writer :writer 2 class-slot-p))
 124
 125 ;;; --------------------------------
 126
 127 (defun emit-one-index-readers (class-slot-p)
 128   (emit-one-or-n-index-reader/writer :reader nil class-slot-p))
 129
 130 (defun emit-one-index-boundps (class-slot-p)
 131   (emit-one-or-n-index-reader/writer :boundp nil class-slot-p))
 132
 133 (defun emit-one-index-writers (class-slot-p)
 134   (emit-one-or-n-index-reader/writer :writer nil class-slot-p))
 135
 136 (defun emit-n-n-readers ()
 137   (emit-one-or-n-index-reader/writer :reader t nil))
 138
 139 (defun emit-n-n-boundps ()
 140   (emit-one-or-n-index-reader/writer :boundp t nil))
 141
 142 (defun emit-n-n-writers ()
 143   (emit-one-or-n-index-reader/writer :writer t nil))
 144
 145 ;;; --------------------------------
 146
 147 (defun emit-checking (metatypes applyp)
 148   (emit-checking-or-caching nil nil metatypes applyp))
 149
 150 (defun emit-caching (metatypes applyp)
 151   (emit-checking-or-caching t nil metatypes applyp))
 152
 153 (defun emit-in-checking-cache-p (metatypes)
 154   (emit-checking-or-caching nil t metatypes nil))
 155
 156 (defun emit-constant-value (metatypes)
 157   (emit-checking-or-caching t t metatypes nil))
 158
 159 ;;; --------------------------------
 160
 161 ;;; FIXME: What do these variables mean?
 162 (defvar *precompiling-lap* nil)
 163 (defvar *emit-function-p* t)
 164
 165 ;;; FIXME: This variable is motivated by Gerd Moellman's observation,
 166 ;;; in <867kga1wra.fsf@gerd.free-bsd.org> on cmucl-imp 2002-10-22,
 167 ;;; that the functions returned from EMIT-xxx-FUNCTION can cause an
 168 ;;; order-of-magnitude slowdown.  We include this variable for now,
 169 ;;; but maybe its effect should rather be controlled by compilation
 170 ;;; policy if there is a noticeable space difference between the
 171 ;;; branches, or else maybe the EMIT-xxx-FUNCTION branches should be
 172 ;;; deleted.  It's not clear to me how all of this works, though, so
 173 ;;; until proper benchmarks are done it's probably safest simply to
 174 ;;; have this pseudo-constant to hide code.  -- CSR, 2003-02-14
 175 (defvar *optimize-cache-functions-p* t)
 176
 177 (defun emit-default-only (metatypes applyp)
 178   (unless *optimize-cache-functions-p*
 179     (when (and (null *precompiling-lap*) *emit-function-p*)
 180       (return-from emit-default-only
 181         (emit-default-only-function metatypes applyp))))
 182   (multiple-value-bind (lambda-list args rest-arg more-arg)
 183       (make-dlap-lambda-list (length metatypes) applyp)
 184     (generating-lisp '(emf)
 185                      lambda-list
 186                      `(invoke-effective-method-function emf
 187                                                         ,applyp
 188                                                         :required-args ,args
 189                                                         :more-arg ,more-arg
 190                                                         :rest-arg ,rest-arg))))
 191
 192 ;;; --------------------------------
 193
 194 (defun generating-lisp (closure-variables args form)
 195   (let ((lambda `(lambda ,closure-variables
 196                    ,@(when (member 'miss-fn closure-variables)
 197                            `((declare (type function miss-fn))))
 198                    #'(lambda ,args
 199                        (let ()
 200                          (declare #.*optimize-speed*)
 201                          ,form)))))
 202     (values (if *precompiling-lap*
 203                 `#',lambda
 204                 (compile nil lambda))
 205             nil)))
 206
 207 ;;; note on implementation for CMU 17 and later (including SBCL):
 208 ;;; Since STD-INSTANCE-P is weakened, that branch may run on non-PCL
 209 ;;; instances (structures). The result will be the non-wrapper layout
 210 ;;; for the structure, which will cause a miss. The "slots" will be
 211 ;;; whatever the first slot is, but will be ignored. Similarly,
 212 ;;; FSC-INSTANCE-P returns true on funcallable structures as well as
 213 ;;; PCL fins.
 214 (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
 215   (unless *optimize-cache-functions-p*
 216     (when (and (null *precompiling-lap*) *emit-function-p*)
 217       (return-from emit-reader/writer
 218         (emit-reader/writer-function
 219          reader/writer 1-or-2-class class-slot-p))))
 220   (let ((instance nil)
 221         (arglist  ())
 222         (closure-variables ())
 223         (field +first-wrapper-cache-number-index+)
 224         (read-form (emit-slot-read-form class-slot-p 'index 'slots)))
 225     ;;we need some field to do the fast obsolete check
 226     (ecase reader/writer
 227       ((:reader :boundp)
 228        (setq instance (dfun-arg-symbol 0)
 229              arglist  (list instance)))
 230       (:writer (setq instance (dfun-arg-symbol 1)
 231                      arglist  (list (dfun-arg-symbol 0) instance))))
 232     (ecase 1-or-2-class
 233       (1 (setq closure-variables '(wrapper-0 index miss-fn)))
 234       (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
 235     (generating-lisp
 236      closure-variables
 237      arglist
 238      `(let* (,@(unless class-slot-p `((slots nil)))
 239                (wrapper (cond ((std-instance-p ,instance)
 240                                ,@(unless class-slot-p
 241                                    `((setq slots
 242                                            (std-instance-slots ,instance))))
 243                                (std-instance-wrapper ,instance))
 244                               ((fsc-instance-p ,instance)
 245                                ,@(unless class-slot-p
 246                                    `((setq slots
 247                                            (fsc-instance-slots ,instance))))
 248                                (fsc-instance-wrapper ,instance)))))
 249         (block access
 250           (when (and wrapper
 251                      (/= (layout-clos-hash wrapper ,field) 0)
 252                      ,@(if (eql 1 1-or-2-class)
 253                            `((eq wrapper wrapper-0))
 254                            `((or (eq wrapper wrapper-0)
 255                                  (eq wrapper wrapper-1)))))
 256             ,@(ecase reader/writer
 257                 (:reader
 258                  `((let ((value ,read-form))
 259                      (unless (eq value +slot-unbound+)
 260                        (return-from access value)))))
 261                 (:boundp
 262                  `((let ((value ,read-form))
 263                      (return-from access (not (eq value +slot-unbound+))))))
 264                 (:writer
 265                  `((return-from access (setf ,read-form ,(car arglist)))))))
 266           (funcall miss-fn ,@arglist))))))
 267
 268 (defun emit-slot-read-form (class-slot-p index slots)
 269   (if class-slot-p
 270       `(cdr ,index)
 271       `(clos-slots-ref ,slots ,index)))
 272
 273 (defun emit-boundp-check (value-form miss-fn arglist)
 274   `(let ((value ,value-form))
 275      (if (eq value +slot-unbound+)
 276          (funcall ,miss-fn ,@arglist)
 277          value)))
 278
 279 (defun emit-slot-access (reader/writer class-slot-p slots
 280                          index miss-fn arglist)
 281   (let ((read-form (emit-slot-read-form class-slot-p index slots)))
 282     (ecase reader/writer
 283       (:reader (emit-boundp-check read-form miss-fn arglist))
 284       (:boundp `(not (eq ,read-form +slot-unbound+)))
 285       (:writer `(setf ,read-form ,(car arglist))))))
 286
 287 (defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
 288   (let ((*emit-function-p* nil)
 289         (*precompiling-lap* t))
 290     (values
 291      (emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
 292
 293 (defun emit-one-or-n-index-reader/writer (reader/writer
 294                                           cached-index-p
 295                                           class-slot-p)
 296   (unless *optimize-cache-functions-p*
 297     (when (and (null *precompiling-lap*) *emit-function-p*)
 298       (return-from emit-one-or-n-index-reader/writer
 299         (emit-one-or-n-index-reader/writer-function
 300          reader/writer cached-index-p class-slot-p))))
 301   (multiple-value-bind (arglist metatypes)
 302       (ecase reader/writer
 303         ((:reader :boundp)
 304          (values (list (dfun-arg-symbol 0))
 305                  '(standard-instance)))
 306         (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
 307                          '(t standard-instance))))
 308     (generating-lisp
 309      `(cache ,@(unless cached-index-p '(index)) miss-fn)
 310      arglist
 311      `(let (,@(unless class-slot-p '(slots))
 312             ,@(when cached-index-p '(index)))
 313         ,(emit-dlap 'cache arglist metatypes
 314                     (emit-slot-access reader/writer class-slot-p
 315                                       'slots 'index 'miss-fn arglist)
 316                     `(funcall miss-fn ,@arglist)
 317                     (when cached-index-p 'index)
 318                     (unless class-slot-p '(slots)))))))
 319
 320 (defmacro emit-one-or-n-index-reader/writer-macro
 321     (reader/writer cached-index-p class-slot-p)
 322   (let ((*emit-function-p* nil)
 323         (*precompiling-lap* t))
 324     (values
 325      (emit-one-or-n-index-reader/writer reader/writer
 326                                         cached-index-p
 327                                         class-slot-p))))
 328
 329 (defun emit-miss (miss-fn args applyp)
 330   (if applyp
 331       `(multiple-value-call ,miss-fn ,@args
 332                             (sb-c::%more-arg-values .more-context.
 333                                                     0
 334                                                     .more-count.))
 335       `(funcall ,miss-fn ,@args)))
 336
 337 (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
 338   (unless *optimize-cache-functions-p*
 339     (when (and (null *precompiling-lap*) *emit-function-p*)
 340       (return-from emit-checking-or-caching
 341         (emit-checking-or-caching-function
 342          cached-emf-p return-value-p metatypes applyp))))
 343   (multiple-value-bind (lambda-list args rest-arg more-arg)
 344       (make-dlap-lambda-list (length metatypes) applyp)
 345     (generating-lisp
 346      `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
 347      lambda-list
 348      `(let (,@(when cached-emf-p '(emf)))
 349         ,(emit-dlap 'cache args metatypes
 350                     (if return-value-p
 351                         (if cached-emf-p 'emf t)
 352                         `(invoke-effective-method-function
 353                           emf ,applyp
 354                           :required-args ,args
 355                           :more-arg ,more-arg
 356                           :rest-arg ,rest-arg))
 357                     (emit-miss 'miss-fn args applyp)
 358                     (when cached-emf-p 'emf))))))
 359
 360 (defmacro emit-checking-or-caching-macro (cached-emf-p
 361                                           return-value-p
 362                                           metatypes
 363                                           applyp)
 364   (let ((*emit-function-p* nil)
 365         (*precompiling-lap* t))
 366     (values
 367      (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp))))
 368
 369 (defun emit-dlap (cache-var args metatypes hit-form miss-form value-var
 370                   &optional slot-vars)
 371   (let* ((index -1)
 372          (miss-tag (gensym "MISSED"))
 373          (wrapper-bindings (mapcan (lambda (arg mt)
 374                                      (unless (eq mt t)
 375                                        (incf index)
 376                                        `((,(format-symbol *pcl-package*
 377                                                           "WRAPPER-~D"
 378                                                           index)
 379                                           ,(emit-fetch-wrapper
 380                                             mt arg miss-tag (pop slot-vars))))))
 381                                    args metatypes))
 382          (wrapper-vars (mapcar #'car wrapper-bindings)))
 383     (declare (fixnum index))
 384     (unless wrapper-vars
 385       (error "Every metatype is T."))
 386     `(prog ()
 387         (return
 388           (let ((field (cache-field ,cache-var))
 389                 (cache-vector (cache-vector ,cache-var))
 390                 (mask (cache-mask ,cache-var))
 391                 (size (cache-size ,cache-var))
 392                 (overflow (cache-overflow ,cache-var))
 393                 ,@wrapper-bindings)
 394             (declare (fixnum size field mask))
 395             ,(emit-cache-lookup wrapper-vars miss-tag value-var)
 396             ,hit-form))
 397       ,miss-tag
 398         (return ,miss-form))))
 399
 400 (defun emit-cache-lookup (wrapper-vars miss-tag value-reg)
 401   (cond ((cdr wrapper-vars)
 402          (emit-greater-than-1-dlap wrapper-vars miss-tag value-reg))
 403         (value-reg
 404          (emit-1-t-dlap (car wrapper-vars) miss-tag value-reg))
 405         (t
 406          (emit-1-nil-dlap (car wrapper-vars) miss-tag))))
 407
 408 (defun emit-1-nil-dlap (wrapper miss-label)
 409   `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper
 410                                                                    miss-label))
 411           (location primary))
 412      (declare (fixnum primary location))
 413      (block search
 414        (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
 415                (return-from search nil))
 416              (setq location (the fixnum (+ location 1)))
 417              (when (= location size)
 418                (setq location 0))
 419              (when (= location primary)
 420                (dolist (entry overflow)
 421                  (when (eq (car entry) ,wrapper)
 422                    (return-from search nil)))
 423                (go ,miss-label))))))
 424
 425 (defmacro get-cache-vector-lock-count (cache-vector)
 426   `(let ((lock-count (cache-vector-lock-count ,cache-vector)))
 427      (unless (typep lock-count 'fixnum)
 428        (error "My cache got freed somehow."))
 429      (the fixnum lock-count)))
 430
 431 (defun emit-1-t-dlap (wrapper miss-label value)
 432   `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper
 433                                                                   miss-label))
 434          (initial-lock-count (get-cache-vector-lock-count cache-vector)))
 435      (declare (fixnum primary initial-lock-count))
 436      (let ((location primary))
 437        (declare (fixnum location))
 438        (block search
 439          (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
 440                  (setq ,value (cache-vector-ref cache-vector (1+ location)))
 441                  (return-from search nil))
 442                (setq location (the fixnum (+ location 2)))
 443                (when (= location size)
 444                  (setq location 0))
 445                (when (= location primary)
 446                  (dolist (entry overflow)
 447                    (when (eq (car entry) ,wrapper)
 448                      (setq ,value (cdr entry))
 449                      (return-from search nil)))
 450                  (go ,miss-label))))
 451        (unless (= initial-lock-count
 452                   (get-cache-vector-lock-count cache-vector))
 453          (go ,miss-label)))))
 454
 455 (defun emit-greater-than-1-dlap (wrappers miss-label value)
 456   (declare (type list wrappers))
 457   (let ((cache-line-size (compute-line-size (+ (length wrappers)
 458                                                (if value 1 0)))))
 459     `(let ((primary 0)
 460            (size-1 (the fixnum (- size 1))))
 461        (declare (fixnum primary size-1))
 462        ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
 463        (let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
 464          (declare (fixnum initial-lock-count))
 465          (let ((location primary)
 466                (next-location 0))
 467            (declare (fixnum location next-location))
 468            (block search
 469              (loop (setq next-location
 470                          (the fixnum (+ location ,cache-line-size)))
 471                    (when (and ,@(mapcar
 472                                  (lambda (wrapper)
 473                                    `(eq ,wrapper
 474                                         (cache-vector-ref
 475                                          cache-vector
 476                                          (setq location
 477                                                (the fixnum (+ location 1))))))
 478                                  wrappers))
 479                      ,@(when value
 480                          `((setq location (the fixnum (+ location 1)))
 481                            (setq ,value (cache-vector-ref cache-vector
 482                                                           location))))
 483                      (return-from search nil))
 484                    (setq location next-location)
 485                    (when (= location size-1)
 486                      (setq location 0))
 487                    (when (= location primary)
 488                      (dolist (entry overflow)
 489                        (let ((entry-wrappers (car entry)))
 490                          (when (and ,@(mapcar (lambda (wrapper)
 491                                                 `(eq ,wrapper
 492                                                      (pop entry-wrappers)))
 493                                               wrappers))
 494                            ,@(when value
 495                                `((setq ,value (cdr entry))))
 496                            (return-from search nil))))
 497                      (go ,miss-label))))
 498            (unless (= initial-lock-count
 499                       (get-cache-vector-lock-count cache-vector))
 500              (go ,miss-label)))))))
 501
 502 (defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)
 503   `(let ((wrapper-cache-no (layout-clos-hash ,wrapper field)))
 504      (declare (fixnum wrapper-cache-no))
 505      (when (zerop wrapper-cache-no) (go ,miss-label))
 506      ,(let ((form `(logand mask wrapper-cache-no)))
 507         `(the fixnum ,form))))
 508
 509 (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
 510   (declare (type list wrappers))
 511   ;; This returns 1 less that the actual location.
 512   `(progn
 513      ,@(let ((adds 0) (len (length wrappers)))
 514          (declare (fixnum adds len))
 515          (mapcar (lambda (wrapper)
 516                    `(let ((wrapper-cache-no (layout-clos-hash ,wrapper field)))
 517                       (declare (fixnum wrapper-cache-no))
 518                       (when (zerop wrapper-cache-no) (go ,miss-label))
 519                       (setq primary (the fixnum (+ primary wrapper-cache-no)))
 520                       ,@(progn
 521                           (incf adds)
 522                           (when (or (zerop (mod adds
 523                                                 wrapper-cache-number-adds-ok))
 524                                     (eql adds len))
 525                             `((setq primary
 526                                     ,(let ((form `(logand primary mask)))
 527                                        `(the fixnum ,form))))))))
 528                  wrappers))))
 529
 530 ;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the
 531 ;;; CMU/SBCL approach of using funcallable instances, that branch may
 532 ;;; run on non-pcl instances (structures). The result will be the
 533 ;;; non-wrapper layout for the structure, which will cause a miss. The
 534 ;;; "slots" will be whatever the first slot is, but will be ignored.
 535 ;;; Similarly, FSC-INSTANCE-P returns true on funcallable structures
 536 ;;; as well as PCL fins.
 537 (defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
 538   (ecase metatype
 539     ((standard-instance)
 540      `(cond ((std-instance-p ,argument)
 541              ,@(when slot `((setq ,slot (std-instance-slots ,argument))))
 542              (std-instance-wrapper ,argument))
 543             ((fsc-instance-p ,argument)
 544              ,@(when slot `((setq ,slot (fsc-instance-slots ,argument))))
 545              (fsc-instance-wrapper ,argument))
 546             (t
 547              (go ,miss-label))))
 548     ;; Sep92 PCL used to distinguish between some of these cases (and
 549     ;; spuriously exclude others).  Since in SBCL
 550     ;; WRAPPER-OF/LAYOUT-OF/BUILT-IN-OR-STRUCTURE-WRAPPER are all
 551     ;; equivalent and inlined to each other, we can collapse some
 552     ;; spurious differences.
 553     ((class built-in-instance structure-instance condition-instance)
 554      (when slot (error "can't do a slot reg for this metatype"))
 555      `(wrapper-of ,argument))
 556     ;; a metatype of NIL should never be seen here, as NIL is only in
 557     ;; the metatypes before a generic function is fully initialized.
 558     ;; T should never be seen because we never need to get a wrapper
 559     ;; to do dispatch if all methods have T as the respective
 560     ;; specializer.
 561     ((t nil)
 562      (bug "~@<metatype ~S seen in ~S.~@:>" metatype 'emit-fetch-wrapper))))