src/pcl/wrapper.lisp

   1 ;;;; Bits and pieces of the wrapper machninery. This used to live in cache.lisp,
   2 ;;;; but doesn't really logically belong there.
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6
   7 ;;;; This software is derived from software originally released by Xerox
   8 ;;;; Corporation. Copyright and release statements follow. Later modifications
   9 ;;;; to the software are in the public domain and are provided with
  10 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
  11 ;;;; information.
  12
  13 ;;;; copyright information from original PCL sources:
  14 ;;;;
  15 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  16 ;;;; All rights reserved.
  17 ;;;;
  18 ;;;; Use and copying of this software and preparation of derivative works based
  19 ;;;; upon this software are permitted. Any distribution of this software or
  20 ;;;; derivative works must comply with all applicable United States export
  21 ;;;; control laws.
  22 ;;;;
  23 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  24 ;;;; warranty about the software, its performance or its conformity to any
  25 ;;;; specification.
  26
  27 (in-package "SB-PCL")
  28
  29 (defmacro wrapper-class (wrapper)
  30   `(classoid-pcl-class (layout-classoid ,wrapper)))
  31 (defmacro wrapper-no-of-instance-slots (wrapper)
  32   `(layout-length ,wrapper))
  33
  34 ;;; This is called in BRAID when we are making wrappers for classes
  35 ;;; whose slots are not initialized yet, and which may be built-in
  36 ;;; classes. We pass in the class name in addition to the class.
  37 (defun !boot-make-wrapper (length name &optional class)
  38   (let ((found (find-classoid name nil)))
  39     (cond
  40      (found
  41       (unless (classoid-pcl-class found)
  42         (setf (classoid-pcl-class found) class))
  43       (aver (eq (classoid-pcl-class found) class))
  44       (let ((layout (classoid-layout found)))
  45         (aver layout)
  46         layout))
  47      (t
  48       (make-wrapper-internal
  49        :length length
  50        :classoid (make-standard-classoid
  51                   :name name :pcl-class class))))))
  52
  53 ;;; The following variable may be set to a STANDARD-CLASS that has
  54 ;;; already been created by the lisp code and which is to be redefined
  55 ;;; by PCL. This allows STANDARD-CLASSes to be defined and used for
  56 ;;; type testing and dispatch before PCL is loaded.
  57 (defvar *pcl-class-boot* nil)
  58
  59 ;;; In SBCL, as in CMU CL, the layouts (a.k.a wrappers) for built-in
  60 ;;; and structure classes already exist when PCL is initialized, so we
  61 ;;; don't necessarily always make a wrapper. Also, we help maintain
  62 ;;; the mapping between CL:CLASS and SB-KERNEL:CLASSOID objects.
  63 (defun make-wrapper (length class)
  64   (cond
  65     ((or (typep class 'std-class)
  66          (typep class 'forward-referenced-class))
  67      (make-wrapper-internal
  68       :length length
  69       :classoid
  70       (let ((owrap (class-wrapper class)))
  71         (cond (owrap
  72                (layout-classoid owrap))
  73               ((or (*subtypep (class-of class) *the-class-standard-class*)
  74                    (*subtypep (class-of class) *the-class-funcallable-standard-class*)
  75                    (typep class 'forward-referenced-class))
  76                (cond ((and *pcl-class-boot*
  77                            (eq (slot-value class 'name) *pcl-class-boot*))
  78                       (let ((found (find-classoid
  79                                     (slot-value class 'name))))
  80                         (unless (classoid-pcl-class found)
  81                           (setf (classoid-pcl-class found) class))
  82                         (aver (eq (classoid-pcl-class found) class))
  83                         found))
  84                      (t
  85                       (let ((name (slot-value class 'name)))
  86                         (make-standard-classoid :pcl-class class
  87                                                 :name (and (symbolp name) name))))))
  88               (t
  89                (bug "Got to T branch in ~S" 'make-wrapper))))))
  90     (t
  91      (let* ((found (find-classoid (slot-value class 'name)))
  92             (layout (classoid-layout found)))
  93        (unless (classoid-pcl-class found)
  94          (setf (classoid-pcl-class found) class))
  95        (aver (eq (classoid-pcl-class found) class))
  96        (aver layout)
  97        layout))))
  98
  99 (declaim (inline wrapper-class*))
 100 (defun wrapper-class* (wrapper)
 101   (or (wrapper-class wrapper)
 102       (let ((classoid (layout-classoid wrapper)))
 103         (ensure-non-standard-class
 104          (classoid-name classoid)
 105          classoid))))
 106
 107 ;;; The wrapper cache machinery provides general mechanism for
 108 ;;; trapping on the next access to any instance of a given class. This
 109 ;;; mechanism is used to implement the updating of instances when the
 110 ;;; class is redefined (MAKE-INSTANCES-OBSOLETE). The same mechanism
 111 ;;; is also used to update generic function caches when there is a
 112 ;;; change to the superclasses of a class.
 113 ;;;
 114 ;;; Basically, a given wrapper can be valid or invalid. If it is
 115 ;;; invalid, it means that any attempt to do a wrapper cache lookup
 116 ;;; using the wrapper should trap. Also, methods on
 117 ;;; SLOT-VALUE-USING-CLASS check the wrapper validity as well. This is
 118 ;;; done by calling CHECK-WRAPPER-VALIDITY.
 119
 120 (declaim (inline invalid-wrapper-p))
 121 (defun invalid-wrapper-p (wrapper)
 122   (not (null (layout-invalid wrapper))))
 123
 124 ;;; We only use this inside INVALIDATE-WRAPPER.
 125 (defvar *previous-nwrappers* (make-hash-table))
 126
 127 (defun %invalidate-wrapper (owrapper state nwrapper)
 128   (aver (member state '(:flush :obsolete) :test #'eq))
 129   (let ((new-previous ()))
 130     ;; First off, a previous call to INVALIDATE-WRAPPER may have
 131     ;; recorded OWRAPPER as an NWRAPPER to update to. Since OWRAPPER
 132     ;; is about to be invalid, it no longer makes sense to update to
 133     ;; it.
 134     ;;
 135     ;; We go back and change the previously invalidated wrappers so
 136     ;; that they will now update directly to NWRAPPER. This
 137     ;; corresponds to a kind of transitivity of wrapper updates.
 138     (dolist (previous (gethash owrapper *previous-nwrappers*))
 139       (when (eq state :obsolete)
 140         (setf (car previous) :obsolete))
 141       (setf (cadr previous) nwrapper)
 142       (push previous new-previous))
 143
 144     ;; FIXME: We are here inside PCL lock, but might someone be
 145     ;; accessing the wrapper at the same time from outside the lock?
 146     (setf (layout-clos-hash owrapper) 0)
 147
 148     ;; FIXME: We could save a whopping cons by using (STATE . WRAPPER)
 149     ;; instead
 150     (push (setf (layout-invalid owrapper) (list state nwrapper))
 151           new-previous)
 152
 153     (remhash owrapper *previous-nwrappers*)
 154     (setf (gethash nwrapper *previous-nwrappers*) new-previous)))
 155
 156 ;;; FIXME: This is not a good name: part of the contract here is that
 157 ;;; we return the valid wrapper, which is not obvious from the name
 158 ;;; (or the names of our callees.)
 159 (defun check-wrapper-validity (instance)
 160   (with-world-lock ()
 161     (let* ((owrapper (wrapper-of instance))
 162            (state (layout-invalid owrapper)))
 163       (aver (not (eq state :uninitialized)))
 164       (cond ((not state)
 165              owrapper)
 166             ((not (layout-for-std-class-p owrapper))
 167              ;; Obsolete structure trap.
 168              (%obsolete-instance-trap owrapper nil instance))
 169             ((eq t state)
 170              ;; FIXME: I can't help thinking that, while this does cure
 171              ;; the symptoms observed from some class redefinitions,
 172              ;; this isn't the place to be doing this flushing.
 173              ;; Nevertheless... -- CSR, 2003-05-31
 174              ;;
 175              ;; CMUCL comment:
 176              ;;    We assume in this case, that the :INVALID is from a
 177              ;;    previous call to REGISTER-LAYOUT for a superclass of
 178              ;;    INSTANCE's class.  See also the comment above
 179              ;;    FORCE-CACHE-FLUSHES.  Paul Dietz has test cases for this.
 180              (let ((class (wrapper-class* owrapper)))
 181                (%force-cache-flushes class)
 182                ;; KLUDGE: avoid an infinite recursion, it's still better to
 183                ;; bail out with an error for server softwares. see FIXME above.
 184                ;; details: http://thread.gmane.org/gmane.lisp.steel-bank.devel/10175
 185                ;;
 186                ;; Error message here is trying to figure out a bit more about the
 187                ;; situation, since we don't have anything approaching a test-case
 188                ;; for the bug.
 189                (let ((new-state (layout-invalid (wrapper-of instance))))
 190                  (unless (neq t new-state)
 191                    (cerror "Nevermind and recurse." 'bug
 192                            :format-control "~@<~4IProblem forcing cache flushes. Please report ~
 193                                                to sbcl-devel.~
 194                                             ~% Owrapper: ~S~
 195                                             ~% Wrapper-of: ~S~
 196                                             ~% Class-wrapper: ~S~%~:@>"
 197                            :format-arguments (mapcar (lambda (x)
 198                                                        (cons x (layout-invalid x)))
 199                                                      (list owrapper
 200                                                            (wrapper-of instance)
 201                                                            (class-wrapper class)))))))
 202              (check-wrapper-validity instance))
 203             ((consp state)
 204              (ecase (car state)
 205                (:flush
 206                 (let ((new (cadr state)))
 207                   (cond ((std-instance-p instance)
 208                          (setf (std-instance-wrapper instance) new))
 209                         ((fsc-instance-p instance)
 210                          (setf (fsc-instance-wrapper instance) new))
 211                         (t
 212                          (bug "unrecognized instance type")))))
 213                (:obsolete
 214                 (%obsolete-instance-trap owrapper (cadr state) instance))))
 215             (t
 216              (bug "Invalid LAYOUT-INVALID: ~S" state))))))
 217
 218 (declaim (inline check-obsolete-instance))
 219 (defun check-obsolete-instance (instance)
 220   (when (invalid-wrapper-p (layout-of instance))
 221     (check-wrapper-validity instance)))
 222
 223 (defun valid-wrapper-of (instance)
 224   (let ((wrapper (wrapper-of instance)))
 225     (if (invalid-wrapper-p wrapper)
 226         (check-wrapper-validity instance)
 227         wrapper)))
 228 \f
 229 ;;;  NIL: means nothing so far, no actual arg info has NILs in the
 230 ;;;  metatype.
 231 ;;;
 232 ;;;  CLASS: seen all sorts of metaclasses (specifically, more than one
 233 ;;;  of the next 5 values) or else have seen something which doesn't
 234 ;;;  fall into a single category (SLOT-INSTANCE, FORWARD).  Also used
 235 ;;;  when seen a non-standard specializer.
 236 ;;;
 237 ;;;  T: means everything so far is the class T.
 238 ;;;
 239 ;;;  The above three are the really important ones, as they affect how
 240 ;;;  discriminating functions are computed.  There are some other
 241 ;;;  possible metatypes:
 242 ;;;
 243 ;;;  * STANDARD-INSTANCE: seen only standard classes
 244 ;;;  * BUILT-IN-INSTANCE: seen only built in classes
 245 ;;;  * STRUCTURE-INSTANCE: seen only structure classes
 246 ;;;  * CONDITION-INSTANCE: seen only condition classes
 247 ;;;
 248 ;;;  but these are largely unexploited as of 2007-05-10.  The
 249 ;;;  distinction between STANDARD-INSTANCE and the others is used in
 250 ;;;  emitting wrapper/slot-getting code in accessor discriminating
 251 ;;;  functions (see EMIT-FETCH-WRAPPER and EMIT-READER/WRITER); it is
 252 ;;;  possible that there was an intention to use these metatypes to
 253 ;;;  specialize cache implementation or discrimination nets, but this
 254 ;;;  has not occurred as yet.
 255 (defun raise-metatype (metatype new-specializer)
 256   (let ((slot      *the-class-slot-class*)
 257         (standard  *the-class-standard-class*)
 258         (fsc       *the-class-funcallable-standard-class*)
 259         (condition *the-class-condition-class*)
 260         (structure *the-class-structure-class*)
 261         (built-in  *the-class-built-in-class*)
 262         (frc       *the-class-forward-referenced-class*))
 263     (flet ((specializer->metatype (x)
 264              (let* ((specializer-class (if (eq **boot-state** 'complete)
 265                                            (specializer-class-or-nil x)
 266                                            x))
 267                    (meta-specializer (class-of specializer-class)))
 268                (cond
 269                  ((eq x *the-class-t*) t)
 270                  ((not specializer-class) 'non-standard)
 271                  ((*subtypep meta-specializer standard) 'standard-instance)
 272                  ((*subtypep meta-specializer fsc) 'standard-instance)
 273                  ((*subtypep meta-specializer condition) 'condition-instance)
 274                  ((*subtypep meta-specializer structure) 'structure-instance)
 275                  ((*subtypep meta-specializer built-in) 'built-in-instance)
 276                  ((*subtypep meta-specializer slot) 'slot-instance)
 277                  ((*subtypep meta-specializer frc) 'forward)
 278                  (t (error "~@<PCL cannot handle the specializer ~S ~
 279                             (meta-specializer ~S).~@:>"
 280                            new-specializer meta-specializer))))))
 281       ;; We implement the following table. The notation is
 282       ;; that X and Y are distinct meta specializer names.
 283       ;;
 284       ;;    NIL    <anything>    ===>  <anything>
 285       ;;    X      X             ===>  X
 286       ;;    X      Y             ===>  CLASS
 287       (let ((new-metatype (specializer->metatype new-specializer)))
 288         (cond ((eq new-metatype 'slot-instance) 'class)
 289               ((eq new-metatype 'forward) 'class)
 290               ((eq new-metatype 'non-standard) 'class)
 291               ((null metatype) new-metatype)
 292               ((eq metatype new-metatype) new-metatype)
 293               (t 'class))))))
 294
 295 (defmacro with-dfun-wrappers ((args metatypes)
 296                               (dfun-wrappers invalid-wrapper-p
 297                                              &optional wrappers classes types)
 298                               invalid-arguments-form
 299                               &body body)
 300   `(let* ((args-tail ,args) (,invalid-wrapper-p nil) (invalid-arguments-p nil)
 301           (,dfun-wrappers nil) (dfun-wrappers-tail nil)
 302           ,@(when wrappers
 303               `((wrappers-rev nil) (types-rev nil) (classes-rev nil))))
 304      (dolist (mt ,metatypes)
 305        (unless args-tail
 306          (setq invalid-arguments-p t)
 307          (return nil))
 308        (let* ((arg (pop args-tail))
 309               (wrapper nil)
 310               ,@(when wrappers
 311                   `((class *the-class-t*)
 312                     (type t))))
 313          (unless (eq mt t)
 314            (setq wrapper (wrapper-of arg))
 315            (when (invalid-wrapper-p wrapper)
 316              (setq ,invalid-wrapper-p t)
 317              (setq wrapper (check-wrapper-validity arg)))
 318            (cond ((null ,dfun-wrappers)
 319                   (setq ,dfun-wrappers wrapper))
 320                  ((not (consp ,dfun-wrappers))
 321                   (setq dfun-wrappers-tail (list wrapper))
 322                   (setq ,dfun-wrappers (cons ,dfun-wrappers dfun-wrappers-tail)))
 323                  (t
 324                   (let ((new-dfun-wrappers-tail (list wrapper)))
 325                     (setf (cdr dfun-wrappers-tail) new-dfun-wrappers-tail)
 326                     (setf dfun-wrappers-tail new-dfun-wrappers-tail))))
 327            ,@(when wrappers
 328                `((setq class (wrapper-class* wrapper))
 329                  (setq type `(class-eq ,class)))))
 330          ,@(when wrappers
 331              `((push wrapper wrappers-rev)
 332                (push class classes-rev)
 333                (push type types-rev)))))
 334      (if invalid-arguments-p
 335          ,invalid-arguments-form
 336          (let* (,@(when wrappers
 337                     `((,wrappers (nreverse wrappers-rev))
 338                       (,classes (nreverse classes-rev))
 339                       (,types (mapcar (lambda (class)
 340                                         `(class-eq ,class))
 341                                       ,classes)))))
 342            ,@body))))