common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Add a debugging utility

Browse source
This commit is contained in:
Douglas Katzman 2023-03-07 23:09:02 -05:00
parent 57c0635ebc
commit 6e13782082
1 changed files with 45 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

45
tests/arena.impure.lisp
View file

@ -510,3 +510,48 @@
(unless (every #'line-ok lines)
(format *error-output* "Failure:~{~%~A~}~%" lines)
(error "Bad result for ~S" symbol))))))))))
(defun collect-objects-pointing-off-heap ()
(let (list)
(flet ((add-to-result (obj referent)
;; If this is a code component and it points to fixups
;; which are a bignum in a random place, assume that it's an ELF core
;; and that the packed fixup locs are in a ".rodata" section
(cond ((and (typep obj 'sb-kernel:code-component)
(typep referent 'bignum)
(eq referent (%code-fixups obj)))
nil)
(t
(push (cons (sb-ext:make-weak-pointer obj)
(if (sb-ext:stack-allocated-p referent t)
:stack
(sb-sys:int-sap (get-lisp-obj-address referent))))
list)))))
(macrolet ((visit (referent)
`(let ((r ,referent))
(when (and (is-lisp-pointer (get-lisp-obj-address r))
(not (heap-allocated-p r))
(add-to-result obj r))
(return-from done)))))
(sb-vm:map-allocated-objects
(lambda (obj type size)
(declare (ignore type size))
(block done
(do-referenced-object (obj visit)
(t
:extend
(case (widetag-of obj)
(#.sb-vm:value-cell-widetag
(visit (value-cell-ref obj)))
(t
(warn "Unknown widetag ~x" (widetag-of obj))))))))
:all)))
list))
(defun show-objects-pointing-off-heap (list)
(dolist (x list)
(let ((obj (weak-pointer-value (car x))))
(if (typep obj '(or sb-kernel:code-component
symbol))
(format t "~s -> ~s~%" obj (cdr x))
(format t "~s -> ~s~%" (type-of obj) (cdr x))))))