From: Nikodemus Siivola Date: Thu, 18 Sep 2008 20:19:47 +0000 (+0000) Subject: 1.0.20.9: fix DEFINE-STRUCTURE-SLOT-ADDRESSOR to work with raw slots as well X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=cccc20daac3d6d4e1086f387055aa0b6ff8f47d1;p=sbcl.git 1.0.20.9: fix DEFINE-STRUCTURE-SLOT-ADDRESSOR to work with raw slots as well * Not needed yet, but soon enough... Only one caveat: the instance passed to the addressor must not be an instance of a subclass! * Also hopefully fix build on non-x86oids (a missing IGNORABLE declaraction), and remove pointless MACROEXPAND from ATOMIC-INCF. (We could keep it, but COMPARE-AND-SWAP should at least behave the same.) --- diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 07dd5b4..aac8f2d 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -310,6 +310,11 @@ :accessor-name '%raw-instance-ref/complex-long :init-vop 'sb!vm::raw-instance-init/complex-long :n-words #!+x86 6 #!+sparc 8))))) +(defun raw-slot-words (type) + (let ((rsd (find type *raw-slot-data-list* :key #'raw-slot-data-raw-type))) + (if rsd + (raw-slot-data-n-words rsd) + (error "Invalid raw slot type: ~S" type)))) ;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its ;;;; close personal friend SB!XC:DEFSTRUCT) diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp index 2e0a9df..0d1febe 100644 --- a/src/code/late-extensions.lisp +++ b/src/code/late-extensions.lisp @@ -48,12 +48,15 @@ ;;; Used internally, but it would be nice to provide something ;;; like this for users as well. - +;;; +;;; FIXME / IMPORTANT: If the slot is raw, the address is correct only for +;;; instances of the specified class, not its subclasses! #!+sb-thread (defmacro define-structure-slot-addressor (name &key structure slot) (let* ((dd (find-defstruct-description structure t)) (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name))) - (index (when slotd (dsd-index slotd)))) + (index (when slotd (dsd-index slotd))) + (raw-type (dsd-raw-type slotd))) (unless index (error "Slot ~S not found in ~S." slot structure)) `(progn @@ -63,7 +66,11 @@ (sb!ext:truly-the sb!vm:word (+ (sb!kernel:get-lisp-obj-address instance) - (- (* ,(+ sb!vm:instance-slots-offset index) sb!vm:n-word-bytes) + (- (* ,(if (eq t raw-type) + (+ sb!vm:instance-slots-offset index) + (- (1+ (sb!kernel::dd-instance-length dd)) sb!vm:instance-slots-offset index + (1- (sb!kernel::raw-slot-words raw-type)))) + sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))))) (defmacro compare-and-swap (place old new &environment env) @@ -160,7 +167,7 @@ EXPERIMENTAL: Interface subject to change." (def %compare-and-swap-symbol-value (symbol) symbol-value) (def %compare-and-swap-svref (vector index) svref)) -(defmacro atomic-incf (place &optional (diff 1) &environment env) +(defmacro atomic-incf (place &optional (diff 1)) #!+sb-doc "Atomically increments PLACE by DIFF, and returns the value of PLACE before the increment. @@ -179,41 +186,40 @@ and (SIGNED-BYTE 64) on 64 bit platforms. EXPERIMENTAL: Interface subject to change." (flet ((invalid-place () (error "Invalid first argument to ATOMIC-INCF: ~S" place))) - (let ((place (macroexpand place env))) - (unless (consp place) + (unless (consp place) + (invalid-place)) + (destructuring-bind (op &rest args) place + (when (cdr args) (invalid-place)) - (destructuring-bind (op &rest args) place - (when (cdr args) - (invalid-place)) - (let ((dd (info :function :structure-accessor op))) - (if dd - (let* ((structure (dd-name dd)) - (slotd (find op (dd-slots dd) :key #'dsd-accessor-name)) - (index (dsd-index slotd)) - (type (dsd-type slotd))) - (declare (ignorable index)) - (unless (and (eq 'sb!vm:word (dsd-raw-type slotd)) - (type= (specifier-type type) (specifier-type 'sb!vm:word))) - (error "ATOMIC-INCF requires a slot of type (UNSIGNED-BYTE ~S), not ~S: ~S" - sb!vm:n-word-bits type place)) - (when (dsd-read-only slotd) - (error "Cannot use ATOMIC-INCF with structure accessor for a read-only slot: ~S" - place)) - #!+(or x86 x86-64) - `(truly-the sb!vm:word - (%raw-instance-atomic-incf/word (the ,structure ,@args) - ,index - (the sb!vm:signed-word ,diff))) - ;; No threads outside x86 and x86-64 for now, so this is easy... - #!-(or x86 x86-64) - (with-unique-names (structure old) - `(sb!sys:without-interrupts - (let* ((,structure ,@args) - (,old (,op ,structure))) - (setf (,op ,structure) (logand #.(1- (ash 1 sb!vm:n-word-bits)) - (+ ,old (the sb!vm:signed-word ,diff)))) - ,old)))) - (invalid-place))))))) + (let ((dd (info :function :structure-accessor op))) + (if dd + (let* ((structure (dd-name dd)) + (slotd (find op (dd-slots dd) :key #'dsd-accessor-name)) + (index (dsd-index slotd)) + (type (dsd-type slotd))) + (declare (ignorable structure index)) + (unless (and (eq 'sb!vm:word (dsd-raw-type slotd)) + (type= (specifier-type type) (specifier-type 'sb!vm:word))) + (error "ATOMIC-INCF requires a slot of type (UNSIGNED-BYTE ~S), not ~S: ~S" + sb!vm:n-word-bits type place)) + (when (dsd-read-only slotd) + (error "Cannot use ATOMIC-INCF with structure accessor for a read-only slot: ~S" + place)) + #!+(or x86 x86-64) + `(truly-the sb!vm:word + (%raw-instance-atomic-incf/word (the ,structure ,@args) + ,index + (the sb!vm:signed-word ,diff))) + ;; No threads outside x86 and x86-64 for now, so this is easy... + #!-(or x86 x86-64) + (with-unique-names (structure old) + `(sb!sys:without-interrupts + (let* ((,structure ,@args) + (,old (,op ,structure))) + (setf (,op ,structure) (logand #.(1- (ash 1 sb!vm:n-word-bits)) + (+ ,old (the sb!vm:signed-word ,diff)))) + ,old)))) + (invalid-place)))))) (defun call-hooks (kind hooks &key (on-error :error)) (dolist (hook hooks) diff --git a/version.lisp-expr b/version.lisp-expr index 3ab0ae5..c08e1e7 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.20.8" +"1.0.20.9"