(sb!c::compiler-note
"implementation limitation: ~
Non-toplevel DEFSTRUCT constructors are slow.")
- (let ((layout (gensym "LAYOUT")))
+ (with-unique-names (layout)
`(let ((,layout (info :type :compiler-layout ',name)))
(unless (typep (layout-info ,layout) 'defstruct-description)
(error "Class is not a structure class: ~S" ',name))
(: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.
-(defun dsd-name (dsd)
- (intern (string (dsd-%name dsd))
- (if (dsd-accessor-name dsd)
- (symbol-package (dsd-accessor-name dsd))
- (sane-package))))
\f
;;;; typed (non-class) structures
\f
;;;; shared machinery for inline and out-of-line slot accessor functions
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
;; information about how a slot of a given DSD-RAW-TYPE is to be accessed
(defstruct raw-slot-data
;; class names which creates fast but non-cold-loadable,
;; non-compact code. In this context, we'd rather have
;; compact, cold-loadable code. -- WHN 19990928
- (declare (notinline sb!xc:find-class))
+ (declare (notinline find-classoid))
,@(let ((pf (dd-print-function defstruct))
(po (dd-print-object defstruct))
(x (gensym))
(t nil))))
,@(let ((pure (dd-pure defstruct)))
(cond ((eq pure t)
- `((setf (layout-pure (class-layout
- (sb!xc:find-class ',name)))
+ `((setf (layout-pure (classoid-layout
+ (find-classoid ',name)))
t)))
((eq pure :substructure)
- `((setf (layout-pure (class-layout
- (sb!xc:find-class ',name)))
+ `((setf (layout-pure (classoid-layout
+ (find-classoid ',name)))
0)))))
,@(let ((def-con (dd-default-constructor defstruct)))
(when (and def-con (not (dd-alternate-metaclass defstruct)))
- `((setf (structure-class-constructor (sb!xc:find-class ',name))
+ `((setf (structure-classoid-constructor (find-classoid ',name))
#',def-con))))))))
;;; shared logic for CL:DEFSTRUCT and SB!XC:DEFSTRUCT
((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
(specifier-type (dd-element-type dd))))
(error ":TYPE option mismatch between structures ~S and ~S"
(dd-name dd) included-name))
- (let ((included-class (sb!xc:find-class included-name nil)))
- (when included-class
+ (let ((included-classoid (find-classoid included-name nil)))
+ (when included-classoid
;; It's not particularly well-defined to :INCLUDE any of the
;; CMU CL INSTANCE weirdosities like CONDITION or
;; GENERIC-FUNCTION, and it's certainly not ANSI-compliant.
- (let* ((included-layout (class-layout included-class))
+ (let* ((included-layout (classoid-layout included-classoid))
(included-dd (layout-info included-layout)))
(when (and (dd-alternate-metaclass included-dd)
;; As of sbcl-0.pre7.73, anyway, STRUCTURE-OBJECT
(super
(if include
(compiler-layout-or-lose (first include))
- (class-layout (sb!xc:find-class
- (or (first superclass-opt)
- 'structure-object))))))
+ (classoid-layout (find-classoid
+ (or (first superclass-opt)
+ 'structure-object))))))
(if (eq (dd-name info) 'ansi-stream)
;; a hack to add the CL:STREAM class as a mixin for ANSI-STREAMs
(concatenate 'simple-vector
(layout-inherits super)
(vector super
- (class-layout (sb!xc:find-class 'stream))))
+ (classoid-layout (find-classoid 'stream))))
(concatenate 'simple-vector
(layout-inherits super)
(vector super)))))
(declare (type defstruct-description dd))
;; We set up LAYOUTs even in the cross-compilation host.
- (multiple-value-bind (class layout old-layout)
+ (multiple-value-bind (classoid layout old-layout)
(ensure-structure-class dd inherits "current" "new")
(cond ((not old-layout)
- (unless (eq (class-layout class) layout)
+ (unless (eq (classoid-layout classoid) layout)
(register-layout layout)))
(t
(let ((old-dd (layout-info old-layout)))
(fmakunbound (dsd-accessor-name slot))
(unless (dsd-read-only slot)
(fmakunbound `(setf ,(dsd-accessor-name slot)))))))
- (%redefine-defstruct class old-layout layout)
- (setq layout (class-layout class))))
- (setf (sb!xc:find-class (dd-name dd)) class)
+ (%redefine-defstruct classoid old-layout layout)
+ (setq layout (classoid-layout classoid))))
+ (setf (find-classoid (dd-name dd)) classoid)
;; Various other operations only make sense on the target SBCL.
#-sb-xc-host
(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
(inherits (vector (find-layout t)
(find-layout 'instance))))
- (multiple-value-bind (class layout old-layout)
+ (multiple-value-bind (classoid layout old-layout)
(multiple-value-bind (clayout clayout-p)
(info :type :compiler-layout (dd-name dd))
(ensure-structure-class dd
"compiled"
:compiler-layout clayout))
(cond (old-layout
- (undefine-structure (layout-class old-layout))
- (when (and (class-subclasses class)
+ (undefine-structure (layout-classoid old-layout))
+ (when (and (classoid-subclasses classoid)
(not (eq layout old-layout)))
(collect ((subs))
- (dohash (class layout (class-subclasses class))
+ (dohash (classoid layout (classoid-subclasses classoid))
(declare (ignore layout))
- (undefine-structure class)
- (subs (class-proper-name class)))
+ (undefine-structure classoid)
+ (subs (classoid-proper-name classoid)))
(when (subs)
(warn "removing old subclasses of ~S:~% ~S"
- (sb!xc:class-name class)
+ (classoid-name classoid)
(subs))))))
(t
- (unless (eq (class-layout class) layout)
+ (unless (eq (classoid-layout classoid) layout)
(register-layout layout :invalidate nil))
- (setf (sb!xc:find-class (dd-name dd)) class)))
+ (setf (find-classoid (dd-name dd)) classoid)))
;; At this point the class should be set up in the INFO database.
;; But the logic that enforces this is a little tangled and
;; scattered, so it's not obvious, so let's check.
- (aver (sb!xc:find-class (dd-name dd) nil))
+ (aver (find-classoid (dd-name dd) nil))
(setf (info :type :compiler-layout (dd-name dd)) layout))
(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
(collect ((moved)
(retyped))
(dolist (name (intersection onames nnames))
- (let ((os (find name oslots :key #'dsd-name))
- (ns (find name nslots :key #'dsd-name)))
- (unless (subtypep (dsd-type ns) (dsd-type os))
+ (let ((os (find name oslots :key #'dsd-name :test #'string=))
+ (ns (find name nslots :key #'dsd-name :test #'string=)))
+ (unless (sb!xc:subtypep (dsd-type ns) (dsd-type os))
(retyped name))
(unless (and (= (dsd-index os) (dsd-index ns))
(eq (dsd-raw-type os) (dsd-raw-type ns)))
(moved name))))
(values (moved)
(retyped)
- (set-difference onames nnames)))))
+ (set-difference onames nnames :test #'string=)))))
;;; If we are redefining a structure with different slots than in the
;;; currently loaded version, give a warning and return true.
-(defun redefine-structure-warning (class old new)
+(defun redefine-structure-warning (classoid old new)
(declare (type defstruct-description old new)
- (type sb!xc:class class)
- (ignore class))
+ (type classoid classoid)
+ (ignore classoid))
(let ((name (dd-name new)))
(multiple-value-bind (moved retyped deleted) (compare-slots old new)
(when (or moved retyped deleted)
;;; structure CLASS to have the specified NEW-LAYOUT. We signal an
;;; error with some proceed options and return the layout that should
;;; be used.
-(defun %redefine-defstruct (class old-layout new-layout)
- (declare (type sb!xc:class class) (type layout old-layout new-layout))
- (let ((name (class-proper-name class)))
+(defun %redefine-defstruct (classoid old-layout new-layout)
+ (declare (type classoid classoid)
+ (type layout old-layout new-layout))
+ (let ((name (classoid-proper-name classoid)))
(restart-case
(error "~@<attempt to redefine the ~S class ~S incompatibly with the current definition~:@>"
'structure-object
(destructuring-bind
(&optional
name
- (class 'sb!xc:structure-class)
- (constructor 'make-structure-class))
+ (class 'structure-classoid)
+ (constructor 'make-structure-classoid))
(dd-alternate-metaclass info)
(declare (ignore name))
- (insured-find-class (dd-name info)
- (if (eq class 'sb!xc:structure-class)
- (lambda (x)
- (typep x 'sb!xc:structure-class))
- (lambda (x)
- (sb!xc:typep x (sb!xc:find-class class))))
- (fdefinition constructor)))
- (setf (class-direct-superclasses class)
+ (insured-find-classoid (dd-name info)
+ (if (eq class 'structure-classoid)
+ (lambda (x)
+ (sb!xc:typep x 'structure-classoid))
+ (lambda (x)
+ (sb!xc:typep x (find-classoid class))))
+ (fdefinition constructor)))
+ (setf (classoid-direct-superclasses class)
(if (eq (dd-name info) 'ansi-stream)
;; a hack to add CL:STREAM as a superclass mixin to ANSI-STREAMs
- (list (layout-class (svref inherits (1- (length inherits))))
- (layout-class (svref inherits (- (length inherits) 2))))
- (list (layout-class (svref inherits (1- (length inherits)))))))
- (let ((new-layout (make-layout :class class
+ (list (layout-classoid (svref inherits (1- (length inherits))))
+ (layout-classoid (svref inherits (- (length inherits) 2))))
+ (list (layout-classoid
+ (svref inherits (1- (length inherits)))))))
+ (let ((new-layout (make-layout :classoid class
:inherits inherits
:depthoid (length inherits)
:length (dd-length info)
(;; This clause corresponds to an assertion in REDEFINE-LAYOUT-WARNING
;; of classic CMU CL. I moved it out to here because it was only
;; exercised in this code path anyway. -- WHN 19990510
- (not (eq (layout-class new-layout) (layout-class old-layout)))
+ (not (eq (layout-classoid new-layout) (layout-classoid old-layout)))
(error "shouldn't happen: weird state of OLD-LAYOUT?"))
((not *type-system-initialized*)
(setf (layout-info old-layout) info)
;;; over this type, clearing the compiler structure type info, and
;;; undefining all the associated functions.
(defun undefine-structure (class)
- (let ((info (layout-info (class-layout class))))
+ (let ((info (layout-info (classoid-layout class))))
(when (defstruct-description-p info)
(let ((type (dd-name info)))
(remhash type *typecheckfuns*)
(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