src/code/defbangstruct.lisp

   1 ;;;; DEF!STRUCT = bootstrap DEFSTRUCT, a wrapper around DEFSTRUCT which
   2 ;;;; provides special features to help at bootstrap time:
   3 ;;;;  1. Layout information, inheritance information, and so forth is
   4 ;;;;     retained in such a way that we can get to it even on vanilla
   5 ;;;;     ANSI Common Lisp at cross-compiler build time.
   6 ;;;;  2. MAKE-LOAD-FORM information is stored in such a way that we can
   7 ;;;;     get to it at bootstrap time before CLOS is built. This is
   8 ;;;;     important because at least as of sbcl-0.6.11.26, CLOS is built
   9 ;;;;     (compiled) after cold init, so we need to have the compiler
  10 ;;;;     even before CLOS runs.
  11
  12 ;;;; This software is part of the SBCL system. See the README file for
  13 ;;;; more information.
  14 ;;;;
  15 ;;;; This software is derived from the CMU CL system, which was
  16 ;;;; written at Carnegie Mellon University and released into the
  17 ;;;; public domain. The software is in the public domain and is
  18 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  19 ;;;; files for more information.
  20
  21 (in-package "SB!KERNEL")
  22
  23 ;;; A bootstrap MAKE-LOAD-FORM method can be a function or the name
  24 ;;; of a function.
  25 (deftype def!struct-type-make-load-form-fun () '(or function symbol))
  26
  27 ;;; a little single-inheritance system to keep track of MAKE-LOAD-FORM
  28 ;;; information for DEF!STRUCT-defined types
  29 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
  30
  31   ;; FIXME: All this could be byte compiled. (Perhaps most of the rest
  32   ;; of the file could be, too.)
  33
  34   ;; (DEF!STRUCT-SUPERTYPE TYPE) is the DEF!STRUCT-defined type that
  35   ;; TYPE inherits from, or NIL if none.
  36   (defvar *def!struct-supertype* (make-hash-table))
  37   (defun def!struct-supertype (type)
  38     (multiple-value-bind (value value-p) (gethash type *def!struct-supertype*)
  39       (unless value-p
  40         (error "~S is not a DEF!STRUCT-defined type." type))
  41       value))
  42   (defun (setf def!struct-supertype) (value type)
  43     (when (and value #-sb-xc-host *type-system-initialized*)
  44       (aver (subtypep value 'structure!object))
  45       (aver (subtypep type value)))
  46     (setf (gethash type *def!struct-supertype*) value))
  47
  48   ;; (DEF!STRUCT-TYPE-MAKE-LOAD-FORM-FUN TYPE) is the load form
  49   ;; generator associated with the DEF!STRUCT-defined structure named
  50   ;; TYPE, stored in a way which works independently of CLOS. The
  51   ;; *DEF!STRUCT-TYPE-MAKE-LOAD-FORM-FUN* table is used to store the
  52   ;; values. All types defined by DEF!STRUCT have an entry in the
  53   ;; table; those with no MAKE-LOAD-FORM function have an explicit NIL
  54   ;; entry.
  55   (defvar *def!struct-type-make-load-form-fun* (make-hash-table))
  56   (defun def!struct-type-make-load-form-fun (type)
  57     (do ((supertype type))
  58         (nil)
  59       (multiple-value-bind (value value-p)
  60           (gethash supertype *def!struct-type-make-load-form-fun*)
  61         (unless value-p
  62           (error "~S (supertype of ~S) is not a DEF!STRUCT-defined type."
  63                  supertype
  64                  type))
  65         (when value
  66           (return value))
  67         (setf supertype (def!struct-supertype supertype))
  68         (unless supertype
  69           (error "There is no MAKE-LOAD-FORM function for bootstrap type ~S."
  70                  type)))))
  71   (defun (setf def!struct-type-make-load-form-fun) (new-value type)
  72     (when #+sb-xc-host t #-sb-xc-host *type-system-initialized*
  73       (aver (subtypep type 'structure!object))
  74       (check-type new-value def!struct-type-make-load-form-fun))
  75     (setf (gethash type *def!struct-type-make-load-form-fun*) new-value)))
  76
  77 ;;; the simplest, most vanilla MAKE-LOAD-FORM function for DEF!STRUCT
  78 ;;; objects
  79 (defun just-dump-it-normally (object &optional (env nil env-p))
  80   (declare (type structure!object object))
  81   (if env-p
  82     (make-load-form-saving-slots object :environment env)
  83     (make-load-form-saving-slots object)))
  84
  85 ;;; a MAKE-LOAD-FORM function for objects which don't use the load
  86 ;;; form system. This is used for LAYOUT objects because the special
  87 ;;; dumping requirements of LAYOUT objects are met by using special
  88 ;;; VOPs which bypass the load form system. It's also used for various
  89 ;;; compiler internal structures like nodes and VOP-INFO (FIXME:
  90 ;;; Why?).
  91 (defun ignore-it (object &optional env)
  92   (declare (type structure!object object))
  93   (declare (ignore object env))
  94   ;; This magic tag is handled specially by the compiler downstream.
  95   :ignore-it)
  96
  97 ;;; machinery used in the implementation of DEF!STRUCT
  98 #+sb-xc-host
  99 (eval-when (:compile-toplevel :load-toplevel :execute)
 100   ;; a description of a DEF!STRUCT call to be stored until we get
 101   ;; enough of the system running to finish processing it
 102   (defstruct delayed-def!struct
 103     (args (required-argument) :type cons)
 104     (package (sane-package) :type package))
 105   ;; a list of DELAYED-DEF!STRUCTs stored until we get DEF!STRUCT
 106   ;; working fully so that we can apply it to them then. After
 107   ;; DEF!STRUCT is made to work fully, this list is processed, then
 108   ;; made unbound, and should no longer be used.
 109   (defvar *delayed-def!structs* nil))
 110 (eval-when (:compile-toplevel :load-toplevel :execute)
 111   ;; Parse the arguments for a DEF!STRUCT call, and return
 112   ;;   (VALUES NAME DEFSTRUCT-ARGS MAKE-LOAD-FORM-FUN DEF!STRUCT-SUPERTYPE),
 113   ;; where NAME is the name of the new type, DEFSTRUCT-ARGS is the
 114   ;; munged result suitable for passing on to DEFSTRUCT,
 115   ;; MAKE-LOAD-FORM-FUN is the make load form function, or NIL if
 116   ;; there's none, and DEF!STRUCT-SUPERTYPE is the direct supertype of
 117   ;; the type if it is another DEF!STRUCT-defined type, or NIL
 118   ;; otherwise.
 119   (defun parse-def!struct-args (nameoid &rest rest)
 120     (multiple-value-bind (name options) ; Note: OPTIONS can change below.
 121         (if (consp nameoid)
 122           (values (first nameoid) (rest nameoid))
 123           (values nameoid nil))
 124       (let* ((include-clause (find :include options :key #'first))
 125              (def!struct-supertype nil) ; may change below
 126              (mlff-clause (find :make-load-form-fun options :key #'first))
 127              (mlff (and mlff-clause (second mlff-clause))))
 128         (when (find :type options :key #'first)
 129           (error "can't use :TYPE option in DEF!STRUCT"))
 130         (when mlff-clause
 131           (setf options (remove mlff-clause options)))
 132         (when include-clause
 133           (setf def!struct-supertype (second include-clause)))
 134         (if (eq name 'structure!object) ; if root of hierarchy
 135           (aver (not include-clause))
 136           (unless include-clause
 137             (setf def!struct-supertype 'structure!object)
 138             (push `(:include ,def!struct-supertype) options)))
 139         (values name `((,name ,@options) ,@rest) mlff def!struct-supertype)))))
 140
 141 ;;; Part of the raison d'etre for DEF!STRUCT is to be able to emulate
 142 ;;; these low-level CMU CL functions in a vanilla ANSI Common Lisp
 143 ;;; cross compilation host. (The emulation doesn't need to be
 144 ;;; efficient, since it's needed for things like dumping objects, not
 145 ;;; inner loops.)
 146 #+sb-xc-host
 147 (progn
 148   (defun %instance-length (instance)
 149     (check-type instance structure!object)
 150     (layout-length (class-layout (sb!xc:find-class (type-of instance)))))
 151   (defun %instance-ref (instance index)
 152     (check-type instance structure!object)
 153     (let* ((class (sb!xc:find-class (type-of instance)))
 154            (layout (class-layout class)))
 155       (if (zerop index)
 156         layout
 157         (let* ((dd (layout-info layout))
 158                (dsd (elt (dd-slots dd) (1- index)))
 159                (accessor (dsd-accessor dsd)))
 160           (declare (type symbol accessor))
 161           (funcall accessor instance)))))
 162   (defun %instance-set (instance index new-value)
 163     (check-type instance structure!object)
 164     (let* ((class (sb!xc:find-class (type-of instance)))
 165            (layout (class-layout class)))
 166       (if (zerop index)
 167         (error "can't set %INSTANCE-REF FOO 0 in cross-compilation host")
 168         (let* ((dd (layout-info layout))
 169                (dsd (elt (dd-slots dd) (1- index)))
 170                (accessor (dsd-accessor dsd)))
 171           (declare (type symbol accessor))
 172           (funcall (fdefinition `(setf ,accessor)) new-value instance))))))
 173
 174 ;;; a helper function for DEF!STRUCT in the #+SB-XC-HOST case: Return
 175 ;;; DEFSTRUCT-style arguments with any class names in the SB!XC
 176 ;;; package (i.e. the name of the class being defined, and/or the
 177 ;;; names of classes in :INCLUDE clauses) converted from SB!XC::FOO to
 178 ;;; CL::FOO.
 179 #+sb-xc-host
 180 (eval-when (:compile-toplevel :load-toplevel :execute)
 181   (defun uncross-defstruct-args (defstruct-args)
 182     (destructuring-bind (name-and-options &rest slots-and-doc) defstruct-args
 183       (multiple-value-bind (name options)
 184           (if (symbolp name-and-options)
 185             (values name-and-options nil)
 186             (values (first name-and-options)
 187                     (rest name-and-options)))
 188         (flet ((uncross-option (option)
 189                  (if (eq (first option) :include)
 190                    (destructuring-bind
 191                        (include-keyword included-name &rest rest)
 192                        option
 193                      `(,include-keyword
 194                        ,(uncross included-name)
 195                        ,@rest))
 196                    option)))
 197           `((,(uncross name)
 198              ,@(mapcar #'uncross-option options))
 199             ,@slots-and-doc))))))
 200
 201 ;;; DEF!STRUCT's arguments are like DEFSTRUCT's arguments, except that
 202 ;;; DEF!STRUCT accepts an extra optional :MAKE-LOAD-FORM-FUN clause.
 203 ;;; DEF!STRUCT also does some magic to ensure that anything it defines
 204 ;;; includes STRUCTURE!OBJECT, so that when CLOS is/becomes available,
 205 ;;; we can hook the DEF!STRUCT system into
 206 ;;;   (DEFMETHOD MAKE-LOAD-FORM ((X STRUCTURE!OBJECT) &OPTIONAL ENV) ..)
 207 ;;; and everything will continue to work.
 208 (defmacro def!struct (&rest args)
 209   (multiple-value-bind (name defstruct-args mlff def!struct-supertype)
 210       (apply #'parse-def!struct-args args)
 211     `(progn
 212        ;; (Putting the DEFSTRUCT here, outside the EVAL-WHEN, seems to
 213        ;; be necessary in order to cross-compile the hash table
 214        ;; implementation. -- WHN 19990809)
 215        (defstruct ,@defstruct-args)
 216        ;; (Putting this SETF here, outside the EVAL-WHEN, seems to be
 217        ;; necessary in order to allow us to put the DEFSTRUCT outside
 218        ;; the EVAL-WHEN.)
 219        (setf (def!struct-type-make-load-form-fun ',name)
 220              ,(if (symbolp mlff)
 221                 `',mlff
 222                 mlff)
 223              (def!struct-supertype ',name)
 224              ',def!struct-supertype)
 225        ;; This bit of commented-out code hasn't been needed for quite
 226        ;; some time, but the comments here about why not might still
 227        ;; be useful to me until I finally get the system to work. When
 228        ;; I do remove all this, I should be sure also to remove the
 229        ;; "outside the EVAL-WHEN" comments above, since they will no
 230        ;; longer make sense. -- WHN 19990803
 231        ;;(eval-when (:compile-toplevel :load-toplevel :execute)
 232        ;;  ;; (The DEFSTRUCT used to be in here, but that failed when trying
 233        ;;  ;; to cross-compile the hash table implementation.)
 234        ;;  ;;(defstruct ,@defstruct-args)
 235        ;;  ;; The (SETF (DEF!STRUCT-TYPE-MAKE-LOAD-FORM-FUN ..) ..) used to
 236        ;;  ;; be in here too, but that failed an assertion in the SETF
 237        ;;  ;; definition once we moved the DEFSTRUCT outside.)
 238        ;;  )
 239        #+sb-xc-host ,(let ((u (uncross-defstruct-args defstruct-args)))
 240                        (if (boundp '*delayed-def!structs*)
 241                            `(push (make-delayed-def!struct :args ',u)
 242                                   *delayed-def!structs*)
 243                            `(sb!xc:defstruct ,@u)))
 244        ',name)))
 245
 246 ;;; When building the cross-compiler, this function has to be called
 247 ;;; some time after SB!XC:DEFSTRUCT is set up, in order to take care
 248 ;;; of any processing which had to be delayed until then.
 249 #+sb-xc-host
 250 (defun force-delayed-def!structs ()
 251   (if (boundp '*delayed-def!structs*)
 252     (progn
 253       (mapcar (lambda (x)
 254                 (let ((*package* (delayed-def!struct-package x)))
 255                   ;; KLUDGE(?): EVAL is almost always the wrong thing.
 256                   ;; However, since we have to map DEFSTRUCT over the
 257                   ;; list, and since ANSI declined to specify any
 258                   ;; functional primitives corresponding to the
 259                   ;; DEFSTRUCT macro, it seems to me that EVAL is
 260                   ;; required in there somewhere..
 261                   (eval `(sb!xc:defstruct ,@(delayed-def!struct-args x)))))
 262               (reverse *delayed-def!structs*))
 263       ;; We shouldn't need this list any more. Making it unbound
 264       ;; serves as a signal to DEF!STRUCT that it needn't delay
 265       ;; DEF!STRUCTs any more. It is also generally a good thing for
 266       ;; other reasons: it frees garbage, and it discourages anyone
 267       ;; else from pushing anything else onto the list later.
 268       (makunbound '*delayed-def!structs*))
 269     ;; This condition is probably harmless if it comes up when
 270     ;; interactively experimenting with the system by loading a source
 271     ;; file into it more than once. But it's worth warning about it
 272     ;; because it definitely shouldn't come up in an ordinary build
 273     ;; process.
 274     (warn "*DELAYED-DEF!STRUCTS* is already unbound.")))
 275
 276 ;;; The STRUCTURE!OBJECT abstract class is the base of the type
 277 ;;; hierarchy for objects which have/use DEF!STRUCT functionality.
 278 ;;; (The extra hackery in DEF!STRUCT-defined things isn't needed for
 279 ;;; STRUCTURE-OBJECTs defined by ordinary, post-warm-init programs, so
 280 ;;; it's only put into STRUCTURE-OBJECTs which inherit from
 281 ;;; STRUCTURE!OBJECT.)
 282 (def!struct (structure!object (:constructor nil)))
 283 \f
 284 ;;;; hooking this all into the standard MAKE-LOAD-FORM system
 285
 286 ;;; MAKE-LOAD-FORM for DEF!STRUCT-defined types
 287 (defun structure!object-make-load-form (object &optional env)
 288   (declare (ignore env))
 289   (funcall (def!struct-type-make-load-form-fun (type-of object))
 290            object))
 291
 292 ;;; Do the right thing at cold load time.
 293 ;;;
 294 ;;; (Eventually this MAKE-LOAD-FORM function be overwritten by CLOS's
 295 ;;; generic MAKE-LOAD-FORM, at which time a STRUCTURE!OBJECT method
 296 ;;; should be added to call STRUCTURE!OBJECT-MAKE-LOAD-FORM.)
 297 (setf (symbol-function 'sb!xc:make-load-form)
 298       #'structure!object-make-load-form)
 299
 300 ;;; Do the right thing in the vanilla ANSI CLOS of the
 301 ;;; cross-compilation host. (Something similar will have to be done in
 302 ;;; our CLOS, too, but later, some time long after the toplevel forms
 303 ;;; of this file have run.)
 304 #+sb-xc-host
 305 (defmethod make-load-form ((obj structure!object) &optional (env nil env-p))
 306   (if env-p
 307     (structure!object-make-load-form obj env)
 308     (structure!object-make-load-form obj)))