[Guile-commits] GNU Guile branch, master, updated. v2.1.0-173-g610295e

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=610295ec9dbf3c21a59b4e579d0889ca90c499e6

The branch, master has been updated
       via  610295ec9dbf3c21a59b4e579d0889ca90c499e6 (commit)
      from  c96933fd544aaf14776a1fc3a2986afc6fecb00c (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 610295ec9dbf3c21a59b4e579d0889ca90c499e6
Author: Andy Wingo <address@hidden>
Date:   Thu Aug 29 20:43:03 2013 +0200

    add ability to disassemble ELF images
    
    * module/scripts/disassemble.scm (disassemble): Update to work with
      RTl (and only RTL, as that's the future).
    
    * module/system/vm/debug.scm (for-each-elf-symbol): New public
      interface.
      (debug-context-from-image): New helper.
      (find-debug-context): Use the helper.
    
    * module/system/vm/disassembler.scm (disassemble-image): New public
      interface.

-----------------------------------------------------------------------

Summary of changes:
 module/scripts/disassemble.scm    |   10 +++++++---
 module/system/vm/debug.scm        |   29 ++++++++++++++++++++++++-----
 module/system/vm/disassembler.scm |   25 ++++++++++++++++++++++++-
 3 files changed, 55 insertions(+), 9 deletions(-)

diff --git a/module/scripts/disassemble.scm b/module/scripts/disassemble.scm
index 094d656..3825bc1 100644
--- a/module/scripts/disassemble.scm
+++ b/module/scripts/disassemble.scm
@@ -1,6 +1,6 @@
 ;;; Disassemble --- Disassemble .go files into something human-readable
 
-;; Copyright 2005, 2008, 2009, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright 2005, 2008, 2009, 2011, 2012, 2013 Free Software Foundation, Inc.
 ;;
 ;; This program is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public License
@@ -22,12 +22,14 @@
 
 ;;; Commentary:
 
-;; Usage: disassemble [ARGS]
+;; Usage: disassemble FILE...
 
 ;;; Code:
 
 (define-module (scripts disassemble)
   #:use-module (system vm objcode)
+  #:use-module (system vm program)
+  #:use-module (system vm disassembler)
   #:use-module ((language assembly disassemble)
                 #:renamer (symbol-prefix-proc 'asm:))
   #:export (disassemble))
@@ -36,7 +38,9 @@
 
 (define (disassemble . files)
   (for-each (lambda (file)
-              (asm:disassemble (load-thunk-from-file file)))
+              (let* ((thunk (load-thunk-from-file file))
+                     (elf (find-mapped-elf-image (rtl-program-code thunk))))
+                (disassemble-image elf)))
             files))
 
 (define main disassemble)
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 0e97df5..2289ec3 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -33,6 +33,7 @@
   #:use-module (srfi srfi-9)
   #:export (debug-context-image
             debug-context-base
+            debug-context-text-base
 
             program-debug-info-name
             program-debug-info-context
@@ -52,6 +53,8 @@
             arity-has-keyword-args?
             arity-is-case-lambda?
 
+            debug-context-from-image
+            for-each-elf-symbol
             find-debug-context
             find-program-debug-info
             arity-arguments-alist
@@ -79,6 +82,19 @@
 @var{context}."
   (elf-bytes (debug-context-elf context)))
 
+(define (for-each-elf-symbol context proc)
+  "Call @var{proc} on each symbol in the symbol table of @var{context}."
+  (let ((elf (debug-context-elf context)))
+    (cond
+     ((elf-section-by-name elf ".symtab")
+      => (lambda (symtab)
+           (let ((len (elf-symbol-table-len symtab))
+                 (strtab (elf-section elf (elf-section-link symtab))))
+             (let lp ((n 0))
+               (when (< n len)
+                 (proc (elf-symbol-table-ref elf symtab n strtab))
+                 (lp (1+ n))))))))))
+
 ;;; A program debug info (PDI) is a handle on debugging meta-data for a
 ;;; particular program.
 ;;;
@@ -117,17 +133,20 @@ offset from the beginning of the ELF image in 32-bit 
units."
         (debug-context-text-base (program-debug-info-context pdi)))
      4))
 
-(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."
-  (let* ((bv (find-mapped-elf-image addr))
-         (elf (parse-elf bv))
+(define (debug-context-from-image bv)
+  "Build a debugging context corresponding to a given ELF image."
+  (let* ((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-debug-context addr)
+  "Find and return the debugging context corresponding to the ELF image
+containing the address @var{addr}.  @var{addr} is an integer."
+  (debug-context-from-image (find-mapped-elf-image addr)))
+
 (define (find-elf-symbol elf text-offset)
   "Search the symbol table of @var{elf} for the ELF symbol containing
 @var{text-offset}.  @var{text-offset} is a byte offset in the text
diff --git a/module/system/vm/disassembler.scm 
b/module/system/vm/disassembler.scm
index 138f267..482d68f 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -31,7 +31,8 @@
   #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-4)
-  #:export (disassemble-program))
+  #:export (disassemble-program
+            disassemble-image))
 
 (define-syntax-rule (u32-ref buf n)
   (bytevector-u32-native-ref buf (* n 4)))
@@ -334,3 +335,25 @@ address of that offset."
    (else
     (format port "Debugging information unavailable.~%")))
   (values))
+
+(define* (disassemble-image bv #:optional (port (current-output-port)))
+  (let* ((ctx (debug-context-from-image bv))
+         (base (debug-context-text-base ctx)))
+    (for-each-elf-symbol
+     ctx
+     (lambda (sym)
+       (let ((name (elf-symbol-name sym))
+             (value (elf-symbol-value sym))
+             (size (elf-symbol-size sym)))
+         (format port "Disassembly of ~A at #x~X:\n\n"
+                 (if (and (string? name) (not (string-null? name)))
+                     name
+                     "<unnamed function>")
+                 (+ base value))
+         (disassemble-buffer port
+                             bv
+                             (/ (+ base value) 4)
+                             (/ (+ base value size) 4)
+                             ctx)
+         (display "\n\n" port)))))
+  (values))


hooks/post-receive
-- 
GNU Guile