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))))
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))
(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-definitio n-location slot)))
(ecase (slot-definitio n-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)))))))))
(check-type mode (member :retained :reachable))
(bind ((seen-object-set (make-hash-table :test #'eq)))
(labels ((recurse (object)
(recurse root))))