X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=f42de7b711fc36d01638016670d7a67e53734d26;hb=18dc0069cd514c976042766ab9a785c970fe1603;hp=0f25b5dff919d5141b9ecc7bd160bc06e719a86e;hpb=2fdd5c9276ba68458e1186c8ae3b7b5a42729a6f;p=sbcl.git diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 0f25b5d..f42de7b 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -31,20 +31,20 @@ (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)) @@ -251,37 +251,44 @@ ;;; "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 @@ -295,31 +302,38 @@ ;; 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 @@ -527,10 +541,6 @@ ((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)))) @@ -614,7 +624,6 @@ ;;; 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) @@ -1127,10 +1136,10 @@ (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) @@ -1542,7 +1551,9 @@ 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))))) @@ -1573,7 +1584,9 @@ (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