src/code/target-defstruct.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 the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 (in-package "SB!KERNEL")
  11
  12 (/show0 "target-defstruct.lisp 12")
  13 \f
  14 ;;;; structure frobbing primitives
  15
  16 ;;; Allocate a new instance with LENGTH data slots.
  17 (defun %make-instance (length)
  18   (declare (type index length))
  19   (%make-instance length))
  20
  21 ;;; Given an instance, return its length.
  22 (defun %instance-length (instance)
  23   (declare (type instance instance))
  24   (%instance-length instance))
  25
  26 ;;; Return the value from the INDEXth slot of INSTANCE. This is SETFable.
  27 (defun %instance-ref (instance index)
  28   (%instance-ref instance index))
  29
  30 ;;; Set the INDEXth slot of INSTANCE to NEW-VALUE.
  31 (defun %instance-set (instance index new-value)
  32   (setf (%instance-ref instance index) new-value))
  33
  34 ;;; Normally IR2 converted, definition needed for interpreted structure
  35 ;;; constructors only.
  36 #!+(or sb-eval sb-fasteval)
  37 (defun %make-structure-instance (dd slot-specs &rest slot-values)
  38   (let ((instance (%make-instance (dd-length dd))) ; length = sans header word
  39         (value-index 0))
  40     (declare (index value-index))
  41     (setf (%instance-layout instance) (dd-layout-or-lose dd))
  42     (dolist (spec slot-specs instance)
  43       (destructuring-bind (kind raw-type . index) spec
  44         (if (eq kind :unbound)
  45             (setf (%instance-ref instance index)
  46                   (sb!sys:%primitive make-unbound-marker))
  47             (macrolet ((make-case ()
  48                            `(ecase raw-type
  49                               ((t)
  50                                (setf (%instance-ref instance index) value))
  51                               ,@(map 'list
  52                                  (lambda (rsd)
  53                                    `(,(raw-slot-data-raw-type rsd)
  54                                       (setf (,(raw-slot-data-accessor-name rsd)
  55                                               instance index)
  56                                             value)))
  57                                  *raw-slot-data*))))
  58                 (let ((value (fast-&rest-nth value-index slot-values)))
  59                   (incf value-index)
  60                   (make-case))))))))
  61
  62 (defun %instance-layout (instance)
  63   (%instance-layout instance))
  64
  65 (defun %set-instance-layout (instance new-value)
  66   (%set-instance-layout instance new-value))
  67
  68 (defun %make-funcallable-instance (len)
  69   (%make-funcallable-instance len))
  70
  71 (defun funcallable-instance-p (x)
  72   (funcallable-instance-p x))
  73
  74 (defun %funcallable-instance-info (fin i)
  75   (%funcallable-instance-info fin i))
  76
  77 (defun %set-funcallable-instance-info (fin i new-value)
  78   (%set-funcallable-instance-info fin i new-value))
  79
  80 (defun funcallable-instance-fun (fin)
  81   (%funcallable-instance-function fin))
  82
  83 (defun (setf funcallable-instance-fun) (new-value fin)
  84   (setf (%funcallable-instance-function fin) new-value))
  85 \f
  86 ;;;; target-only parts of the DEFSTRUCT top level code
  87
  88 ;;; A list of hooks designating functions of one argument, the
  89 ;;; classoid, to be called when a defstruct is evaluated.
  90 (!defvar *defstruct-hooks* nil)
  91
  92 ;;; the part of %DEFSTRUCT which makes sense only on the target SBCL
  93 ;;;
  94 (defun %target-defstruct (dd)
  95   (declare (type defstruct-description dd))
  96
  97   #!+(and sb-show (host-feature sb-xc))
  98   (progn (write `(%target-defstruct ,(dd-name dd))) (terpri))
  99
 100   (when (dd-doc dd)
 101     (setf (fdocumentation (dd-name dd) 'structure)
 102           (dd-doc dd)))
 103
 104   (let* ((classoid (find-classoid (dd-name dd)))
 105          (layout (classoid-layout classoid)))
 106     (when (eq (dd-pure dd) t)
 107       (setf (layout-pure layout) t))
 108     ;; Make a vector of EQUALP slots comparators, indexed by (- word-index data-start).
 109     ;; This has to be assigned to something regardless of whether there are
 110     ;; raw slots just in case someone mutates a layout which had raw
 111     ;; slots into one which does not - although that would probably crash
 112     ;; unless no instances exist or all raw slots miraculously contained
 113     ;; bits which were the equivalent of valid Lisp descriptors.
 114     (setf (layout-equalp-tests layout)
 115           (if (eql (layout-bitmap layout) +layout-all-tagged+)
 116               #()
 117               ;; The initial element of NIL means "do not compare".
 118               ;; Ignored words (comparator = NIL) fall into two categories:
 119               ;; - pseudo-ignored, which get compared by their
 120               ;;   predecessor word, as for complex-double-float,
 121               ;; - internal padding words which are truly ignored.
 122               ;; Other words are compared as tagged if the comparator is 0,
 123               ;; or as untagged if the comparator is a type-specific function.
 124               (let ((comparators
 125                      ;; If data-start is 1, subtract 1 because we don't need
 126                      ;; a comparator for the LAYOUT slot.
 127                      (make-array (- (dd-length dd) sb!vm:instance-data-start)
 128                                  :initial-element nil)))
 129                 (dolist (slot (dd-slots dd) comparators)
 130                   ;; -1 because LAYOUT (slot index 0) has no comparator stored.
 131                   (setf (aref comparators
 132                               (- (dsd-index slot) sb!vm:instance-data-start))
 133                         (let ((rsd (dsd-raw-slot-data slot)))
 134                           (if (not rsd)
 135                               0 ; means recurse using EQUALP
 136                               (raw-slot-data-comparer rsd))))))))
 137
 138     (dolist (fun *defstruct-hooks*)
 139       (funcall fun classoid)))
 140
 141   (values))
 142 \f
 143 ;;; Copy any old kind of structure.
 144 (defun copy-structure (structure)
 145   "Return a copy of STRUCTURE with the same (EQL) slot values."
 146   (declare (type structure-object structure))
 147   (let ((layout (%instance-layout structure)))
 148     (when (layout-invalid layout)
 149       (error "attempt to copy an obsolete structure:~%  ~S" structure))
 150     ;; Previously this had to used LAYOUT-LENGTH in the allocation,
 151     ;; to avoid copying random bits from the stack to the heap if you had a
 152     ;; padding word in a stack-allocated instance. This is no longer an issue.
 153     ;; %INSTANCE-LENGTH returns the number of words that are logically in the
 154     ;; instance, with no padding. Using %INSTANCE-LENGTH allows potentially
 155     ;; interesting nonstandard things like variable-length structures.
 156     (let* ((len (%instance-length structure))
 157            (res (%make-instance len)))
 158       (declare (type index len))
 159       (let ((bitmap (layout-bitmap layout)))
 160         ;; Don't assume that %INSTANCE-REF can access the layout.
 161         (setf (%instance-layout res) (%instance-layout structure))
 162         ;; On backends which don't segregate descriptor vs. non-descriptor
 163         ;; registers, we could speed up this code in an obvious way.
 164         (macrolet ((copy-loop (tagged-p &optional step)
 165                      `(do ((i sb!vm:instance-data-start (1+ i)))
 166                           ((>= i len))
 167                         (declare (index i))
 168                         (if ,tagged-p
 169                             (setf (%instance-ref res i)
 170                                   (%instance-ref structure i))
 171                             (setf (%raw-instance-ref/word res i)
 172                                   (%raw-instance-ref/word structure i)))
 173                         ,step)))
 174           (cond ((eql bitmap +layout-all-tagged+) (copy-loop t))
 175                 ;; The fixnum case uses fixnum operations for ODDP and ASH.
 176                 ((fixnump bitmap) ; shift and mask is faster than logbitp
 177                  (copy-loop (oddp (truly-the fixnum bitmap))
 178                             (setq bitmap (ash bitmap -1))))
 179                 (t ; bignum - use LOGBITP to avoid consing more bignums
 180                  (copy-loop (logbitp i bitmap))))))
 181       res)))
 182 \f
 183 ;;; default PRINT-OBJECT method
 184
 185 ;;; Printing formerly called the auto-generated accessor functions,
 186 ;;; but reading the slots more primitively confers several advantages:
 187 ;;; - it works even if the user clobbered an accessor
 188 ;;; - it works if the slot fails a type-check and the reader was SAFE-P,
 189 ;;    i.e. was required to perform a check. This is a feature, not a bug.
 190 (macrolet ((access-fn (dsd)
 191              `(acond ((dsd-raw-slot-data ,dsd)
 192                       (symbol-function (raw-slot-data-accessor-name it)))
 193                      (t #'%instance-ref))))
 194
 195 (defun %default-structure-pretty-print (structure stream name dd)
 196   (pprint-logical-block (stream nil :prefix "#S(" :suffix ")")
 197     (prin1 name stream)
 198     (let ((remaining-slots (dd-slots dd)))
 199       (when remaining-slots
 200         (write-char #\space stream)
 201                  ;; CMU CL had (PPRINT-INDENT :BLOCK 2 STREAM) here,
 202                  ;; but I can't see why. -- WHN 20000205
 203         (pprint-newline :linear stream)
 204         (loop (pprint-pop)
 205               (let ((slot (pop remaining-slots)))
 206                 (output-symbol (dsd-name slot) *keyword-package* stream)
 207                 (write-char #\space stream)
 208                 (pprint-newline :miser stream)
 209                 (output-object (funcall (access-fn slot) structure (dsd-index slot))
 210                                stream)
 211                 (when (null remaining-slots)
 212                   (return))
 213                 (write-char #\space stream)
 214                 (pprint-newline :linear stream)))))))
 215
 216 (defun %default-structure-ugly-print (structure stream name dd)
 217   (descend-into (stream)
 218     (write-string "#S(" stream)
 219     (prin1 name stream)
 220     (do ((index 0 (1+ index))
 221          (limit (or (and (not *print-readably*) *print-length*)
 222                     most-positive-fixnum))
 223          (remaining-slots (dd-slots dd) (cdr remaining-slots)))
 224         ((or (null remaining-slots) (>= index limit))
 225          (write-string (if remaining-slots " ...)" ")") stream))
 226       (declare (type index index))
 227       (write-char #\space stream)
 228       (let ((slot (first remaining-slots)))
 229         (output-symbol (dsd-name slot) *keyword-package* stream)
 230         (write-char #\space stream)
 231         (output-object (funcall (access-fn slot) structure (dsd-index slot))
 232                        stream)))))
 233 ) ; end MACROLET
 234
 235 (defun default-structure-print (structure stream depth)
 236   (declare (ignore depth))
 237   (if (funcallable-instance-p structure)
 238       (print-unreadable-object (structure stream :identity t :type t))
 239       (let* ((layout (%instance-layout structure))
 240              (dd (layout-info layout))
 241              (name (classoid-name (layout-classoid layout))))
 242         (cond ((not dd)
 243                ;; FIXME? this branch may be unnecessary as a consequence
 244                ;; of change f02bee325920166b69070e4735a8a3f295f8edfd which
 245                ;; stopped the badness is a stronger way. It should be the case
 246                ;; that absence of a DD can't happen unless the classoid is absent.
 247                ;; KLUDGE: during PCL build debugging, we can sometimes
 248                ;; attempt to print out a PCL object (with null LAYOUT-INFO).
 249                (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
 250                (prin1 name stream)
 251                (write-char #\space stream)
 252                (write-string "(no LAYOUT-INFO)" stream)))
 253               ((not (dd-slots dd))
 254                ;; the structure type doesn't count as a component for *PRINT-LEVEL*
 255                ;; processing. We can likewise elide the logical block processing,
 256                ;; since all we have to print is the type name. -- CSR, 2004-10-05
 257                (write-string "#S(" stream)
 258                (prin1 name stream)
 259                (write-char #\) stream))
 260               (t
 261                (funcall (if *print-pretty*
 262                             #'%default-structure-pretty-print
 263                             #'%default-structure-ugly-print)
 264                         structure stream name dd))))))
 265
 266 (defmethod print-object ((x structure-object) stream)
 267   (default-structure-print x stream *current-level-in-print*))
 268 \f
 269 (/show0 "target-defstruct.lisp end of file")