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 (file)
--- 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))))
 \f
 ;;;; 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 (file)
--- 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 (file)
--- 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"