From 986ce2596822cc0871b609346aaf592348aca596 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Thu, 1 Nov 2001 18:39:01 +0000 Subject: [PATCH] 0.pre7.80: fixed raw slot accessor stuff so that it indexes correctly when it's looking at raw data (rescaling the index by the element size, as the old DEFUN SLOT-ACCESSOR-FORM code did but my new code doesn't) redid *RAW-TYPE->RAWREF-FUN-NAME* as *RAW-SLOT-DATA-LIST* to support this --- src/code/defstruct.lisp | 134 +++++++++++++++++++++++----------------- src/code/target-defstruct.lisp | 23 ++++--- tests/defstruct.impure.lisp | 50 +++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 144 insertions(+), 65 deletions(-) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 8092f7d..6ce0948 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -189,27 +189,59 @@ ;;;; shared machinery for inline and out-of-line slot accessor functions -;;; an alist mapping from raw slot type to the operator used to access -;;; the raw slot -;;; -;;; FIXME: should be shared with other src/code/*defstruct*.lisp code -;;; which refers to e.g. %RAW-REF-SINGLE, but as of sbcl-0.pre7.78 -;;; is only used by out-of-line versions (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *raw-type->rawref-fun-name* - '(;; The compiler thinks that the raw data vector is a vector of - ;; unsigned bytes, so if the slot we want to access actually *is* - ;; an unsigned byte, it'll access the slot for us even if we don't - ;; lie to it at all. - (unsigned-byte . aref) - ;; "A lie can travel halfway round the world while the truth is - ;; putting on its shoes." -- Mark Twain - (single-float . %raw-ref-single) - (double-float . %raw-ref-double) - #!+long-float (long-float . %raw-ref-long) - (complex-single-float . %raw-ref-complex-single) - (complex-double-float . %raw-ref-complex-double) - #!+long-float (complex-long-float . %raw-ref-complex-long)))) + + ;; 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 + ;; + ;; (Raw slots are allocated in the raw slots array in a vector which + ;; the GC doesn't need to scavenge. Non-raw slots are in the + ;; ordinary place you'd expect, directly indexed off the instance + ;; pointer.) + (raw-type (missing-arg) :type (or symbol cons) :read-only t) + ;; What operator is used (on the raw data vector) to access a slot + ;; of this type? + (accessor-name (missing-arg) :type symbol :read-only t) + ;; How many words are each value of this type? (This is used to + ;; rescale the offset into the raw data vector.) + (n-words (missing-arg) :type (and index (integer 1)) :read-only t)) + + (defvar *raw-slot-data-list* + (list + ;; The compiler thinks that the raw data vector is a vector of + ;; word-sized unsigned bytes, so if the slot we want to access + ;; actually *is* an unsigned byte, it'll access the slot for us + ;; even if we don't lie to it at all, just let it use normal AREF. + (make-raw-slot-data :raw-type 'unsigned-byte + :accessor-name 'aref + :n-words 1) + ;; In the other cases, we lie to the compiler, making it use + ;; some low-level AREFish access in order to pun the hapless + ;; bits into some other-than-unsigned-byte meaning. + ;; + ;; "A lie can travel halfway round the world while the truth is + ;; putting on its shoes." -- Mark Twain + (make-raw-slot-data :raw-type 'single-float + :accessor-name '%raw-ref-single + :n-words 1) + (make-raw-slot-data :raw-type 'double-float + :accessor-name '%raw-ref-double + :n-words 2) + (make-raw-slot-data :raw-type 'complex-single-float + :accessor-name '%raw-ref-complex-single + :n-words 2) + (make-raw-slot-data :raw-type 'complex-double-float + :accessor-name '%raw-ref-complex-double + :n-words 4) + #!+long-float + (make-raw-slot-data :raw-type long-float + :accessor-name '%raw-ref-long + :n-words #!+x86 3 #!+sparc 4) + #!+long-float + (make-raw-slot-data :raw-type complex-long-float + :accessor-name '%raw-ref-complex-long + :n-words #!+x86 6 #!+sparc 8)))) ;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its ;;;; close personal friend SB!XC:DEFSTRUCT) @@ -719,7 +751,7 @@ (vector super))))) ;;; Do miscellaneous (LOAD EVAL) time actions for the structure -;;; described by DD. Create the class & LAYOUT, checking for +;;; described by DD. Create the class and LAYOUT, checking for ;;; incompatible redefinition. Define those functions which are ;;; sufficiently stereotyped that we can implement them as standard ;;; closures. @@ -743,7 +775,7 @@ (setq layout (class-layout class)))) (setf (sb!xc:find-class (dd-name dd)) class) - ;; It doesn't make sense to do these in the cross-compilation host. + ;; Various other operations only make sense on the target SBCL. #-sb-xc-host (progn (remhash (dd-name dd) *typecheckfuns*) @@ -766,41 +798,33 @@ (raw-type (dsd-raw-type dsd))) (if (eq raw-type t) ; if not raw slot `(,ref ,instance-name ,(dsd-index dsd)) - (let (;; the operator that we'll use to access one value in - ;; the raw data vector - (rawref (ecase raw-type - ;; The compiler thinks that the raw data - ;; vector is a vector of unsigned bytes, so if - ;; the slot we want to access actually *is* an - ;; unsigned byte, it'll access the slot for - ;; us even if we don't lie to it at all. - (unsigned-byte 'aref) - ;; "A lie can travel halfway round the world while - ;; the truth is putting on its shoes." -- Mark Twain - (single-float '%raw-ref-single) - (double-float '%raw-ref-double) - #!+long-float (long-float '%raw-ref-long) - (complex-single-float '%raw-ref-complex-single) - (complex-double-float '%raw-ref-complex-double) - #!+long-float (complex-long-float - '%raw-ref-complex-long)))) - `(,rawref (,ref ,instance-name ,(dd-raw-index dd)) - ,(dsd-index dsd)))))) + (let* ((raw-slot-data (find raw-type *raw-slot-data-list* + :key #'raw-slot-data-raw-type + :test #'equal)) + (raw-slot-accessor (raw-slot-data-accessor-name raw-slot-data)) + (raw-n-words (raw-slot-data-n-words raw-slot-data))) + (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-EXPANSSION-DESIGNATOR ..)) for the reader +;;; (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR ..)) for the reader ;;; and writer functions of the slot described by DSD. -(defun accessor-inline-expansion-designators (dd dsd) - (values (lambda () - `(lambda (instance) - (declare (type ,(dd-name dd) instance)) - (truly-the ,(dsd-type dsd) - ,(%accessor-place-form dd dsd 'instance)))) - (lambda () - `(lambda (new-value instance) - (declare (type ,(dsd-type dsd) new-value)) - (declare (type ,(dd-name dd) structure-object)) - (setf ,(%accessor-place-form dd dsd 'instance) new-value))))) +(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)) + (dsd-type (dsd-type dsd))) + (values (lambda () + `(lambda (instance) + ,instance-type-decl + (truly-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)))))) ;;; core compile-time setup of any class with a LAYOUT, used even by ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities @@ -894,7 +918,7 @@ (dsd-type (dsd-type dsd))) (when accessor-name (multiple-value-bind (reader-designator writer-designator) - (accessor-inline-expansion-designators dd dsd) + (slot-accessor-inline-expansion-designators dd dsd) (sb!xc:proclaim `(ftype (function (,dtype) ,dsd-type) ,accessor-name)) (setf (info :function :inline-expansion-designator accessor-name) diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 803a61f..702abbc 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -267,20 +267,25 @@ (,dd-ref-fun-name instance dsd-index) ,instance-type-check-form)) ;; raw slot cases - ,@(mapcar (lambda (raw-type-and-rawref-fun-name) - (destructuring-bind (raw-type - . rawref-fun-name) - raw-type-and-rawref-fun-name + ,@(mapcar (lambda (rtd) + (let ((raw-type (raw-slot-data-raw-type rtd)) + (accessor-name + (raw-slot-data-accessor-name rtd)) + (n-words (raw-slot-data-n-words rtd))) `((equal dsd-raw-type ',raw-type) #+sb-xc (/show0 "in raw slot case") (let ((raw-index (dd-raw-index dd))) - (%slotplace-accessor-funs - (,rawref-fun-name (,dd-ref-fun-name + (multiple-value-bind (scaled-dsd-index + misalignment) + (floor dsd-index ,n-words) + (aver (zerop misalignment)) + (%slotplace-accessor-funs + (,accessor-name (,dd-ref-fun-name instance raw-index) - dsd-index) - ,instance-type-check-form))))) - *raw-type->rawref-fun-name*) + scaled-dsd-index) + ,instance-type-check-form)))))) + *raw-slot-data-list*) ;; oops (t (error "internal error: unexpected DSD-RAW-TYPE ~S" diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index 6c26466..e0995f3 100644 --- a/tests/defstruct.impure.lisp +++ b/tests/defstruct.impure.lisp @@ -274,6 +274,56 @@ (test-variant vector-struct :colontype vector) (test-variant list-struct :colontype list) +;;;; testing raw slots harder +;;;; +;;;; The offsets of raw slots need to be rescaled during the punning +;;;; process which is used to access them. That seems like a good +;;;; place for errors to lurk, so we'll try hunting for them by +;;;; verifying that all the raw slot data gets written successfully +;;;; into the object, can be copied with the object, and can then be +;;;; read back out (with none of it ending up bogusly outside the +;;;; object, so that it couldn't be copied, or bogusly overwriting +;;;; some other raw slot). + +(defstruct manyraw + (a (expt 2 30) :type (unsigned-byte 32)) + (b 0.1 :type single-float) + (c 0.2d0 :type double-float) + (d #c(0.3 0.3) :type (complex single-float)) + unraw-slot-just-for-variety + (e #c(0.4d0 0.4d0) :type (complex double-float)) + (aa (expt 2 30) :type (unsigned-byte 32)) + (bb 0.1 :type single-float) + (cc 0.2d0 :type double-float) + (dd #c(0.3 0.3) :type (complex single-float)) + (ee #c(0.4d0 0.4d0) :type (complex double-float))) + +(defvar *manyraw* (make-manyraw)) + +(assert (eql (manyraw-a *manyraw*) (expt 2 30))) +(assert (eql (manyraw-b *manyraw*) 0.1)) +(assert (eql (manyraw-c *manyraw*) 0.2d0)) +(assert (eql (manyraw-d *manyraw*) #c(0.3 0.3))) +(assert (eql (manyraw-e *manyraw*) #c(0.4d0 0.4d0))) +(assert (eql (manyraw-aa *manyraw*) (expt 2 30))) +(assert (eql (manyraw-bb *manyraw*) 0.1)) +(assert (eql (manyraw-cc *manyraw*) 0.2d0)) +(assert (eql (manyraw-dd *manyraw*) #c(0.3 0.3))) +(assert (eql (manyraw-ee *manyraw*) #c(0.4d0 0.4d0))) + +(setf (manyraw-aa *manyraw*) (expt 2 31) + (manyraw-bb *manyraw*) 0.11 + (manyraw-cc *manyraw*) 0.22d0 + (manyraw-dd *manyraw*) #c(0.33 0.33) + (manyraw-ee *manyraw*) #c(0.44d0 0.44d0)) + +(let ((copy (copy-manyraw *manyraw*))) + (assert (eql (manyraw-aa copy) (expt 2 31))) + (assert (eql (manyraw-bb copy) 0.11)) + (assert (eql (manyraw-cc copy) 0.22d0)) + (assert (eql (manyraw-dd copy) #c(0.33 0.33))) + (assert (eql (manyraw-ee copy) #c(0.44d0 0.44d0)))) + ;;; success (format t "~&/returning success~%") (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 602bcfd..f648513 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre7.79" +"0.pre7.80" -- 1.7.10.4