[PATCH 3/6] Add runtime support for reading debug information from ELF

[Andy Wingo]

* module/Makefile.am:
* module/system/vm/debug.scm: New module.

* module/system/vm/elf.scm (elf-section-by-name): New helper.
  (elf-symbol-table-len): New helper.

* test-suite/tests/rtl.test: Add test for finding debug info.
---
 module/Makefile.am         |    1 +
 module/system/vm/debug.scm |  137 ++++++++++++++++++++++++++++++++++++++++++++
 module/system/vm/elf.scm   |   22 ++++++-
 test-suite/tests/rtl.test  |   23 +++++++-
 4 files changed, 180 insertions(+), 3 deletions(-)
 create mode 100644 module/system/vm/debug.scm

diff --git a/module/Makefile.am b/module/Makefile.am
index d6450be..74a9621 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -357,6 +357,7 @@ SYSTEM_SOURCES =                            \
   system/vm/traps.scm                          \
   system/vm/trap-state.scm                     \
   system/vm/assembler.scm                      \
+  system/vm/debug.scm                          \
   system/vm/vm.scm                             \
   system/foreign.scm                           \
   system/xref.scm                              \
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
new file mode 100644
index 0000000..d7d62da
--- /dev/null
+++ b/module/system/vm/debug.scm
@@ -0,0 +1,137 @@
+;;; Guile runtime debug information
+
+;;; Copyright (C) 2013 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 
USA
+
+;;; Code:
+
+(define-module (system vm debug)
+  #:use-module (system vm elf)
+  #:use-module (system vm objcode)
+  #:use-module (system foreign)
+  #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-9)
+  #:export (debug-context-image
+            u32-offset->addr
+
+            program-debug-info-name
+            program-debug-info-context
+            program-debug-info-image
+            program-debug-info-offset
+            program-debug-info-addr
+            program-debug-info-u32-offset
+            program-debug-info-u32-offset-end
+
+            find-debug-context
+            find-program-debug-info))
+
+(define-record-type <debug-context>
+  (make-debug-context elf base text-base)
+  debug-context?
+  (elf debug-context-elf)
+  (base debug-context-base)
+  (text-base debug-context-text-base))
+
+(define (debug-context-image context)
+  (elf-bytes (debug-context-elf context)))
+
+(define (u32-offset->addr offset context)
+  (+ (debug-context-base context) (* offset 4)))
+
+(define-record-type <program-debug-info>
+  (make-program-debug-info context name offset size)
+  program-debug-info?
+  (context program-debug-info-context)
+  (name program-debug-info-name)
+  (offset program-debug-info-offset)
+  (size program-debug-info-size))
+
+(define (program-debug-info-addr pdi)
+  (+ (program-debug-info-offset pdi)
+     (debug-context-text-base (program-debug-info-context pdi))
+     (debug-context-base (program-debug-info-context pdi))))
+
+(define (program-debug-info-image pdi)
+  (debug-context-image (program-debug-info-context pdi)))
+
+(define (program-debug-info-u32-offset pdi)
+  ;; OFFSET is in bytes from the beginning of the text section.  TEXT-BASE
+  ;; is in bytes from the beginning of the image.  Return OFFSET as a u32
+  ;; index from the start of the image.
+  (/ (+ (program-debug-info-offset pdi)
+        (debug-context-text-base (program-debug-info-context pdi)))
+     4))
+
+(define (program-debug-info-u32-offset-end pdi)
+  ;; Return the end position as a u32 index from the start of the image.
+  (/ (+ (program-debug-info-size pdi)
+        (program-debug-info-offset pdi)
+        (debug-context-text-base (program-debug-info-context pdi)))
+     4))
+
+(define (find-debug-context addr)
+  (let* ((bv (find-mapped-elf-image addr))
+         (elf (parse-elf bv))
+         (base (pointer-address (bytevector->pointer (elf-bytes elf))))
+         (text-base (elf-section-offset
+                     (or (elf-section-by-name elf ".rtl-text")
+                         (error "ELF object has no text section")))))
+    (make-debug-context elf base text-base)))
+
+(define (find-elf-symbol elf text-offset)
+  (and=>
+   (elf-section-by-name elf ".symtab")
+   (lambda (symtab)
+     (let ((len (elf-symbol-table-len symtab))
+           (strtab (elf-section elf (elf-section-link symtab))))
+       ;; The symbols should be sorted, but maybe somehow that fails
+       ;; (for example if multiple objects are relinked together).  So,
+       ;; a modicum of tolerance.
+       (define (bisect)
+         ;; FIXME: Implement.
+         #f)
+       (define (linear-search)
+         (let lp ((n 0))
+           (and (< n len)
+                (let ((sym (elf-symbol-table-ref elf symtab n strtab)))
+                  (if (and (<= (elf-symbol-value sym) text-offset)
+                           (< text-offset (+ (elf-symbol-value sym)
+                                             (elf-symbol-size sym))))
+                      sym
+                      (lp (1+ n)))))))
+       (or (bisect) (linear-search))))))
+
+(define* (find-program-debug-info addr #:optional
+                                  (context (find-debug-context addr)))
+  (cond
+   ((find-elf-symbol (debug-context-elf context)
+                     (- addr
+                        (debug-context-base context)
+                        (debug-context-text-base context)))
+    => (lambda (sym)
+         (make-program-debug-info context
+                                  (and=> (elf-symbol-name sym)
+                                         ;; The name might be #f if
+                                         ;; the string table was
+                                         ;; stripped somehow.
+                                         (lambda (x)
+                                           (and (string? x)
+                                                (not (string-null? x))
+                                                (string->symbol x))))
+                                  (elf-symbol-value sym)
+                                  (elf-symbol-size sym))))
+   (else #f)))
diff --git a/module/system/vm/elf.scm b/module/system/vm/elf.scm
index 2f4dee6..5167459 100644
--- a/module/system/vm/elf.scm
+++ b/module/system/vm/elf.scm
@@ -123,8 +123,8 @@
 
             parse-elf
             elf-segment elf-segments
-            elf-section elf-sections elf-sections-by-name
-            elf-symbol-table-ref
+            elf-section elf-sections elf-section-by-name elf-sections-by-name
+            elf-symbol-table-len elf-symbol-table-ref
 
             parse-elf-note
             elf-note-name elf-note-desc elf-note-type))
@@ -796,6 +796,17 @@
           (utf8->string out))
         (lp (1+ end)))))
 
+(define (elf-section-by-name elf name)
+  (let ((off (elf-section-offset (elf-section elf (elf-shstrndx elf)))))
+    (let lp ((n (elf-shnum elf)))
+      (and (> n 0)
+           (let ((section (elf-section elf (1- n))))
+             (if (equal? (string-table-ref (elf-bytes elf)
+                                           (+ off (elf-section-name section)))
+                         name)
+                 section
+                 (lp (1- n))))))))
+
 (define (elf-sections-by-name elf)
   (let* ((sections (elf-sections elf))
          (off (elf-section-offset (list-ref sections (elf-shstrndx elf)))))
@@ -895,6 +906,13 @@
      (else (error "invalid word size" word-size)))
    bv offset byte-order sym))
 
+(define (elf-symbol-table-len section)
+  (let ((len (elf-section-size section))
+        (entsize (elf-section-entsize section)))
+    (unless (and (not (zero? entsize)) (zero? (modulo len entsize)))
+      (error "bad symbol table" section))
+    (/ len entsize)))
+
 (define* (elf-symbol-table-ref elf section n #:optional strtab)
   (let ((bv (elf-bytes elf))
         (byte-order (elf-byte-order elf))
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index 74a7ff3..d3923b4 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -18,7 +18,9 @@
 
 (define-module (tests rtl)
   #:use-module (test-suite lib)
-  #:use-module (system vm assembler))
+  #:use-module (system vm assembler)
+  #:use-module (system vm program)
+  #:use-module (system vm debug))
 
 (define-syntax-rule (assert-equal val expr)
   (let ((x val))
@@ -247,3 +249,22 @@
                             (end-program)))))
                     ((make-top-incrementor))
                     *top-val*))))
+
+(with-test-prefix "debug contexts"
+  (let ((return-3 (assemble-program
+                   '((begin-program return-3)
+                     (assert-nargs-ee/locals 0 1)
+                     (load-constant 0 3)
+                     (return 0)
+                     (end-program)))))
+    (pass-if "program name"
+      (and=> (find-program-debug-info (rtl-program-code return-3))
+             (lambda (pdi)
+               (equal? (program-debug-info-name pdi)
+                       'return-3))))
+
+    (pass-if "program address"
+      (and=> (find-program-debug-info (rtl-program-code return-3))
+             (lambda (pdi)
+               (equal? (program-debug-info-addr pdi)
+                       (rtl-program-code return-3)))))))
-- 
1.7.10.4