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