[Guile-commits] GNU Guile branch, wip-rtl, updated. v2.0.5-927-g1dc0d7b

[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=1dc0d7b0068d1a313ea4d89a75f80f0786eb9e2e

The branch, wip-rtl has been updated
       via  1dc0d7b0068d1a313ea4d89a75f80f0786eb9e2e (commit)
       via  8d8b61b7949dbd69ca1d303817e1ec6ac20fdd62 (commit)
      from  81dde670d884e558e205fd45186d40073ebacd76 (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 1dc0d7b0068d1a313ea4d89a75f80f0786eb9e2e
Author: Andy Wingo <address@hidden>
Date:   Sun May 5 16:54:55 2013 +0200

    disassembler has more useful annotations
    
    * module/system/vm/disassembler.scm (code-annotation): Provide useful
      annotations for more instructions.
      (disassemble-buffer): Take the debug context as an argument.
      (unpack-scm): Rename from unpack-immediate.
    
    * module/system/vm/debug.scm (debug-context-image, u32-offset->addr)
      (program-debug-info-context, program-debug-info-addr): New exports.
      (<program-debug-info>): Rename size field to addr.

commit 8d8b61b7949dbd69ca1d303817e1ec6ac20fdd62
Author: Andy Wingo <address@hidden>
Date:   Sun May 5 15:40:17 2013 +0200

    add (system vm debug)
    
    * module/Makefile.am:
    * module/system/vm/debug.scm: New module, split out of the
      disassembler.
    
    * module/system/vm/disassembler.scm: Use the new module.

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

Summary of changes:
 module/Makefile.am                |    1 +
 module/system/vm/debug.scm        |  133 ++++++++++++++++++++++++++++++
 module/system/vm/disassembler.scm |  160 +++++++++++++-----------------------
 3 files changed, 192 insertions(+), 102 deletions(-)
 create mode 100644 module/system/vm/debug.scm

diff --git a/module/Makefile.am b/module/Makefile.am
index 9e10f20..049861d 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -355,6 +355,7 @@ SYSTEM_SOURCES =                            \
   system/vm/traps.scm                          \
   system/vm/trap-state.scm                     \
   system/vm/assembler.scm                      \
+  system/vm/debug.scm                          \
   system/vm/disassembler.scm                   \
   system/vm/vm.scm                             \
   system/foreign.scm                           \
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
new file mode 100644
index 0000000..bd8a0d6
--- /dev/null
+++ b/module/system/vm/debug.scm
@@ -0,0 +1,133 @@
+;;; Guile RTL disassembler
+
+;;; Copyright (C) 2001, 2009, 2010, 2012, 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 program)
+  #: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>
+            debug-context-image
+            find-debug-context
+            u32-offset->addr
+
+            <program-debug-info>
+            program-debug-info-name
+            program-debug-info-context
+            program-debug-info-image
+            program-debug-info-addr
+            program-debug-info-u32-offset
+            program-debug-info-u32-offset-end
+
+            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 addr size)
+  program-debug-info?
+  (context program-debug-info-context)
+  (name program-debug-info-name)
+  (addr program-debug-info-addr)
+  (size program-debug-info-size))
+
+(define (program-debug-info-image pdi)
+  (debug-context-image (program-debug-info-context pdi)))
+
+(define (program-debug-info-u32-offset pdi)
+  ;; ADDR is in bytes from the beginning of the text section.  TEXT-BASE
+  ;; is in bytes from the beginning of the image.  Return ADDR as a u32
+  ;; index from the start of the image.
+  (/ (+ (program-debug-info-addr 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-addr pdi)
+        (debug-context-text-base (program-debug-info-context pdi)))
+     4))
+
+(define* (find-debug-context #:key program (addr (rtl-program-code program)))
+  (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 #:key program
+                                  (addr (rtl-program-code program))
+                                  (context (find-debug-context #:addr 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) x)))
+                                  (elf-symbol-value sym)
+                                  (elf-symbol-size sym))))
+   (else #f)))
diff --git a/module/system/vm/disassembler.scm 
b/module/system/vm/disassembler.scm
index 2757d0f..1db44aa 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -20,14 +20,11 @@
 
 (define-module (system vm disassembler)
   #:use-module (system vm instruction)
-  #:use-module (system vm elf)
-  #:use-module (system vm program)
-  #:use-module (system vm objcode)
+  #:use-module (system vm debug)
   #:use-module (system foreign)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-4)
   #:export (disassemble-program))
@@ -53,27 +50,7 @@
   (define (id-append ctx a b)
     (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))))
 
-(define-syntax join-subformats
-  (lambda (x)
-    (syntax-case x ()
-      ((_)
-       #f)
-      ((_ #f rest ...)
-       #'(join-subformats rest ...))
-      ((_ (fmt arg ...))
-       (string? (syntax->datum #'fmt))
-       #'(list fmt arg ...))
-      ((_ (fmt arg ...) #f rest ...)
-       (string? (syntax->datum #'fmt))
-       #'(join-subformats (fmt arg ...) rest ...))
-      ((_ (fmt arg ...) (fmt* arg* ...) rest ...)
-       (and (string? (syntax->datum #'fmt)) (string? (syntax->datum #'fmt*)))
-       (let ((fmt** (string-append (syntax->datum #'fmt)
-                                   ", "
-                                   (syntax->datum #'fmt*))))
-         #`(join-subformats (#,fmt** arg ... arg* ...) rest ...))))))
-
-(define (unpack-immediate n)
+(define (unpack-scm n)
   (pointer->scm (make-pointer n)))
 
 (define (unpack-s24 s)
@@ -239,31 +216,18 @@
                      (cons (u32-ref buf (+ offset len n)) rhead)))))
           (_ (values len list)))))))
 
-(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)
-         #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 (code-annotation code len offset start labels)
+(define (code-annotation code len offset start labels context)
   ;; FIXME: Print names for register loads and stores that correspond to
   ;; access to named locals.
+  (define (reference-scm target)
+    (unpack-scm (u32-offset->addr (+ offset target) context)))
+
+  (define (dereference-scm target)
+    (let ((addr (u32-offset->addr (+ offset target)
+                                  context)))
+      (pointer->scm
+       (dereference-pointer (make-pointer addr)))))
+
   (match code
     (((or 'br
           'br-if-nargs-ne 'br-if-nargs-lt 'br-if-nargs-gt
@@ -275,46 +239,43 @@
      ;; The H is for handler.
      (list "H -> ~A" (vector-ref labels (- (+ offset handler) start))))
     (((or 'make-short-immediate 'make-long-immediate) _ imm)
-     (list "~S" (unpack-immediate imm)))
+     (list "~S" (unpack-scm imm)))
     (('make-long-long-immediate _ high low)
-     (list "~S" (unpack-immediate (logior (ash high 32) low))))
+     (list "~S" (unpack-scm (logior (ash high 32) low))))
     (('assert-nargs-ee/locals nargs locals)
      (list "~a arg~:p, ~a local~:p" nargs locals))
     (('tail-call nargs proc)
      (list "~a arg~:p" nargs))
     (('make-closure dst target free ...)
-     ;; FIXME: Resolve TARGET to a procedure name.  Also we should be
-     ;; disassembling embedded closures as well.
-     #f)
-    (('make-non-immediate U24 N32)
-     ;; FIXME: Print the non-immediate.
-     #f)
-    (('static-ref U24 S32)
-     ;; FIXME: Print the address and the value if initialized.
-     #f)
-    (('static-set! U24 LO32)
-     ;; FIXME: Print the address and the value if initialized.
-     #f)
-    (('link-procedure! U24 L32)
-     ;; FIXME: Resolve TARGET to a procedure name.
-     #f)
+     (let* ((addr (u32-offset->addr (+ offset target) context))
+            (pdi (find-program-debug-info #:addr addr #:context context)))
+       ;; FIXME: Disassemble embedded closures as well.
+       (list "~A at 0x~X"
+             (or (and pdi (program-debug-info-name pdi))
+                 "(anonymous procedure)")
+             addr)))
+    (('make-non-immediate dst target)
+     (list "address@hidden" (reference-scm target)))
+    (((or 'static-ref 'static-set!) _ target)
+     (list "address@hidden" (dereference-scm target)))
+    (('link-procedure! src target)
+     (let* ((addr (u32-offset->addr (+ offset target) context))
+            (pdi (find-program-debug-info #:addr addr #:context context)))
+       (list "~A at 0x~X"
+             (or (and pdi (program-debug-info-name pdi))
+                 "(anonymous procedure)")
+             addr)))
     (('resolve-module dst name public)
      (list "~a" (if (zero? public) "private" "public")))
-    (('toplevel-ref dst var-offset mod-offset sym-offset)
-     ;; FIXME: Print module, symbol, and cached variable.
-     #f)
-    (('toplevel-set! src var-offset mod-offset sym-offset)
-     ;; FIXME: Print module, symbol, and cached variable.
-     #f)
-    (('module-ref dst var-offset mod-name-offset sym-offset)
-     ;; FIXME: Print module name, symbol, and cached variable.
-     #f)
-    (('module-set! src var-offset mod-name-offset sym-offset)
-     ;; FIXME: Print module name, symbol, and cached variable.
-     #f)
-    (('load-typed-array U8 U8 U8 N32 U32)
-     ;; FIXME: Print address and length.
-     #f)
+    (((or 'toplevel-ref 'toplevel-set!) _ var-offset mod-offset sym-offset)
+     (list "`~A'" (dereference-scm sym-offset)))
+    (((or 'module-ref 'module-set!) _ var-offset mod-name-offset sym-offset)
+     (let ((mod-name (reference-scm mod-name-offset)))
+       (list "`(~A ~A ~A)'" (if (car mod-name) '@ '@@) (cdr mod-name)
+             (dereference-scm sym-offset))))
+    (('load-typed-array dst type shape target len)
+     (let ((addr (u32-offset->addr (+ offset target) context)))
+       (list "~a bytes from #x~X" len addr)))
     (_ #f)))
 
 (define (compute-labels bv start end)
@@ -368,35 +329,30 @@
   (format port "address@hidden    address@hidden;; address@hidden@[~61t at 
~a~]\n"
           addr info extra src))
 
-(define (disassemble-buffer port bv start end)
+(define (disassemble-buffer port bv start end context)
   (let ((labels (compute-labels bv start end)))
     (let lp ((offset start))
       (when (< offset end)
         (call-with-values (lambda () (disassemble-one bv offset))
           (lambda (len elt)
             (let ((pos (- offset start))
-                  (annotation (code-annotation elt len offset start labels)))
+                  (annotation (code-annotation elt len offset start labels
+                                               context)))
               (print-info port pos (vector-ref labels pos) elt annotation #f)
               (lp (+ offset len)))))))))
 
 (define* (disassemble-program program #:optional (port (current-output-port)))
-  (let* ((code (rtl-program-code program))
-         (bv (find-mapped-elf-image code))
-         (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")))))
-    (cond
-     ((find-elf-symbol elf (- code base text-base))
-      => (lambda (sym)
-           ;; The text-base, symbol value, and symbol size are in bytes,
-           ;; but the disassembler operates on u32 units.
-           (let ((start (/ (+ (elf-symbol-value sym) text-base) 4))
-                 (size (/ (elf-symbol-size sym) 4)))
-             (format port "Disassembly of ~A at #x~X:\n\n"
-                     (elf-symbol-name sym) code)
-             (disassemble-buffer port bv start (+ start size)))))
-     (else
-      (format port "Debugging information unavailable.~%")))
-    (values)))
+  (cond
+   ((find-program-debug-info #:program program)
+    => (lambda (pdi)
+         ;; FIXME: RTL programs should print with their names.
+         (format port "Disassembly of ~A at ~S:\n\n"
+                 (program-debug-info-name pdi) program)
+         (disassemble-buffer port
+                             (program-debug-info-image pdi)
+                             (program-debug-info-u32-offset pdi)
+                             (program-debug-info-u32-offset-end pdi)
+                             (program-debug-info-context pdi))))
+   (else
+    (format port "Debugging information unavailable.~%")))
+  (values))


hooks/post-receive
-- 
GNU Guile