From 0128bb9c38b28e74675e72539a162b5cf9848845 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Thu, 7 Nov 2013 17:53:04 +0100
Subject: [PATCH] add fold-all-debug-contexts, fold-source-locations

* module/system/vm/objcode.scm:
* libguile/objcodes.c (scm_all_mapped_elf_images): New proc.

* module/system/vm/debug.scm (fold-all-debug-contexts):
  (fold-source-locations): New public interfaces.
---
 libguile/objcodes.c          | 23 ++++++++++++++++++
 module/system/vm/debug.scm   | 45 +++++++++++++++++++++++++++++++++++-
 module/system/vm/objcode.scm |  2 +-
 3 files changed, 68 insertions(+), 2 deletions(-)

diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index 734bddeb3..fa4e28b39 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -741,6 +741,27 @@ scm_find_mapped_elf_image (SCM ip)
   return result;
 }
 
+static SCM
+scm_all_mapped_elf_images (void)
+{
+  SCM result = SCM_EOL;
+
+  scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
+  {
+    size_t n;
+    for (n = 0; n < mapped_elf_images_count; n++)
+      {
+        signed char *data = (signed char *) mapped_elf_images[n].start;
+        size_t len = mapped_elf_images[n].end - mapped_elf_images[n].start;
+        result = scm_cons (scm_c_take_gc_bytevector (data, len, SCM_BOOL_F),
+                           result);
+      }
+  }
+  scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
+
+  return result;
+}
+
 
 /*
  * Scheme interface
@@ -881,6 +902,8 @@ scm_init_objcodes (void)
 
   scm_c_define_gsubr ("find-mapped-elf-image", 1, 0, 0,
                       (scm_t_subr) scm_find_mapped_elf_image);
+  scm_c_define_gsubr ("all-mapped-elf-images", 0, 0, 0,
+                      (scm_t_subr) scm_all_mapped_elf_images);
 
   scm_c_define ("word-size", scm_from_size_t (sizeof(SCM)));
   scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER));
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)))
diff --git a/module/system/vm/objcode.scm b/module/system/vm/objcode.scm
index e2a93d791..4a0e9924a 100644
--- a/module/system/vm/objcode.scm
+++ b/module/system/vm/objcode.scm
@@ -23,7 +23,7 @@
             bytecode->objcode objcode->bytecode
             load-thunk-from-file load-thunk-from-memory
             word-size byte-order
-            find-mapped-elf-image))
+            find-mapped-elf-image all-mapped-elf-images))
 
 (load-extension (string-append "libguile-" (effective-version))
                 "scm_init_objcodes")