;; slow, so if anyone cares about performance of
;; non-toplevel DEFSTRUCTs, it should be rewritten to be
;; cleverer. -- WHN 2002-10-23
- (sb!c::compiler-note
+ (sb!c:compiler-notify
"implementation limitation: ~
Non-toplevel DEFSTRUCT constructors are slow.")
(with-unique-names (layout)
(:conc-name dsd-)
(:copier nil)
#-sb-xc-host (:pure t))
- ;; string name of slot
- %name
+ ;; name of slot
+ name
;; its position in the implementation sequence
(index (missing-arg) :type fixnum)
;; the name of the accessor function
(def!method print-object ((x defstruct-slot-description) stream)
(print-unreadable-object (x stream :type t)
(prin1 (dsd-name x) stream)))
-
-;;; Return the name of a defstruct slot as a symbol. We store it as a
-;;; string to avoid creating lots of worthless symbols at load time.
-;;;
-;;; FIXME: This has horrible package issues. In many ways, it would
-;;; be very nice to treat the names of structure slots as strings, but
-;;; unfortunately PCL requires slot names to be interned symbols.
-;;; Maybe we want to resurrect something like the old
-;;; SB-SLOT-ACCESSOR-NAME package?
-(defun dsd-name (dsd)
- (intern (dsd-%name dsd)))
\f
;;;; typed (non-class) structures
(let ((inherited (accessor-inherited-data name defstruct)))
(cond
((not inherited)
- (stuff `(proclaim '(inline ,name (setf ,name))))
+ (stuff `(declaim (inline ,name (setf ,name))))
;; FIXME: The arguments in the next two DEFUNs should
;; be gensyms. (Otherwise e.g. if NEW-VALUE happened to
;; be the name of a special variable, things could get
((not (= (cdr inherited) index))
(style-warn "~@<Non-overwritten accessor ~S does not access ~
slot with name ~S (accessing an inherited slot ~
- instead).~:@>" name (dsd-%name slot))))))))
+ instead).~:@>" name (dsd-name slot))))))))
(stuff)))
\f
;;;; parsing
;;; that we modify to get the new slot. This is supplied when handling
;;; included slots.
(defun parse-1-dsd (defstruct spec &optional
- (slot (make-defstruct-slot-description :%name ""
+ (slot (make-defstruct-slot-description :name ""
:index 0
:type t)))
(multiple-value-bind (name default default-p type type-p read-only ro-p)
- (cond
- ((listp spec)
- (destructuring-bind
- (name
- &optional (default nil default-p)
- &key (type nil type-p) (read-only nil ro-p))
- spec
- (values name
- default default-p
- (uncross type) type-p
- read-only ro-p)))
- (t
- (when (keywordp spec)
- (style-warn "Keyword slot name indicates probable syntax ~
- error in DEFSTRUCT: ~S."
- spec))
- spec))
-
- (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)
+ (typecase spec
+ (symbol
+ (when (keywordp spec)
+ (style-warn "Keyword slot name indicates probable syntax ~
+ error in DEFSTRUCT: ~S."
+ spec))
+ spec)
+ (cons
+ (destructuring-bind
+ (name
+ &optional (default nil default-p)
+ &key (type nil type-p) (read-only nil ro-p))
+ spec
+ (values name
+ default default-p
+ (uncross type) type-p
+ read-only ro-p)))
+ (t (error 'simple-program-error
+ :format-control "in DEFSTRUCT, ~S is not a legal slot ~
+ description."
+ :format-arguments (list spec))))
+
+ (when (find name (dd-slots defstruct)
+ :test #'string=
+ :key (lambda (x) (symbol-name (dsd-name x))))
(error 'simple-program-error
:format-control "duplicate slot name ~S"
:format-arguments (list name)))
- (setf (dsd-%name slot) (string name))
+ (setf (dsd-name slot) name)
(setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list slot)))
(let ((accessor-name (if (dd-conc-name defstruct)
;;;
;;; FIXME: This should use the data in *RAW-SLOT-DATA-LIST*.
(defun structure-raw-slot-type-and-size (type)
- (cond #+nil
- (;; FIXME: For now we suppress raw slots, since there are various
- ;; issues about the way that the cross-compiler handles them.
- (not (boundp '*dummy-placeholder-to-stop-compiler-warnings*))
- (values nil nil nil))
- ((and (sb!xc:subtypep type '(unsigned-byte 32))
+ (cond ((and (sb!xc:subtypep type '(unsigned-byte 32))
(multiple-value-bind (fixnum? fixnum-certain?)
(sb!xc:subtypep type 'fixnum)
;; (The extra test for FIXNUM-CERTAIN? here is
(dsd-index included-slot))
(dd-inherited-accessor-alist dd)
:test #'eq :key #'car))
- (parse-1-dsd dd
- modified
- (copy-structure included-slot)))))))
+ (let ((new-slot (parse-1-dsd dd
+ modified
+ (copy-structure included-slot))))
+ (when (and (neq (dsd-type new-slot) (dsd-type included-slot))
+ (not (subtypep (dsd-type included-slot)
+ (dsd-type new-slot)))
+ (dsd-safe-p included-slot))
+ (setf (dsd-safe-p new-slot) nil)
+ ;; XXX: notify?
+ )))))))
\f
;;;; various helper functions for setting up DEFSTRUCTs
(multiple-value-bind (scaled-dsd-index misalignment)
(floor (dsd-index dsd) raw-n-words)
(aver (zerop misalignment))
- `(,raw-slot-accessor (,ref ,instance-name ,(dd-raw-index dd))
- ,scaled-dsd-index))))))
-
-;;; Return inline expansion designators (i.e. values suitable for
-;;; (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR ..)) for the reader
-;;; and writer functions of the slot described by DSD.
-(defun slot-accessor-inline-expansion-designators (dd dsd)
- (let ((instance-type-decl `(declare (type ,(dd-name dd) instance)))
- (accessor-place-form (%accessor-place-form dd dsd 'instance))
+ (let* ((raw-vector-bare-form
+ `(,ref ,instance-name ,(dd-raw-index dd)))
+ (raw-vector-form
+ (if (eq raw-type 'unsigned-byte)
+ (progn
+ (aver (= raw-n-words 1))
+ (aver (eq raw-slot-accessor 'aref))
+ ;; FIXME: when the 64-bit world rolls
+ ;; around, this will need to be reviewed,
+ ;; along with the whole RAW-SLOT thing.
+ `(truly-the (simple-array (unsigned-byte 32) (*))
+ ,raw-vector-bare-form))
+ raw-vector-bare-form)))
+ `(,raw-slot-accessor ,raw-vector-form ,scaled-dsd-index)))))))
+
+;;; Return source transforms for the reader and writer functions of
+;;; the slot described by DSD. They should be inline expanded, but
+;;; source transforms work faster.
+(defun slot-accessor-transforms (dd dsd)
+ (let ((accessor-place-form (%accessor-place-form dd dsd
+ `(the ,(dd-name dd) instance)))
(dsd-type (dsd-type dsd))
(value-the (if (dsd-safe-p dsd) 'truly-the 'the)))
- (values (lambda () `(lambda (instance)
- ,instance-type-decl
- (,value-the ,dsd-type ,accessor-place-form)))
- (lambda () `(lambda (new-value instance)
- (declare (type ,dsd-type new-value))
- ,instance-type-decl
- (setf ,accessor-place-form new-value))))))
+ (values (sb!c:source-transform-lambda (instance)
+ `(,value-the ,dsd-type ,(subst instance 'instance
+ accessor-place-form)))
+ (sb!c:source-transform-lambda (new-value instance)
+ (destructuring-bind (accessor-name &rest accessor-args)
+ accessor-place-form
+ `(,(info :setf :inverse accessor-name)
+ ,@(subst instance 'instance accessor-args)
+ (the ,dsd-type ,new-value)))))))
;;; Return a LAMBDA form which can be used to set a slot.
(defun slot-setter-lambda-form (dd dsd)
- (funcall (nth-value 1
- (slot-accessor-inline-expansion-designators dd dsd))))
+ `(lambda (new-value instance)
+ ,(funcall (nth-value 1 (slot-accessor-transforms dd dsd))
+ '(dummy new-value instance))))
;;; core compile-time setup of any class with a LAYOUT, used even by
;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities
(let ((copier-name (dd-copier-name dd)))
(when copier-name
- (sb!xc:proclaim `(ftype (function (,dtype) ,dtype) ,copier-name))))
+ (sb!xc:proclaim `(ftype (sfunction (,dtype) ,dtype) ,copier-name))))
(let ((predicate-name (dd-predicate-name dd)))
(when predicate-name
- (sb!xc:proclaim `(ftype (function (t) t) ,predicate-name))
+ (sb!xc:proclaim `(ftype (sfunction (t) t) ,predicate-name))
;; Provide inline expansion (or not).
(ecase (dd-type dd)
((structure funcallable-structure)
- ;; Let the predicate be inlined.
+ ;; Let the predicate be inlined.
(setf (info :function :inline-expansion-designator predicate-name)
(lambda ()
`(lambda (x)
(cond
((not inherited)
(multiple-value-bind (reader-designator writer-designator)
- (slot-accessor-inline-expansion-designators dd dsd)
- (sb!xc:proclaim `(ftype (function (,dtype) ,dsd-type)
+ (slot-accessor-transforms dd dsd)
+ (sb!xc:proclaim `(ftype (sfunction (,dtype) ,dsd-type)
,accessor-name))
- (setf (info :function :inline-expansion-designator
- accessor-name)
- reader-designator
- (info :function :inlinep accessor-name)
- :inline)
+ (setf (info :function :source-transform accessor-name)
+ reader-designator)
(unless (dsd-read-only dsd)
(let ((setf-accessor-name `(setf ,accessor-name)))
(sb!xc:proclaim
- `(ftype (function (,dsd-type ,dtype) ,dsd-type)
+ `(ftype (sfunction (,dsd-type ,dtype) ,dsd-type)
,setf-accessor-name))
- (setf (info :function
- :inline-expansion-designator
- setf-accessor-name)
- writer-designator
- (info :function :inlinep setf-accessor-name)
- :inline)))))
+ (setf (info :function :source-transform setf-accessor-name)
+ writer-designator)))))
((not (= (cdr inherited) (dsd-index dsd)))
(style-warn "~@<Non-overwritten accessor ~S does not access ~
slot with name ~S (accessing an inherited slot ~
instead).~:@>"
accessor-name
- (dsd-%name dsd)))))))))
+ (dsd-name dsd)))))))))
(values))
\f
;;;; redefinition stuff
(unless (or defaults boas)
(push (symbolicate "MAKE-" (dd-name defstruct)) defaults))
- (collect ((res))
+ (collect ((res) (names))
(when defaults
- (let ((cname (first defaults)))
- (setf (dd-default-constructor defstruct) cname)
- (res (create-keyword-constructor defstruct creator))
- (dolist (other-name (rest defaults))
- (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
- (res `(declaim (ftype function ',other-name))))))
+ (let ((cname (first defaults)))
+ (setf (dd-default-constructor defstruct) cname)
+ (res (create-keyword-constructor defstruct creator))
+ (names cname)
+ (dolist (other-name (rest defaults))
+ (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
+ (names other-name))))
(dolist (boa boas)
- (res (create-boa-constructor defstruct boa creator)))
+ (res (create-boa-constructor defstruct boa creator))
+ (names (first boa)))
+
+ (res `(declaim (ftype
+ (sfunction *
+ ,(if (eq (dd-type defstruct) 'structure)
+ (dd-name defstruct)
+ '*))
+ ,@(names))))
(res))))
\f
(index 1))
(dolist (slot-name slot-names)
(push (make-defstruct-slot-description
- :%name (symbol-name slot-name)
+ :name slot-name
:index index
:accessor-name (symbolicate conc-name slot-name))
reversed-result)
(let ((,object-gensym ,raw-maker-form))
,@(mapcar (lambda (slot-name)
(let ((dsd (find (symbol-name slot-name) dd-slots
- :key #'dsd-%name
+ :key (lambda (x)
+ (symbol-name (dsd-name x)))
:test #'string=)))
;; KLUDGE: bug 117 bogowarning. Neither
;; DECLAREing the type nor TRULY-THE cut
projects / sbcl.git / blobdiff