Heap walk safely around */signed vop result

In general any cons with most-positive-word in the car.
I do like the idea of using -1 because it is unambiguously a filler
where (0 . 0) is possibly a real cons.

src/code/room.lisp

@@ -45,6 +45,7 @@
                           complex-array-widetag))
         (setf (svref infos code) info)))
 
+    ;; FIXME: do we still need this ?
     (setf (svref infos filler-widetag) (make-room-info 'filler))
 
     (dotimes (i (length *specialized-array-element-type-properties*))
@@ -189,21 +190,31 @@
         (end (descriptor-sap end)))
     (loop
      (if (sap>= start end) (return))
-     (binding* ((widetag (widetag@baseptr start))
-                (obj (lispobj@baseptr start widetag))
-                ((typecode size)
+     (let ((word (sap-ref-word start 0)))
+       (cond
+         ((= (logand word widetag-mask) filler-widetag) ; pseudo-object
+          (let ((size (+ (* (ash word -8) n-word-bytes) n-word-bytes)))
+            (setq start (sap+ start size))))
+         ((= word most-positive-word)
+          ;; has to be a pseudo-cons resulting from removing an insignificant
+          ;; sign word of a bignum. Don't call FUN
+          (setq start (sap+ start (* 2 n-word-bytes))))
+         (t
+          (binding*
+              ((widetag (widetag@baseptr start))
+               (obj (lispobj@baseptr start widetag))
+               ((typecode size)
                  ;; PRIMITIVE-OBJECT-SIZE works on conses, but they're exceptions already
                  ;; because of absence of a widetag, so may as well not call the sizer.
                  (if (listp obj)
                      (values list-pointer-lowtag (* 2 n-word-bytes))
                      (values widetag (primitive-object-size obj)))))
-       ;; SIZE is surely a fixnum. Non-fixnum would imply at least
-       ;; a 512MB object if 32-bit words, and is inconceivable if 64-bit.
-       ;; But check to be sure.
-       (aver (not (logtest (the fixnum size) lowtag-mask)))
-       (unless (= typecode filler-widetag)
-         (funcall fun obj typecode size))
-       (setq start (sap+ start size))))
+              ;; SIZE is surely a fixnum. Non-fixnum would imply at least
+              ;; a 512MB object if 32-bit words, and is inconceivable if 64-bit.
+              ;; But check to be sure.
+              (aver (not (logtest (the fixnum size) lowtag-mask)))
+              (funcall fun obj typecode size)
+              (setq start (sap+ start size)))))))
     (when strict-bound
      ;; If START is not eq to END, then we have blown past our endpoint.
       #+sb-devel

tests/heapwalk.impure.lisp

@@ -0,0 +1,46 @@
+
+(defun mul (x y) (declare (sb-vm:signed-word x y)) (* x y))
+(compile 'mul)
+
+(defun manymul (n &aux res)
+  (dotimes (i n res)
+    (setq res (mul -4706957933656302 (+ i 1000)))))
+(compile 'manymul)
+
+(defun walk ()
+  (let ((v (make-array 1000))
+        (ct 0))
+    (sb-vm:map-allocated-objects
+     (lambda (obj type size)
+       (declare (ignore size))
+       (when (and (= type sb-vm:list-pointer-lowtag)
+                  (= (sb-kernel:generation-of obj) 0)
+                  (< ct 1000))
+         (setf (aref v ct) obj)
+         (incf ct)))
+     :dynamic)
+    (let ((*print-level* 2)
+          (*print-length* 4))
+      (dotimes (i ct)
+        (princ (aref v i))))))
+(compile 'walk)
+
+;;; As a precondition to asserting that heap walking did not
+;;; visit an alleged cons that is a filler object,
+;;; assert that there is the telltale pattern (if applicable).
+#+(or arm64 x86-64)
+(let ((product (manymul 1)))
+  (sb-sys:with-pinned-objects (product)
+    (let ((word (sb-sys:sap-ref-word
+                 (sb-sys:int-sap (sb-kernel:get-lisp-obj-address product))
+                 (- (ash 2 sb-vm:word-shift) sb-vm:other-pointer-lowtag))))
+      (assert (= word sb-ext:most-positive-word)))))
+
+(manymul 100)
+
+;;; Granted it's not a great idea to assume that anything in the heap
+;;; can be printed, but this test was a fairly easy way to get
+;;;  "Unhandled memory fault at #xFFFFFFFFFFFFFFF0."
+;;; The should print approximately one cons (for GC epoch)
+(with-test (:name :heapwalk-safety)
+  (progn (gc :gen 1) (manymul 100) (walk)))