Walking heap objects helper function

[Stas Boukarev]

From https://bugs.launchpad.net/sbcl/+bug/310221/comments/1
"
i would welcome an exported function that can walk the objects reachable from a given root. we have some debug code that tries to calculate the size of a web session using the pasted (crippled) iterator. it has a "reachable" and a "retained" mode.

(defun %iterate-descendant-objects (root visitor &key ignored-type (mode :retained))
  (check-type mode (member :retained :reachable))
  (bind ((seen-object-set (make-hash-table :test #'eq)))
    (labels ((recurse (object)
               (unless (or (gethash object seen-object-set)
                           (not ignored-type)
                           (typep object ignored-type))
                 (setf (gethash object seen-object-set) #t)
                 (funcall visitor object)
                 (etypecase object
                   ((or number string character)
                    (values))
                   (cons
                    (recurse (car object))
                    (recurse (cdr object)))
                   (symbol
                    (when (eq mode :reachable)
                      (recurse (symbol-name object))
                      (recurse (symbol-package object))
                      (recurse (symbol-plist object))
                      (when (boundp object)
                        (recurse (symbol-value object)))
                      (when (fboundp object)
                        (recurse (symbol-function object))))
                    (recurse (symbol-name object)))
                   (hash-table
                    ;; TODO handle weak hashtables when mode is :retained
                    (iter (for (key value) :in-hashtable object)
                          (recurse key)
                          (recurse value)))
                   (array
                    (dotimes (i (apply #'* (array-dimensions object)))
                      (recurse (row-major-aref object i))))
                   (structure-object
                    (bind ((class (class-of object)))
                      (dolist (slot (class-slots class))
                        (recurse (slot-value-using-class class object slot)))))
                   (standard-object
                    ;; TODO should grab the underlying vector and check for sb-pcl::*unbound-slot-value-marker*
                    (bind ((class (class-of object)))
                      (dolist (slot (class-slots class))
                        (bind ((slot-location (slot-definition-location slot)))
                          (ecase (slot-definition-allocation slot)
                            (:instance (recurse (if (typep object 'funcallable-standard-object)
                                                    (funcallable-standard-instance-access object slot-location)
                                                    (standard-instance-access object slot-location))))
                            (:class))))))
                   #+sbcl
                   (sb-vm::code-component
                    (let ((length (sb-vm::get-header-data object)))
                      (do ((i sb-vm::code-constants-offset (1+ i)))
                          ((= i length))
                        (recurse (sb-vm::code-header-ref object i)))))
                   #+sbcl
                   (sb-kernel::random-class
                    ;; TODO:
                    )
                   #+sbcl
                   (sb-sys:system-area-pointer
                    ;; TODO:
                    )
                   (function
                    #+sbcl
                    (bind ((widetag (sb-kernel:widetag-of object)))
                      (cond ((= widetag sb-vm:simple-fun-header-widetag)
                             (recurse (sb-kernel:fun-code-header object)))
                            ((= widetag sb-vm:closure-header-widetag)
                             (recurse (sb-kernel:%closure-fun object))
                             (sb-impl::map-closed-over-values #'recurse object))
                            (t (error "Unknown function type ~A" object)))))))))
      (recurse root))))
"

[Douglas Katzman (dougk)]

sb-introspect has MAP-ROOT

[Douglas Katzman (dougk)]

Nothing needs to be done here. MAP-ROOT is enough.