summaryrefslogtreecommitdiff
path: root/module/system/vm/debug.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/system/vm/debug.scm')
-rw-r--r--module/system/vm/debug.scm45
1 files changed, 44 insertions, 1 deletions
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index e5eb9bead..c66c15b3b 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -31,6 +31,7 @@
#:use-module (system foreign)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold))
#:use-module (srfi srfi-9)
#:export (debug-context-image
debug-context-base
@@ -55,6 +56,7 @@
arity-is-case-lambda?
debug-context-from-image
+ fold-all-debug-contexts
for-each-elf-symbol
find-debug-context
find-program-debug-info
@@ -74,7 +76,8 @@
source-line-for-user
source-column
find-source-for-addr
- find-program-sources))
+ find-program-sources
+ fold-source-locations))
;;; A compiled procedure comes from a specific loaded ELF image. A
;;; debug context identifies that image.
@@ -153,6 +156,15 @@ offset from the beginning of the ELF image in 32-bit units."
(error "ELF object has no text section")))))
(make-debug-context elf base text-base)))
+(define (fold-all-debug-contexts proc seed)
+ "Fold @var{proc} over debug contexts corresponding to all images that
+are mapped at the time this procedure is called. Any images mapped
+during the fold are omitted."
+ (fold (lambda (image seed)
+ (proc (debug-context-from-image image) seed))
+ seed
+ (all-mapped-elf-images)))
+
(define (find-debug-context addr)
"Find and return the debugging context corresponding to the ELF image
containing the address @var{addr}. @var{addr} is an integer. If no ELF
@@ -543,3 +555,34 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
(reverse sources))))))
(else '())))))
(else '())))
+
+(define* (fold-source-locations proc seed context)
+ "Fold @var{proc} over all source locations in @var{context}.
+@var{proc} will be called with two arguments: the source object and the
+seed."
+ (cond
+ ((and context
+ (false-if-exception
+ (elf->dwarf-context (debug-context-elf context))))
+ =>
+ (lambda (dwarf-ctx)
+ (let ((base (debug-context-base context)))
+ (fold
+ (lambda (die seed)
+ (cond
+ ((die-line-prog die)
+ =>
+ (lambda (prog)
+ (let lp ((seed seed))
+ (call-with-values
+ (lambda () (line-prog-advance prog))
+ (lambda (pc* file line col)
+ (if pc*
+ (lp
+ (proc (make-source/dwarf (+ pc* base) file line col)
+ seed))
+ seed))))))
+ (else seed)))
+ seed
+ (read-die-roots dwarf-ctx)))))
+ (else seed)))