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))))
"
sb-introspect has MAP-ROOT