(and layout (typep (layout-info layout) 'defstruct-description))))
(sb!xc:defmacro %make-structure-instance-macro (dd slot-specs &rest slot-vars)
- `(truly-the ,(dd-name dd)
- ,(if (compiler-layout-ready-p (dd-name dd))
- `(%make-structure-instance ,dd ,slot-specs ,@slot-vars)
- ;; Non-toplevel defstructs don't have a layout at compile time,
- ;; so we need to construct the actual function at runtime -- but
- ;; we cache it at the call site, so that we don't perform quite
- ;; so horribly.
- `(let* ((cell (load-time-value (list nil)))
- (fun (car cell)))
- (if (functionp fun)
- (funcall fun ,@slot-vars)
- (funcall (setf (car cell)
- (%make-structure-instance-allocator ,dd ,slot-specs))
- ,@slot-vars))))))
+ (if (compiler-layout-ready-p (dd-name dd))
+ `(truly-the ,(dd-name dd)
+ (%make-structure-instance ,dd ,slot-specs ,@slot-vars))
+ ;; Non-toplevel defstructs don't have a layout at compile time,
+ ;; so we need to construct the actual function at runtime -- but
+ ;; we cache it at the call site, so that we don't perform quite
+ ;; so horribly.
+ `(let* ((cell (load-time-value (list nil)))
+ (fun (car cell)))
+ (if (functionp fun)
+ (funcall fun ,@slot-vars)
+ (funcall (setf (car cell)
+ (%make-structure-instance-allocator ,dd ,slot-specs))
+ ,@slot-vars)))))
(declaim (ftype (sfunction (defstruct-description list) function)
%make-structure-instance-allocator))
;;; "A lie can travel halfway round the world while the truth is
;;; putting on its shoes." -- Mark Twain
-(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
- ;; the raw slot type, or T for a non-raw slot
- ;;
- ;; (Non-raw slots are in the ordinary place you'd expect, directly
- ;; indexed off the instance pointer. Raw slots are indexed from the end
- ;; of the instance and skipped by GC.)
- (raw-type (missing-arg) :type (or symbol cons) :read-only t)
- ;; What operator is used to access a slot of this type?
- (accessor-name (missing-arg) :type symbol :read-only t)
- (init-vop (missing-arg) :type symbol :read-only t)
- ;; How many words are each value of this type?
- (n-words (missing-arg) :type (and index (integer 1)) :read-only t)
- ;; Necessary alignment in units of words. Note that instances
- ;; themselves are aligned by exactly two words, so specifying more
- ;; than two words here would not work.
- (alignment 1 :type (integer 1 2) :read-only t))
-
- (defvar *raw-slot-data-list*
+;; information about how a slot of a given DSD-RAW-TYPE is to be accessed
+(defstruct (raw-slot-data
+ (:copier nil)
+ (:predicate nil))
+ ;; the raw slot type, or T for a non-raw slot
+ ;;
+ ;; (Non-raw slots are in the ordinary place you'd expect, directly
+ ;; indexed off the instance pointer. Raw slots are indexed from the end
+ ;; of the instance and skipped by GC.)
+ (raw-type (missing-arg) :type (or symbol cons) :read-only t)
+ ;; What operator is used to access a slot of this type?
+ (accessor-name (missing-arg) :type symbol :read-only t)
+ (init-vop (missing-arg) :type symbol :read-only t)
+ ;; How many words are each value of this type?
+ (n-words (missing-arg) :type (and index (integer 1)) :read-only t)
+ ;; Necessary alignment in units of words. Note that instances
+ ;; themselves are aligned by exactly two words, so specifying more
+ ;; than two words here would not work.
+ (alignment 1 :type (integer 1 2) :read-only t)
+ (comparer (missing-arg) :type function :read-only t))
+
+(defvar *raw-slot-data-list*
+ (macrolet ((make-comparer (accessor-name)
+ `(lambda (index x y)
+ (declare (optimize speed (safety 0)))
+ (= (,accessor-name x index)
+ (,accessor-name y index)))))
(let ((double-float-alignment
- ;; white list of architectures that can load unaligned doubles:
- #!+(or x86 x86-64 ppc) 1
- ;; at least sparc, mips and alpha can't:
- #!-(or x86 x86-64 ppc) 2))
+ ;; white list of architectures that can load unaligned doubles:
+ #!+(or x86 x86-64 ppc) 1
+ ;; at least sparc, mips and alpha can't:
+ #!-(or x86 x86-64 ppc) 2))
(list
(make-raw-slot-data :raw-type 'sb!vm:word
:accessor-name '%raw-instance-ref/word
:init-vop 'sb!vm::raw-instance-init/word
- :n-words 1)
+ :n-words 1
+ :comparer (make-comparer %raw-instance-ref/word))
(make-raw-slot-data :raw-type 'single-float
:accessor-name '%raw-instance-ref/single
:init-vop 'sb!vm::raw-instance-init/single
;; would really benefit is (UNSIGNED-BYTE
;; 32), but that is a subtype of FIXNUM, so
;; we store it unraw anyway. :-( -- DFL
- :n-words 1)
+ :n-words 1
+ :comparer (make-comparer %raw-instance-ref/single))
(make-raw-slot-data :raw-type 'double-float
:accessor-name '%raw-instance-ref/double
:init-vop 'sb!vm::raw-instance-init/double
:alignment double-float-alignment
- :n-words (/ 8 sb!vm:n-word-bytes))
+ :n-words (/ 8 sb!vm:n-word-bytes)
+ :comparer (make-comparer %raw-instance-ref/double))
(make-raw-slot-data :raw-type 'complex-single-float
:accessor-name '%raw-instance-ref/complex-single
:init-vop 'sb!vm::raw-instance-init/complex-single
- :n-words (/ 8 sb!vm:n-word-bytes))
+ :n-words (/ 8 sb!vm:n-word-bytes)
+ :comparer (make-comparer %raw-instance-ref/complex-single))
(make-raw-slot-data :raw-type 'complex-double-float
:accessor-name '%raw-instance-ref/complex-double
:init-vop 'sb!vm::raw-instance-init/complex-double
:alignment double-float-alignment
- :n-words (/ 16 sb!vm:n-word-bytes))
+ :n-words (/ 16 sb!vm:n-word-bytes)
+ :comparer (make-comparer %raw-instance-ref/complex-double))
#!+long-float
(make-raw-slot-data :raw-type long-float
:accessor-name '%raw-instance-ref/long
:init-vop 'sb!vm::raw-instance-init/long
- :n-words #!+x86 3 #!+sparc 4)
+ :n-words #!+x86 3 #!+sparc 4
+ :comparer (make-comparer %raw-instance-ref/long))
#!+long-float
(make-raw-slot-data :raw-type complex-long-float
:accessor-name '%raw-instance-ref/complex-long
:init-vop 'sb!vm::raw-instance-init/complex-long
- :n-words #!+x86 6 #!+sparc 8)))))
+ :n-words #!+x86 6 #!+sparc 8
+ :comparer (make-comparer %raw-instance-ref/complex-long))))))
+
(defun raw-slot-words (type)
(let ((rsd (find type *raw-slot-data-list* :key #'raw-slot-data-raw-type)))
(if rsd
((not inherited)
(stuff `(declaim (inline ,name ,@(unless (dsd-read-only slot)
`((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
- ;; weird.)
(stuff `(defun ,name (structure)
(declare (type ,ltype structure))
(the ,slot-type (elt structure ,index))))
;;; Given name and options, return a DD holding that info.
(defun parse-defstruct-name-and-options (name-and-options)
(destructuring-bind (name &rest options) name-and-options
- (aver name) ; A null name doesn't seem to make sense here.
(let ((dd (make-defstruct-description name))
(predicate-named-p nil))
(dolist (option options)
(let* ((accessor-name (dsd-accessor-name dsd))
(dsd-type (dsd-type dsd)))
(when accessor-name
- (setf (info :function :structure-accessor accessor-name) dd)
(let ((inherited (accessor-inherited-data accessor-name dd)))
(cond
((not inherited)
+ (setf (info :function :structure-accessor accessor-name) dd)
(multiple-value-bind (reader-designator writer-designator)
(slot-accessor-transforms dd dsd)
(sb!xc:proclaim `(ftype (sfunction (,dtype) ,dsd-type)
arg
(arglist `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)))
(vars name)
- (arg-type (get-slot name))))
+ (arg-type (get-slot name))
+ (when supplied-test-p
+ (vars supplied-test))))
(t
(do-default arg)))))
(arglist `(,wot ,(if def-p def slot-def)
,@(if supplied-test-p `(,supplied-test) nil)))
(vars name)
- (arg-type type key name))))
+ (arg-type type key name)
+ (when supplied-test-p
+ (vars supplied-test)))))
(do-default key t))))
(when allowp
projects / sbcl.git / blobdiff