Express do-instance-tagged-slot in terms of do-layout-bitmap

Remove the option to scan the padding slot and/or specify a layout.

src/code/early-raw-slots.lisp

@@ -187,87 +187,43 @@
          (let ((,index-var (dsd-index ,dsd)))
            ,@body)))))
 
-;;; PAD, if T (the default), includes a final word that may be present at the
-;;; end of the structure due to alignment requirements.
-;;; TYPE should be supplied only by 'editcore' for manipulating an on-disk core
-;;; mapped an address that differs from the core's desired address.
-;;; I have a love/hate relationship with this macro.
-;;; It's more efficient than iterating over DSD-SLOTS, and editcore would
-;;; have a harder time using DSD-SLOTS. But it's too complicated.
 #-sb-xc-host
-(defmacro do-instance-tagged-slot ((index-var thing &optional (pad t) layout-expr)
-                                   &body body)
-  (with-unique-names (instance layout mask bitmap-index bitmap-limit nbits end)
-    `(let* ((,instance ,thing)
-            (,layout ,(or layout-expr
-                          ;; %INSTANCE-LAYOUT is defknown'ed to return a LAYOUT,
-                          ;; but heap walking might encounter an instance with no layout,
-                          ;; hence the need to access the layout without assuming
-                          ;; it to be of that type.
-                          `(let ((l #+compact-instance-header
-                                    (%primitive %instance-layout ,instance)
-                                    #-compact-instance-header
-                                    (%instance-ref ,instance 0)))
-                             (truly-the sb-vm:layout
-                                        (if (eql l 0) #.(find-layout 't) l)))))
-            ;; Shift out 1 bit if skipping bit 0 of the 0th mask word
-            ;; because it's not user-visible data.
-            (,mask (ash (%raw-instance-ref/signed-word ,layout (type-dd-length sb-vm:layout))
-                        (- sb-vm:instance-data-start)))
-            ;; Start counting from the next bitmap word as we've consumed one already
-            (,bitmap-index (1+ (type-dd-length sb-vm:layout)))
-            (,bitmap-limit (%instance-length ,layout))
-            ;; If this was the last word of the bitmap, then the high bit
-            ;; is infinitely sign-extended, and we can keep right-shifting
-            ;; the mask word indefinitely. Most bitmaps will have only 1 word.
-            (,nbits (if (= ,bitmap-index ,bitmap-limit)
-                        sb-vm:instance-length-mask
-                        (- sb-vm:n-word-bits sb-vm:instance-data-start))))
-       (declare (type sb-vm:signed-word ,mask)
-                (type fixnum ,nbits))
-       (do ((,index-var sb-vm:instance-data-start (1+ ,index-var))
-            (,end ,(if pad
-                       ;; target instances have an odd number of payload words.
-                       `(logior (%instance-length ,instance) 1)
-                       `(%instance-length ,instance))))
-           ((>= ,index-var ,end))
-         (declare (type index ,index-var))
-         ;; If mask was fully consumed, fetch the next bitmap word
-         (when (zerop ,nbits)
-           (setq ,mask (%raw-instance-ref/signed-word ,layout ,bitmap-index)
-                 ,nbits (if (= (incf (truly-the index ,bitmap-index)) ,bitmap-limit)
-                            sb-vm:instance-length-mask
-                            sb-vm:n-word-bits)))
-         (when (logbitp 0 ,mask) ,@body)
-         (setq ,mask (ash ,mask -1)
-               ,nbits (truly-the fixnum (1- ,nbits)))))))
+(progn
+(defmacro do-layout-bitmap ((index-var taggedp-var layout count) &body guts)
+  `(let* ((layout ,layout)
+          (bitmap-word-index (bitmap-start layout))
+          (bitmap-word-limit (%instance-length layout))
+          ;; Shift out 1 bit if skipping bit 0 of the 0th mask word
+          ;; because it's not user-visible data.
+          (mask (ash (%raw-instance-ref/signed-word
+                      layout (prog1 bitmap-word-index (incf bitmap-word-index)))
+                     ,(- sb-vm:instance-data-start)))
+          ;; If this was the last word of the bitmap, then the high bit
+          ;; is infinitely sign-extended, and we can keep right-shifting
+          ;; the mask word indefinitely. Most bitmaps will have only 1 word.
+          (nbits (if (= bitmap-word-index bitmap-word-limit)
+                     ,sb-vm:instance-length-mask
+                     ,(- sb-vm:n-word-bits sb-vm:instance-data-start))))
+     (declare (type sb-vm:signed-word mask)
+              (type fixnum nbits))
+     (do ((,index-var sb-vm:instance-data-start (1+ ,index-var))
+          (end ,count))
+         ((>= ,index-var end))
+       (declare (type (unsigned-byte 14) ,index-var end))
+       ;; If mask was fully consumed, fetch the next bitmap word
+       (when (zerop nbits)
+         (setq mask (%raw-instance-ref/signed-word layout bitmap-word-index)
+               nbits (if (= (incf (truly-the index bitmap-word-index))
+                            bitmap-word-limit)
+                         ,sb-vm:instance-length-mask
+                         ,sb-vm:n-word-bits)))
+       (let ((,taggedp-var (logbitp 0 mask))) ,@guts)
+       (setq mask (ash mask -1)
+             nbits (truly-the fixnum (1- nbits))))))
 
-;;; FIXME: at the earliest opportunity, either express DO-INSTANCE-TAGGED-SLOT
-;;; in terms of DO-LAYOUT-BITMAP or apply this diff:
-#|
---- a/src/code/early-raw-slots.lisp
-+++ b/src/code/early-raw-slots.lisp
-@@ -194,6 +194,7 @@
- ;;; I have a love/hate relationship with this macro.
- ;;; It's more efficient than iterating over DSD-SLOTS, and editcore would
- ;;; have a harder time using DSD-SLOTS. But it's too complicated.
- #-sb-xc-host
- (defmacro do-instance-tagged-slot ((index-var thing &optional (pad t) layout-expr)
-                                    &body body)
-@@ -210,12 +211,12 @@
-                                     (%instance-ref ,instance 0)))
-                              (truly-the sb-vm:layout
-                                         (if (eql l 0) #.(find-layout 't) l)))))
-+            (,bitmap-index (bitmap-start ,layout))
-             ;; Shift out 1 bit if skipping bit 0 of the 0th mask word
-             ;; because it's not user-visible data.
--            (,mask (ash (%raw-instance-ref/signed-word ,layout (type-dd-length sb-vm:layout))
-+            (,mask (ash (%raw-instance-ref/signed-word
-+                         ,layout (prog1 ,bitmap-index (incf ,bitmap-index)))
-                         (- sb-vm:instance-data-start)))
--            ;; Start counting from the next bitmap word as we've consumed one already
--            (,bitmap-index (1+ (type-dd-length sb-vm:layout)))
-             (,bitmap-limit (%instance-length ,layout))
-             ;; If this was the last word of the bitmap, then the high bit
-             ;; is infinitely sign-extended, and we can keep right-shifting
-|#
+(defmacro do-instance-tagged-slot ((index-var thing) &body body)
+  (with-unique-names (instance layout taggedp)
+    `(let* ((,instance ,thing)
+            (,layout (%instance-layout ,instance)))
+       (do-layout-bitmap (,index-var ,taggedp ,layout (%instance-length ,instance))
+         (when ,taggedp ,@body))))))

src/code/room.lisp

@@ -913,9 +913,13 @@ We could try a few things to mitigate this:
          ;; These two are in fact generally the most frequently occurring type.
          ,.(make-case 'cons `(car ,obj) `(cdr ,obj))
          ,.(make-case* 'instance
-            `(progn
+            ;; %INSTANCE-LAYOUT is defknown'ed to return a LAYOUT,
+            ;; but heap walking might encounter an instance with no layout,
+            ;; hence the need to access the slot opaquely.
+            `(unless (eql 0 #+compact-instance-header (%primitive %instance-layout ,obj)
+                            #-compact-instance-header (%instance-ref ,obj 0))
                (,functoid (%instance-layout ,obj) ,@more)
-               (do-instance-tagged-slot (.i. ,obj nil)
+               (do-instance-tagged-slot (.i. ,obj)
                  (,functoid (%instance-ref ,obj .i.) ,@more))))
          (function
           (typecase ,obj

src/code/target-defstruct.lisp

@@ -317,39 +317,6 @@
       (funcall fun classoid)))
   t)
 
-;;; Similar to DO-INSTANCE-TAGGED-SLOT but iterating over all words.
-(defmacro do-layout-bitmap ((index-var taggedp-var layout count) &body guts)
-  `(let* ((layout ,layout)
-          (bitmap-word-index (bitmap-start layout))
-          (bitmap-word-limit (%instance-length layout))
-          ;; Shift out 1 bit if skipping bit 0 of the 0th mask word
-          ;; because it's not user-visible data.
-          (mask (ash (%raw-instance-ref/signed-word
-                      layout (prog1 bitmap-word-index (incf bitmap-word-index)))
-                     ,(- sb-vm:instance-data-start)))
-          ;; If this was the last word of the bitmap, then the high bit
-          ;; is infinitely sign-extended, and we can keep right-shifting
-          ;; the mask word indefinitely. Most bitmaps will have only 1 word.
-          (nbits (if (= bitmap-word-index bitmap-word-limit)
-                     ,sb-vm:instance-length-mask
-                     ,(- sb-vm:n-word-bits sb-vm:instance-data-start))))
-     (declare (type sb-vm:signed-word mask)
-              (type fixnum nbits))
-     (do ((,index-var sb-vm:instance-data-start (1+ ,index-var))
-          (end ,count))
-         ((>= ,index-var end))
-       (declare (type (unsigned-byte 14) ,index-var end))
-       ;; If mask was fully consumed, fetch the next bitmap word
-       (when (zerop nbits)
-         (setq mask (%raw-instance-ref/signed-word layout bitmap-word-index)
-               nbits (if (= (incf (truly-the index bitmap-word-index))
-                            bitmap-word-limit)
-                         ,sb-vm:instance-length-mask
-                         ,sb-vm:n-word-bits)))
-       (let ((,taggedp-var (logbitp 0 mask))) ,@guts)
-       (setq mask (ash mask -1)
-             nbits (truly-the fixnum (1- nbits))))))
-
 ;;; Copy any old kind of structure.
 (defun copy-structure (structure)
   "Return a copy of STRUCTURE with the same (EQL) slot values."

tests/raw-slots-interleaved.impure.lisp

@@ -118,8 +118,8 @@
     (sb-kernel:do-instance-tagged-slot (i *afoo*)
       (push `(,i ,(sb-kernel:%instance-ref *afoo* i)) l))
     (assert (equalp (nreverse l)
-                    #-64-bit `((3 aaay) (9 bee) (13 cee) (14 #xdead))
-                    #+64-bit `((2 aaay) (6 bee) (9 cee) (10 #xdead))))))
+                    #-64-bit `((3 aaay) (9 bee) (13 cee))
+                    #+64-bit `((2 aaay) (6 bee) (9 cee))))))
 
 (defvar *anotherfoo* (make-foo1))