guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, master, updated. v2.1.0-200-ga862d8c


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. v2.1.0-200-ga862d8c
Date: Sat, 28 Sep 2013 12:52:06 +0000

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=a862d8c13893e04ca8b65c8262e305bd18861f4f

The branch, master has been updated
       via  a862d8c13893e04ca8b65c8262e305bd18861f4f (commit)
       via  35558f75f8b62995dd32dcc1ba40a62e9fa3e396 (commit)
      from  c04bf4337b88ea45641065b7fe70dd0973b8ce94 (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 a862d8c13893e04ca8b65c8262e305bd18861f4f
Author: Andy Wingo <address@hidden>
Date:   Sat Sep 28 14:50:48 2013 +0200

    Emit minimal DWARF information
    
    * module/system/vm/assembler.scm (link-debug): New function, creates the
      necessary DWARF debugging sections.
      (link-objects): Emit debugging sections.

commit 35558f75f8b62995dd32dcc1ba40a62e9fa3e396
Author: Andy Wingo <address@hidden>
Date:   Sat Jun 9 18:26:27 2012 +0200

    add DWARF parser
    
    * module/Makefile.am:
    * module/system/vm/dwarf.scm: New module, a DWARF parser.

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

Summary of changes:
 module/Makefile.am             |    1 +
 module/system/vm/assembler.scm |  176 +++++-
 module/system/vm/dwarf.scm     | 1602 ++++++++++++++++++++++++++++++++++++++++
 3 files changed, 1778 insertions(+), 1 deletions(-)
 create mode 100644 module/system/vm/dwarf.scm

diff --git a/module/Makefile.am b/module/Makefile.am
index 0e6fdf6..b3e573b 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -371,6 +371,7 @@ OOP_SOURCES = \
 SYSTEM_SOURCES =                               \
   system/vm/inspect.scm                                \
   system/vm/coverage.scm                       \
+  system/vm/dwarf.scm                          \
   system/vm/elf.scm                            \
   system/vm/linker.scm                         \
   system/vm/frame.scm                          \
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 9c267fe..1b909a8 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -45,10 +45,12 @@
 (define-module (system vm assembler)
   #:use-module (system base target)
   #:use-module (system vm instruction)
+  #:use-module (system vm dwarf)
   #:use-module (system vm elf)
   #:use-module (system vm linker)
   #:use-module (system vm objcode)
   #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
@@ -1465,6 +1467,175 @@ it will be added to the GC roots at runtime."
                                       (intern-constant asm props))
                    relocs)))))))
 
+;;;
+;;; The DWARF .debug_info, .debug_abbrev, .debug_str, and .debug_loc
+;;; sections provide line number and local variable liveness
+;;; information.  Their format is defined by the DWARF
+;;; specifications.
+;;;
+
+(define (asm-language asm)
+  ;; FIXME: Plumb language through to the assembler.
+  'scheme)
+
+;; -> 4 values: .debug_info, .debug_abbrev, .debug_str, and .debug_loc
+(define (link-debug asm)
+  (define (put-u16 port val)
+    (let ((bv (make-bytevector 2)))
+      (bytevector-u16-set! bv 0 val (asm-endianness asm))
+      (put-bytevector port bv)))
+
+  (define (put-u32 port val)
+    (let ((bv (make-bytevector 4)))
+      (bytevector-u32-set! bv 0 val (asm-endianness asm))
+      (put-bytevector port bv)))
+
+  (define (put-u64 port val)
+    (let ((bv (make-bytevector 8)))
+      (bytevector-u64-set! bv 0 val (asm-endianness asm))
+      (put-bytevector port bv)))
+
+  (define (put-uleb128 port val)
+    (let lp ((val val))
+      (let ((next (ash val -7)))
+        (if (zero? next)
+            (put-u8 port val)
+            (begin
+              (put-u8 port (logior #x80 (logand val #x7f)))
+              (lp next))))))
+
+  (define (meta->subprogram-die meta)
+    `(subprogram
+      (@ ,@(cond
+            ((meta-name meta)
+             => (lambda (name) `((name ,(symbol->string name)))))
+            (else
+             '()))
+         (low-pc ,(meta-label meta))
+         (high-pc ,(* 4 (- (meta-high-pc meta) (meta-low-pc meta)))))))
+
+  (define (make-compile-unit-die asm)
+    `(compile-unit
+      (@ (producer ,(string-append "Guile " (version)))
+         (language ,(asm-language asm))
+         (low-pc .rtl-text)
+         (high-pc ,(* 4 (asm-pos asm))))
+      ,@(map meta->subprogram-die (reverse (asm-meta asm)))))
+
+  (let-values (((die-port get-die-bv) (open-bytevector-output-port))
+               ((die-relocs) '())
+               ((abbrev-port get-abbrev-bv) (open-bytevector-output-port))
+               ;; (tag has-kids? attrs forms) -> code
+               ((abbrevs) vlist-null)
+               ((next-abbrev-code) 1)
+               ((strtab) (make-string-table)))
+
+    (define (write-abbrev code tag has-children? attrs forms)
+      (put-uleb128 abbrev-port code)
+      (put-uleb128 abbrev-port (tag-name->code tag))
+      (put-u8 abbrev-port (children-name->code (if has-children? 'yes 'no)))
+      (for-each (lambda (attr form)
+                  (put-uleb128 abbrev-port (attribute-name->code attr))
+                  (put-uleb128 abbrev-port (form-name->code form)))
+                attrs forms)
+      (put-uleb128 abbrev-port 0)
+      (put-uleb128 abbrev-port 0))
+
+    (define (intern-abbrev tag has-children? attrs forms)
+      (let ((key (list tag has-children? attrs forms)))
+        (match (vhash-assoc key abbrevs)
+          ((_ . code) code)
+          (#f (let ((code next-abbrev-code))
+                (set! next-abbrev-code (1+ next-abbrev-code))
+                (set! abbrevs (vhash-cons key code abbrevs))
+                (write-abbrev code tag has-children? attrs forms)
+                code)))))
+
+    (define (compute-code attr val)
+      (match attr
+        ('name (string-table-intern! strtab val))
+        ('low-pc val)
+        ('high-pc val)
+        ('producer (string-table-intern! strtab val))
+        ('language (language-name->code val))))
+
+    (define (exact-integer? val)
+      (and (number? val) (integer? val) (exact? val)))
+
+    (define (choose-form attr val code)
+      (cond
+       ((string? val) 'sec-offset)
+       ((exact-integer? code)
+        (cond
+         ((< code 0) 'sleb128)
+         ((<= code #xff) 'data1)
+         ((<= code #xffff) 'data2)
+         ((<= code #xffffffff) 'data4)
+         ((<= code #xffffffffffffffff) 'data8)
+         (else 'uleb128)))
+       ((symbol? val) 'addr)
+       (else (error "unhandled case" attr val code))))
+
+    (define (add-die-relocation! kind sym)
+      (set! die-relocs
+            (cons (make-linker-reloc kind (seek die-port 0 SEEK_CUR) 0 sym)
+                  die-relocs)))
+
+    (define (write-value code form)
+      (match form
+        ('data1 (put-u8 die-port code))
+        ('data2 (put-u16 die-port code))
+        ('data4 (put-u32 die-port code))
+        ('data8 (put-u64 die-port code))
+        ('uleb128 (put-uleb128 die-port code))
+        ('sleb128 (error "not yet implemented"))
+        ('addr
+         (match (asm-word-size asm)
+           (4
+            (add-die-relocation! 'abs32/1 code)
+            (put-u32 die-port 0))
+           (8
+            (add-die-relocation! 'abs64/1 code)
+            (put-u64 die-port 0))))
+        ('sec-offset (put-u32 die-port code))))
+
+    (define (write-die die)
+      (match die
+        ((tag ('@ (attrs vals) ...) children ...)
+         (let* ((codes (map compute-code attrs vals))
+                (forms (map choose-form attrs vals codes))
+                (has-children? (not (null? children)))
+                (abbrev-code (intern-abbrev tag has-children? attrs forms)))
+           (put-uleb128 die-port abbrev-code)
+           (for-each write-value codes forms)
+           (when has-children?
+             (for-each write-die children)
+             (put-uleb128 die-port 0))))))
+
+    ;; Compilation unit header.
+    (put-u32 die-port 0) ; Length; will patch later.
+    (put-u16 die-port 4) ; DWARF 4.
+    (put-u32 die-port 0) ; Abbrevs offset.
+    (put-u8 die-port (asm-word-size asm)) ; Address size.
+
+    (write-die (make-compile-unit-die asm))
+
+    ;; Terminate the abbrevs list.
+    (put-uleb128 abbrev-port 0)
+
+    (values (let ((bv (get-die-bv)))
+              ;; Patch DWARF32 length.
+              (bytevector-u32-set! bv 0 (- (bytevector-length bv) 4)
+                                   (asm-endianness asm))
+              (make-object asm '.debug_info bv die-relocs '()
+                           #:type SHT_PROGBITS #:flags 0))
+            (make-object asm '.debug_abbrev (get-abbrev-bv) '() '()
+                         #:type SHT_PROGBITS #:flags 0)
+            (make-object asm '.debug_str (link-string-table! strtab) '() '()
+                         #:type SHT_PROGBITS #:flags 0)
+            (make-object asm '.debug_loc #vu8() '() '()
+                         #:type SHT_PROGBITS #:flags 0))))
+
 (define (link-objects asm)
   (let*-values (;; Link procprops before constants, because it probably
                 ;; interns more constants.
@@ -1477,12 +1648,15 @@ it will be added to the GC roots at runtime."
                 ((symtab strtab) (link-symtab (linker-object-section text) 
asm))
                 ((arities arities-strtab) (link-arities asm))
                 ((docstrs docstrs-strtab) (link-docstrs asm))
+                ((dinfo dabbrev dstrtab dloc) (link-debug asm))
                 ;; This needs to be linked last, because linking other
                 ;; sections adds entries to the string table.
                 ((shstrtab) (link-shstrtab asm)))
     (filter identity
             (list text ro rw dt symtab strtab arities arities-strtab
-                  docstrs docstrs-strtab procprops shstrtab))))
+                  docstrs docstrs-strtab procprops
+                  dinfo dabbrev dstrtab dloc
+                  shstrtab))))
 
 
 
diff --git a/module/system/vm/dwarf.scm b/module/system/vm/dwarf.scm
new file mode 100644
index 0000000..90f2df8
--- /dev/null
+++ b/module/system/vm/dwarf.scm
@@ -0,0 +1,1602 @@
+;;; Guile DWARF reader and writer
+
+;; Copyright (C) 2012, 2013 Free Software Foundation, Inc.
+
+;; Parts of this file were derived from sysdeps/generic/dwarf2.h, from
+;; the GNU C Library.  That file is available under the LGPL version 2
+;; or later, and is copyright:
+;;
+;; Copyright (C) 1992, 1993, 1995, 1996, 1997, 2000, 2011
+;;     Free Software Foundation, Inc.
+;; Contributed by Gary Funck (address@hidden).  Derived from the
+;; DWARF 1 implementation written by Ron Guilmette (address@hidden).
+
+;;;; 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
+
+;;; Commentary:
+;;
+;; DWARF is a flexible format for describing compiled programs.  It is
+;; used by Guile to record source positions, describe local variables,
+;; function arities, and other function metadata.
+;;
+;; Structurally, DWARF describes a tree of data.  Each node in the tree
+;; is a debugging information entry ("DIE").  Each DIE has a "tag",
+;; possible a set of attributes, and possibly some child DIE nodes.
+;; That's basically it!
+;;
+;; The DIE nodes are contained in the .debug_info section of an ELF
+;; file.  Attributes within the DIE nodes link them to mapped ranges of
+;; the ELF file (.rtl_text, .data, etc.).
+;;
+;; A .debug_info section logically contains a series of debugging
+;; "contributions", one for each compilation unit.  Each contribution is
+;; prefixed by a header and contains a single DIE element whose tag is
+;; "compilation-unit".  That node usually contains child nodes, for
+;; example of type "subprogram".
+;;
+;; Since usually one will end up producing many DIE nodes with the same
+;; tag and attribute types, DIE nodes are defined by referencing a known
+;; shape, and then filling in the values.  The shapes are defined in the
+;; form of "abbrev" entries, which specify a specific combination of a
+;; tag and an ordered set of attributes, with corresponding attribute
+;; representations ("forms").  Abbrevs are written out to a separate
+;; section, .debug_abbrev.  Abbrev nodes also specify whether the
+;; corresponding DIE node has children or not.  When a DIE is written
+;; into the .debug_info section, it references one of the abbrevs in
+;; .debug_abbrev.  You need the abbrev in order to parse the DIE.
+;;
+;; For completeness, the other sections that DWARF uses are .debug_str,
+;; .debug_loc, .debug_pubnames, .debug_aranges, .debug_frame, and
+;; .debug_line.  These are described in section 6 of the DWARF 3.0
+;; specification, at http://dwarfstd.org/.
+;;
+;; This DWARF module is currently capable of parsing all of DWARF 2.0
+;; and parts of DWARF 3.0.  For Guile's purposes, we also use DWARF as
+;; the format for our own debugging information.  The DWARF generator is
+;; fairly minimal, and is not intended to be complete.
+;;
+;;; Code:
+
+(define-module (system vm dwarf)
+  #:use-module (rnrs bytevectors)
+  #:use-module (system foreign)
+  #:use-module (system base target)
+  #:use-module (system vm elf)
+  #:use-module ((srfi srfi-1) #:select (fold))
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-11)
+  #:export (elf->dwarf-context
+            read-die-roots
+            fold-pubnames fold-aranges
+
+            access-name->code
+            address-name->code
+            attribute-name->code
+            call-frame-address-name->code
+            children-name->code
+            convention-name->code
+            discriminant-name->code
+            form-name->code
+            inline-name->code
+            language-name->code
+            macro-name->code
+            ordering-name->code
+            sensitivity-name->code
+            tag-name->code
+            virtuality-name->code
+            visibility-name->code
+
+            abbrev? abbrev-code
+            abbrev-tag abbrev-has-children? abbrev-attrs abbrev-forms
+
+            die? die-ctx die-offset die-abbrev die-vals die-children
+            die-tag die-attrs die-forms die-ref
+            die-name die-specification die-qname
+
+            ctx-parent ctx-die ctx-start ctx-end ctx-children ctx-language
+
+            find-die-context find-die-by-offset find-die find-die-by-pc
+            read-die fold-die-list
+
+            fold-die-children die->tree))
+
+;;;
+;;; First, define a number of constants.  The figures numbers refer to
+;;; the DWARF 2.0 draft specification available on http://dwarfstd.org/.
+;;; Extra codes not defined in that document are taken from the dwarf2
+;;; header in glibc.
+;;;
+
+(define-syntax-rule (define-enumeration code->name name->code
+                      (tag value) ...)
+  (begin
+    (define code->name
+      (let ((table (make-hash-table)))
+        (hashv-set! table value 'tag)
+        ...
+        (lambda (v)
+          (hashv-ref table v v))))
+    (define name->code
+      (let ((table (make-hash-table)))
+        (hashv-set! table 'tag value)
+        ...
+        (lambda (v)
+          (hashv-ref table v v))))))
+
+;; Figures 14 and 15: Tag names and codes.
+;;
+(define-enumeration tag-code->name tag-name->code
+  (padding #x00)
+  (array-type #x01)
+  (class-type #x02)
+  (entry-point #x03)
+  (enumeration-type #x04)
+  (formal-parameter #x05)
+  (imported-declaration #x08)
+  (label #x0a)
+  (lexical-block #x0b)
+  (member #x0d)
+  (pointer-type #x0f)
+  (reference-type #x10)
+  (compile-unit #x11)
+  (string-type #x12)
+  (structure-type #x13)
+  (subroutine-type #x15)
+  (typedef #x16)
+  (union-type #x17)
+  (unspecified-parameters #x18)
+  (variant #x19)
+  (common-block #x1a)
+  (common-inclusion #x1b)
+  (inheritance #x1c)
+  (inlined-subroutine #x1d)
+  (module #x1e)
+  (ptr-to-member-type #x1f)
+  (set-type #x20)
+  (subrange-type #x21)
+  (with-stmt #x22)
+  (access-declaration #x23)
+  (base-type #x24)
+  (catch-block #x25)
+  (const-type #x26)
+  (constant #x27)
+  (enumerator #x28)
+  (file-type #x29)
+  (friend #x2a)
+  (namelist #x2b)
+  (namelist-item #x2c)
+  (packed-type #x2d)
+  (subprogram #x2e)
+  (template-type-param #x2f)
+  (template-value-param #x30)
+  (thrown-type #x31)
+  (try-block #x32)
+  (variant-part #x33)
+  (variable #x34)
+  (volatile-type #x35)
+  ;; DWARF 3.
+  (dwarf-procedure #x36)
+  (restrict-type #x37)
+  (interface-type #x38)
+  (namespace #x39)
+  (imported-module #x3a)
+  (unspecified-type #x3b)
+  (partial-unit #x3c)
+  (imported-unit #x3d)
+  (condition #x3f)
+  (shared-type #x40)
+  ;; Extensions.
+  (format-label #x4101)
+  (function-template #x4102)
+  (class-template #x4103)
+  (GNU-BINCL #x4104)
+  (GNU-EINCL #x4105)
+  (lo-user #x4080)
+  (hi-user #xffff))
+
+;; Figure 16: Flag that tells whether entry has a child or not.
+;;
+(define-enumeration children-code->name children-name->code
+  (no 0)
+  (yes 1))
+
+;; Figures 17 and 18: Attribute names and codes.
+;;
+(define-enumeration attribute-code->name attribute-name->code
+  (sibling #x01)
+  (location #x02)
+  (name #x03)
+  (ordering #x09)
+  (subscr-data #x0a)
+  (byte-size #x0b)
+  (bit-offset #x0c)
+  (bit-size #x0d)
+  (element-list #x0f)
+  (stmt-list #x10)
+  (low-pc #x11)
+  (high-pc #x12)
+  (language #x13)
+  (member #x14)
+  (discr #x15)
+  (discr-value #x16)
+  (visibility #x17)
+  (import #x18)
+  (string-length #x19)
+  (common-reference #x1a)
+  (comp-dir #x1b)
+  (const-value #x1c)
+  (containing-type #x1d)
+  (default-value #x1e)
+  (inline #x20)
+  (is-optional #x21)
+  (lower-bound #x22)
+  (producer #x25)
+  (prototyped #x27)
+  (return-addr #x2a)
+  (start-scope #x2c)
+  (stride-size #x2e)
+  (upper-bound #x2f)
+  (abstract-origin #x31)
+  (accessibility #x32)
+  (address-class #x33)
+  (artificial #x34)
+  (base-types #x35)
+  (calling-convention #x36)
+  (count #x37)
+  (data-member-location #x38)
+  (decl-column #x39)
+  (decl-file #x3a)
+  (decl-line #x3b)
+  (declaration #x3c)
+  (discr-list #x3d)
+  (encoding #x3e)
+  (external #x3f)
+  (frame-base #x40)
+  (friend #x41)
+  (identifier-case #x42)
+  (macro-info #x43)
+  (namelist-items #x44)
+  (priority #x45)
+  (segment #x46)
+  (specification #x47)
+  (static-link #x48)
+  (type #x49)
+  (use-location #x4a)
+  (variable-parameter #x4b)
+  (virtuality #x4c)
+  (vtable-elem-location #x4d)
+  ;; DWARF 3.
+  (associated #x4f)
+  (data-location #x50)
+  (byte-stride #x51)
+  (entry-pc #x52)
+  (use-UTF8 #x53)
+  (extension #x54)
+  (ranges #x55)
+  (trampoline #x56)
+  (call-column #x57)
+  (call-file #x58)
+  (call-line #x59)
+  (description #x5a)
+  (binary-scale #x5b)
+  (decimal-scale #x5c)
+  (small #x5d)
+  (decimal-sign #x5e)
+  (digit-count #x5f)
+  (picture-string #x60)
+  (mutable #x61)
+  (threads-scaled #x62)
+  (explicit #x63)
+  (object-pointer #x64)
+  (endianity #x65)
+  (elemental #x66)
+  (pure #x67)
+  (recursive #x68)
+  ;; Extensions.
+  (linkage-name #x2007)
+  (sf-names #x2101)
+  (src-info #x2102)
+  (mac-info #x2103)
+  (src-coords #x2104)
+  (body-begin #x2105)
+  (body-end #x2106)
+  (lo-user #x2000)
+  (hi-user #x3fff))
+
+;; Figure 19: Form names and codes.
+;;
+(define-enumeration form-code->name form-name->code
+  (addr #x01)
+  (block2 #x03)
+  (block4 #x04)
+  (data2 #x05)
+  (data4 #x06)
+  (data8 #x07)
+  (string #x08)
+  (block #x09)
+  (block1 #x0a)
+  (data1 #x0b)
+  (flag #x0c)
+  (sdata #x0d)
+  (strp #x0e)
+  (udata #x0f)
+  (ref-addr #x10)
+  (ref1 #x11)
+  (ref2 #x12)
+  (ref4 #x13)
+  (ref8 #x14)
+  (ref-udata #x15)
+  (indirect #x16)
+  (sec-offset #x17)
+  (exprloc #x18)
+  (flag-present #x19)
+  (ref-sig8 #x20))
+
+;; Figures 22 and 23: Location atom names and codes.
+;;
+(define-enumeration location-op->name location-name->op
+  (addr #x03)
+  (deref #x06)
+  (const1u #x08)
+  (const1s #x09)
+  (const2u #x0a)
+  (const2s #x0b)
+  (const4u #x0c)
+  (const4s #x0d)
+  (const8u #x0e)
+  (const8s #x0f)
+  (constu #x10)
+  (consts #x11)
+  (dup #x12)
+  (drop #x13)
+  (over #x14)
+  (pick #x15)
+  (swap #x16)
+  (rot #x17)
+  (xderef #x18)
+  (abs #x19)
+  (and #x1a)
+  (div #x1b)
+  (minus #x1c)
+  (mod #x1d)
+  (mul #x1e)
+  (neg #x1f)
+  (not #x20)
+  (or #x21)
+  (plus #x22)
+  (plus-uconst #x23)
+  (shl #x24)
+  (shr #x25)
+  (shra #x26)
+  (xor #x27)
+  (bra #x28)
+  (eq #x29)
+  (ge #x2a)
+  (gt #x2b)
+  (le #x2c)
+  (lt #x2d)
+  (ne #x2e)
+  (skip #x2f)
+  (lit0 #x30)
+  (lit1 #x31)
+  (lit2 #x32)
+  (lit3 #x33)
+  (lit4 #x34)
+  (lit5 #x35)
+  (lit6 #x36)
+  (lit7 #x37)
+  (lit8 #x38)
+  (lit9 #x39)
+  (lit10 #x3a)
+  (lit11 #x3b)
+  (lit12 #x3c)
+  (lit13 #x3d)
+  (lit14 #x3e)
+  (lit15 #x3f)
+  (lit16 #x40)
+  (lit17 #x41)
+  (lit18 #x42)
+  (lit19 #x43)
+  (lit20 #x44)
+  (lit21 #x45)
+  (lit22 #x46)
+  (lit23 #x47)
+  (lit24 #x48)
+  (lit25 #x49)
+  (lit26 #x4a)
+  (lit27 #x4b)
+  (lit28 #x4c)
+  (lit29 #x4d)
+  (lit30 #x4e)
+  (lit31 #x4f)
+  (reg0 #x50)
+  (reg1 #x51)
+  (reg2 #x52)
+  (reg3 #x53)
+  (reg4 #x54)
+  (reg5 #x55)
+  (reg6 #x56)
+  (reg7 #x57)
+  (reg8 #x58)
+  (reg9 #x59)
+  (reg10 #x5a)
+  (reg11 #x5b)
+  (reg12 #x5c)
+  (reg13 #x5d)
+  (reg14 #x5e)
+  (reg15 #x5f)
+  (reg16 #x60)
+  (reg17 #x61)
+  (reg18 #x62)
+  (reg19 #x63)
+  (reg20 #x64)
+  (reg21 #x65)
+  (reg22 #x66)
+  (reg23 #x67)
+  (reg24 #x68)
+  (reg25 #x69)
+  (reg26 #x6a)
+  (reg27 #x6b)
+  (reg28 #x6c)
+  (reg29 #x6d)
+  (reg30 #x6e)
+  (reg31 #x6f)
+  (breg0 #x70)
+  (breg1 #x71)
+  (breg2 #x72)
+  (breg3 #x73)
+  (breg4 #x74)
+  (breg5 #x75)
+  (breg6 #x76)
+  (breg7 #x77)
+  (breg8 #x78)
+  (breg9 #x79)
+  (breg10 #x7a)
+  (breg11 #x7b)
+  (breg12 #x7c)
+  (breg13 #x7d)
+  (breg14 #x7e)
+  (breg15 #x7f)
+  (breg16 #x80)
+  (breg17 #x81)
+  (breg18 #x82)
+  (breg19 #x83)
+  (breg20 #x84)
+  (breg21 #x85)
+  (breg22 #x86)
+  (breg23 #x87)
+  (breg24 #x88)
+  (breg25 #x89)
+  (breg26 #x8a)
+  (breg27 #x8b)
+  (breg28 #x8c)
+  (breg29 #x8d)
+  (breg30 #x8e)
+  (breg31 #x8f)
+  (regx #x90)
+  (fbreg #x91)
+  (bregx #x92)
+  (piece #x93)
+  (deref-size #x94)
+  (xderef-size #x95)
+  (nop #x96)
+  ;; DWARF 3.
+  (push-object-address #x97)
+  (call2 #x98)
+  (call4 #x99)
+  (call-ref #x9a)
+  (form-tls-address #x9b)
+  (call-frame-cfa #x9c)
+  (bit-piece #x9d)
+  (lo-user #x80)
+  (hi-user #xff))
+
+;; Figure 24: Type encodings.
+;;
+(define-enumeration type-encoding->name type-name->encoding
+  (void #x0)
+  (address #x1)
+  (boolean #x2)
+  (complex-float #x3)
+  (float #x4)
+  (signed #x5)
+  (signed-char #x6)
+  (unsigned #x7)
+  (unsigned-char #x8)
+  ;; DWARF 3.
+  (imaginary-float #x09)
+  (packed-decimal #x0a)
+  (numeric-string #x0b)
+  (edited #x0c)
+  (signed-fixed #x0d)
+  (unsigned-fixed #x0e)
+  (decimal-float #x0f)
+  (lo-user #x80)
+  (hi-user #xff))
+
+;; Figure 25: Access attribute.
+;;
+(define-enumeration access-code->name access-name->code
+  (public 1)
+  (protected 2)
+  (private 3))
+
+;; Figure 26: Visibility.
+;;
+(define-enumeration visibility-code->name visibility-name->code
+  (local 1)
+  (exported 2)
+  (qualified 3))
+
+;; Figure 27: Virtuality.
+;;
+(define-enumeration virtuality-code->name virtuality-name->code
+  (none 0)
+  (virtual 1)
+  (pure-virtual 2))
+
+;; Figure 28: Source language names and codes.
+;;
+(define-enumeration language-code->name language-name->code
+  (c89 #x0001)
+  (c #x0002)
+  (ada83 #x0003)
+  (c++ #x0004)
+  (cobol74 #x0005)
+  (cobol85 #x0006)
+  (fortran77 #x0007)
+  (fortran90 #x0008)
+  (pascal83 #x0009)
+  (modula2 #x000a)
+  (java #x000b)
+  (c99 #x000c)
+  (ada95 #x000d)
+  (fortran95 #x000e)
+  (pli #x000f)
+  (objc #x0010)
+  (objc++ #x0011)
+  (upc #x0012)
+  (d #x0013)
+  (python #x0014)
+  (mips-assembler #x8001)
+
+  (lo-user #x8000)
+
+  ;; FIXME: Ask for proper codes for these.
+  (scheme #xaf33)
+  (emacs-lisp #xaf34)
+  (ecmascript #xaf35)
+  (lua #xaf36)
+  (brainfuck #xaf37)
+
+  (hi-user #xffff))
+
+;; Figure 29: Case sensitivity.
+;;
+(define-enumeration case-sensitivity-code->name case-sensitivity-name->code
+  (case-sensitive 0)
+  (up-case 1)
+  (down-case 2)
+  (case-insensitive 3))
+
+;; Figure 30: Calling convention.
+;;
+(define-enumeration calling-convention-code->name calling-convention-name->code
+  (normal #x1)
+  (program #x2)
+  (nocall #x3)
+  (lo-user #x40)
+  (hi-user #xff))
+
+;; Figure 31: Inline attribute.
+;;
+(define-enumeration inline-code->name inline-name->code
+  (not-inlined 0)
+  (inlined 1)
+  (declared-not-inlined 2)
+  (declared-inlined 3))
+
+;; Figure 32: Array ordering names and codes.
+(define-enumeration ordering-code->name ordering-name->code
+  (row-major 0)
+  (col-major 1))
+
+;; Figure 33: Discriminant lists.
+;;
+(define-enumeration discriminant-code->name discriminant-name->code
+  (label 0)
+  (range 1))
+
+;; Figure 34: "Standard" line number opcodes.
+;;
+(define-enumeration standard-line-opcode->name standard-line-name->opcode
+  (extended-op 0)
+  (copy 1)
+  (advance-pc 2)
+  (advance-line 3)
+  (set-file 4)
+  (set-column 5)
+  (negate-stmt 6)
+  (set-basic-block 7)
+  (const-add-pc 8)
+  (fixed-advance-pc 9)
+  ;; DWARF 3.
+  (set-prologue-end #x0a)
+  (set-epilogue-begin #x0b)
+  (set-isa #x0c))
+
+;; Figure 35: "Extended" line number opcodes.
+;;
+(define-enumeration extended-line-opcode->name extended-line-name->opcode
+  (end-sequence 1)
+  (set-address 2)
+  (define-file 3)
+  ;; DWARF 3.
+  (lo-user #x80)
+  (hi-user #xff))
+
+;; Figure 36: Names and codes for macro information.
+;;
+(define-enumeration macro-code->name macro-name->code
+  (define 1)
+  (undef 2)
+  (start-file 3)
+  (end-file 4)
+  (vendor-ext 255))
+
+;; Figure 37: Call frame information.
+;;
+(define-enumeration call-frame-address-code->name call-frame-address-code->name
+  (advance-loc #x40)
+  (offset #x80)
+  (restore #xc0)
+  (nop #x00)
+  (set-loc #x01)
+  (advance-loc1 #x02)
+  (advance-loc2 #x03)
+  (advance-loc4 #x04)
+  (offset-extended #x05)
+  (restore-extended #x06)
+  (undefined #x07)
+  (same-value #x08)
+  (register #x09)
+  (remember-state #x0a)
+  (restore-state #x0b)
+  (def-cfa #x0c)
+  (def-cfa-register #x0d)
+  (def-cfa-offset #x0e)
+  ;; DWARF 3.
+  (def-cfa-expression #x0f)
+  (expression #x10)
+  (offset-extended-sf #x11)
+  (def-cfa-sf #x12)
+  (def-cfa-offset-sf #x13)
+  (val-offset #x14)
+  (val-offset-sf #x15)
+  (val-expression #x16)
+  (GNU-window-save #x2d)
+  (GNU-args-size #x2e)
+  (GNU-negative-offset-extended #x2f)
+
+  (extended 0)
+  (low-user #x1c)
+  (high-user #x3f))
+
+;(define CIE-ID #xffffffff)
+;(define CIE-VERSION 1)
+;(define ADDR-none 0)
+
+
+;;;
+;;; A general configuration object.
+;;;
+
+(define-record-type <dwarf-meta>
+  (make-dwarf-meta addr-size
+                   vaddr memsz
+                   path lib-path
+                   info-start info-end
+                   abbrevs-start abbrevs-end
+                   strtab-start strtab-end
+                   loc-start loc-end
+                   pubnames-start pubnames-end
+                   aranges-start aranges-end)
+  dwarf-meta?
+  (addr-size meta-addr-size)
+  (vaddr meta-vaddr)
+  (memsz meta-memsz)
+  (path meta-path)
+  (lib-path meta-lib-path)
+  (info-start meta-info-start)
+  (info-end meta-info-end)
+  (abbrevs-start meta-abbrevs-start)
+  (abbrevs-end meta-abbrevs-end)
+  (strtab-start meta-strtab-start)
+  (strtab-end meta-strtab-end)
+  (loc-start meta-loc-start)
+  (loc-end meta-loc-end)
+  (pubnames-start meta-pubnames-start)
+  (pubnames-end meta-pubnames-end)
+  (aranges-start meta-aranges-start)
+  (aranges-end meta-aranges-end))
+
+;; A context represents a namespace.  The root context is the
+;; compilation unit.  DIE nodes of type class-type, structure-type, or
+;; namespace may form child contexts.
+;;
+(define-record-type <dwarf-context>
+  (make-dwarf-context bv offset-size endianness meta
+                      abbrevs
+                      parent die start end children)
+  dwarf-context?
+  (bv ctx-bv)
+  (offset-size ctx-offset-size)
+  (endianness ctx-endianness)
+  (meta ctx-meta)
+  (abbrevs ctx-abbrevs)
+  (parent ctx-parent)
+  (die ctx-die)
+  (start ctx-start)
+  (end ctx-end)
+  (children ctx-children set-children!))
+
+
+(set-record-type-printer! <dwarf-context>
+                          (lambda (x port)
+                            (format port "<dwarf-context ~a>"
+                                    (number->string (object-address x) 16))))
+
+(define-inlinable (ctx-addr-size ctx)
+  (meta-addr-size (ctx-meta ctx)))
+
+;;;
+;;; Procedures for reading DWARF data.
+;;;
+
+(define (read-u8 ctx pos)
+  (values (bytevector-u8-ref (ctx-bv ctx) pos)
+          (1+ pos)))
+(define (skip-8 ctx pos)
+  (+ pos 1))
+
+(define (read-u16 ctx pos)
+  (values (bytevector-u16-ref (ctx-bv ctx) pos (ctx-endianness ctx))
+          (+ pos 2)))
+(define (skip-16 ctx pos)
+  (+ pos 2))
+
+(define (read-u32 ctx pos)
+  (values (bytevector-u32-ref (ctx-bv ctx) pos (ctx-endianness ctx))
+          (+ pos 4)))
+(define (skip-32 ctx pos)
+  (+ pos 4))
+
+(define (read-u64 ctx pos)
+  (values (bytevector-u64-ref (ctx-bv ctx) pos (ctx-endianness ctx))
+          (+ pos 8)))
+(define (skip-64 ctx pos)
+  (+ pos 8))
+
+(define (read-addr ctx pos)
+  (case (ctx-addr-size ctx)
+    ((4) (read-u32 ctx pos))
+    ((8) (read-u64 ctx pos))
+    (else (error "unsupported word size" ctx))))
+(define (skip-addr ctx pos)
+  (+ pos (ctx-addr-size ctx)))
+
+(define (%read-uleb128 bv pos)
+  ;; Unrolled by one.
+  (let ((b (bytevector-u8-ref bv pos)))
+    (if (zero? (logand b #x80))
+        (values b
+                (1+ pos))
+        (let lp ((n (logxor #x80 b)) (pos (1+ pos)) (shift 7))
+          (let ((b (bytevector-u8-ref bv pos)))
+            (if (zero? (logand b #x80))
+                (values (logior (ash b shift) n)
+                        (1+ pos))
+                (lp (logior (ash (logxor #x80 b) shift) n)
+                    (1+ pos)
+                    (+ shift 7))))))))
+
+(define (%read-sleb128 bv pos)
+  (let lp ((n 0) (pos pos) (shift 0))
+    (let ((b (bytevector-u8-ref bv pos)))
+      (if (zero? (logand b #x80))
+          (values (logior (ash b shift) n
+                          (if (zero? (logand #x40 b))
+                              0
+                              (- (ash 1 (+ shift 7)))))
+                  (1+ pos))
+          (lp (logior (ash (logxor #x80 b) shift) n)
+              (1+ pos)
+              (+ shift 7))))))
+
+(define (read-uleb128 ctx pos)
+  (%read-uleb128 (ctx-bv ctx) pos))
+
+(define (read-sleb128 ctx pos)
+  (%read-sleb128 (ctx-bv ctx) pos))
+
+(define (skip-leb128 ctx pos)
+  (let ((bv (ctx-bv ctx)))
+    (let lp ((pos pos))
+      (let ((b (bytevector-u8-ref bv pos)))
+        (if (zero? (logand b #x80))
+            (1+ pos)
+            (lp (1+ pos)))))))
+
+(define (read-initial-length ctx pos)
+  (let ((len (bytevector-u32-ref (ctx-bv ctx) pos (ctx-endianness ctx))))
+    (cond
+     ((= len #xffffffff)
+      (values (bytevector-u32-ref (ctx-bv ctx) (+ pos 4) (ctx-endianness ctx))
+              (+ pos 12)
+              8))
+     ((>= len #xfffffff0)
+      (error "bad initial length value" len))
+     (else
+      (values len
+              (+ pos 4)
+              4)))))
+
+(define* (read-offset ctx pos #:optional (offset-size (ctx-offset-size ctx)))
+  (case offset-size
+    ((4) (values (read-u32 ctx pos) (+ pos 4)))
+    ((8) (values (read-u64 ctx pos) (+ pos 8)))
+    (else (error "bad word size" offset-size))))
+
+(define* (skip-offset ctx pos #:optional (offset-size (ctx-offset-size ctx)))
+  (+ pos offset-size))
+
+(define (read-block ctx pos len)
+  (let ((bv (make-bytevector len)))
+    (bytevector-copy! (ctx-bv ctx) pos bv 0 len)
+    (values bv
+            (+ pos len))))
+
+(define (read-string ctx pos)
+  (let ((bv (ctx-bv ctx)))
+    (let lp ((end pos))
+      (if (zero? (bytevector-u8-ref bv end))
+          (let ((out (make-bytevector (- end pos))))
+            (bytevector-copy! bv pos out 0 (- end pos))
+            (values (utf8->string out)
+                    (1+ end)))
+          (lp (1+ end))))))
+
+(define (skip-string ctx pos)
+  (let ((bv (ctx-bv ctx)))
+    (let lp ((end pos))
+      (if (zero? (bytevector-u8-ref bv end))
+          (1+ end)
+          (lp (1+ end))))))
+
+(define-record-type <abbrev>
+  (make-abbrev code tag has-children? attrs forms)
+  abbrev?
+  (code abbrev-code)
+  (tag abbrev-tag)
+  (has-children? abbrev-has-children?)
+  (attrs abbrev-attrs)
+  (forms abbrev-forms))
+
+(define (read-abbrev ctx pos)
+  (let*-values (((code pos) (read-uleb128 ctx pos))
+                ((tag pos) (read-uleb128 ctx pos))
+                ((children pos) (read-u8 ctx pos)))
+    (let lp ((attrs '()) (forms '()) (pos pos))
+      (let*-values (((attr pos) (read-uleb128 ctx pos))
+                    ((form pos) (read-uleb128 ctx pos)))
+        (if (and (zero? attr) (zero? form))
+            (values (make-abbrev code
+                                 (tag-code->name tag)
+                                 (eq? (children-code->name children) 'yes)
+                                 (reverse attrs)
+                                 (reverse forms))
+                    pos)
+            (lp (cons (attribute-code->name attr) attrs)
+                (cons (form-code->name form) forms)
+                pos))))))
+
+(define* (read-abbrevs ctx pos
+                       #:optional (start (meta-abbrevs-start
+                                          (ctx-meta ctx)))
+                       (end (meta-abbrevs-end
+                             (ctx-meta ctx))))
+  (let lp ((abbrevs '()) (pos (+ start pos)) (max-code -1))
+    (if (zero? (read-u8 ctx pos))
+        (if (< pos end)
+            (let ((av (make-vector (1+ max-code) #f)))
+              (for-each (lambda (a)
+                          (vector-set! av (abbrev-code a) a))
+                        abbrevs)
+              av)
+            (error "Unexpected length" abbrevs pos start end))
+        (let-values (((abbrev pos) (read-abbrev ctx pos)))
+          (lp (cons abbrev abbrevs)
+              pos
+              (max (abbrev-code abbrev) max-code))))))
+
+(define (ctx-compile-unit-start ctx)
+  (if (ctx-die ctx)
+      (ctx-compile-unit-start (ctx-parent ctx))
+      (ctx-start ctx)))
+
+;; Values.
+;;
+(define *readers* (make-hash-table))
+(define *scanners* (make-hash-table))
+(define-syntax define-value-reader
+  (syntax-rules ()
+    ((_ form reader scanner)
+     (begin
+       (hashq-set! *readers* 'form reader)
+       (hashq-set! *scanners* 'form scanner)))))
+
+(define-value-reader addr read-addr skip-addr)
+
+(define-value-reader block
+  (lambda (ctx pos)
+    (let-values (((len pos) (read-uleb128 ctx pos)))
+      (read-block ctx pos len)))
+  (lambda (ctx pos)
+    (let-values (((len pos) (read-uleb128 ctx pos)))
+      (+ pos len))))
+
+(define-value-reader block1
+  (lambda (ctx pos)
+    (let-values (((len pos) (read-u8 ctx pos)))
+      (read-block ctx pos len)))
+  (lambda (ctx pos)
+    (+ pos 1 (bytevector-u8-ref (ctx-bv ctx) pos))))
+
+(define-value-reader block2
+  (lambda (ctx pos)
+    (let-values (((len pos) (read-u16 ctx pos)))
+      (read-block ctx pos len)))
+  (lambda (ctx pos)
+    (+ pos 2 (bytevector-u16-ref (ctx-bv ctx) pos (ctx-endianness ctx)))))
+
+(define-value-reader block4
+  (lambda (ctx pos)
+    (let-values (((len pos) (read-u32 ctx pos)))
+      (read-block ctx pos len)))
+  (lambda (ctx pos)
+    (+ pos 4 (bytevector-u32-ref (ctx-bv ctx) pos (ctx-endianness ctx)))))
+
+(define-value-reader data1 read-u8 skip-8)
+(define-value-reader data2 read-u16 skip-16)
+(define-value-reader data4 read-u32 skip-32)
+(define-value-reader data8 read-u64 skip-64)
+(define-value-reader udata read-uleb128 skip-leb128)
+(define-value-reader sdata read-sleb128 skip-leb128)
+
+(define-value-reader flag
+  (lambda (ctx pos)
+    (values (not (zero? (bytevector-u8-ref (ctx-bv ctx) pos)))
+            (1+ pos)))
+  skip-8)
+
+(define-value-reader string
+  read-string
+  skip-string)
+
+(define-value-reader strp
+  (lambda (ctx pos)
+    (let ((strtab (meta-strtab-start (ctx-meta ctx))))
+      (unless strtab
+        (error "expected a string table" ctx))
+      (let-values (((offset pos) (read-offset ctx pos)))
+        (values (read-string ctx (+ strtab offset))
+                pos))))
+  skip-32)
+
+(define-value-reader ref-addr
+  (lambda (ctx pos)
+    (let-values (((addr pos) (read-addr ctx pos)))
+      (values (+ addr (meta-info-start (ctx-meta ctx)))
+              pos)))
+  skip-addr)
+
+(define-value-reader ref1
+  (lambda (ctx pos)
+    (let-values (((addr pos) (read-u8 ctx pos)))
+      (values (+ addr (ctx-compile-unit-start ctx))
+              pos)))
+  skip-8)
+
+(define-value-reader ref2
+  (lambda (ctx pos)
+    (let-values (((addr pos) (read-u16 ctx pos)))
+      (values (+ addr (ctx-compile-unit-start ctx))
+              pos)))
+  skip-16)
+
+(define-value-reader ref4
+  (lambda (ctx pos)
+    (let-values (((addr pos) (read-u32 ctx pos)))
+      (values (+ addr (ctx-compile-unit-start ctx))
+              pos)))
+  skip-32)
+
+(define-value-reader ref8
+  (lambda (ctx pos)
+    (let-values (((addr pos) (read-u64 ctx pos)))
+      (values (+ addr (ctx-compile-unit-start ctx))
+              pos)))
+  skip-64)
+
+(define-value-reader ref
+  (lambda (udata ctx pos)
+    (let-values (((addr pos) (read-uleb128 ctx pos)))
+      (values (+ addr (ctx-compile-unit-start ctx))
+              pos)))
+  skip-leb128)
+
+(define-value-reader indirect
+  (lambda (ctx pos)
+    (let*-values (((form pos) (read-uleb128 ctx pos))
+                  ((val pos) (read-value ctx pos (form-code->name form))))
+      (values (cons form val)
+              pos)))
+  (lambda (ctx pos)
+    (let*-values (((form pos) (read-uleb128 ctx pos)))
+      (skip-value ctx pos (form-code->name form)))))
+
+(define-value-reader sec-offset
+  read-offset
+  skip-offset)
+
+(define-value-reader exprloc
+  (lambda (ctx pos)
+    (let-values (((len pos) (read-uleb128 ctx pos)))
+      (read-block ctx pos len)))
+  (lambda (ctx pos)
+    (let-values (((len pos) (read-uleb128 ctx pos)))
+      (+ pos len))))
+
+(define-value-reader flag-present
+  (lambda (ctx pos)
+    (values #t pos))
+  (lambda (ctx pos)
+    pos))
+
+(define-value-reader ref-sig8
+  read-u64
+  skip-64)
+
+(define (read-value ctx pos form)
+  ((or (hashq-ref *readers* form)
+       (error "unrecognized form" form))
+   ctx pos))
+
+(define (skip-value ctx pos form)
+  ((or (hashq-ref *scanners* form)
+       (error "unrecognized form" form))
+   ctx pos))
+
+;; Parsers for particular attributes.
+;;
+(define (parse-location-list ctx offset)
+  (let lp ((pos (+ (meta-loc-start (ctx-meta ctx)) offset))
+           (out '()))
+    (let*-values (((start pos) (read-addr ctx pos))
+                  ((end pos) (read-addr ctx pos)))
+      (if (and (zero? start) (zero? end))
+          (reverse out)
+          (let*-values (((len pos) (read-u16 ctx pos))
+                        ((block pos) (read-block ctx pos len)))
+            (lp pos
+                (cons (list start end (parse-location ctx block)) out)))))))
+
+(define (parse-location ctx loc)
+  (cond
+   ((bytevector? loc)
+    (let ((len (bytevector-length loc))
+          (addr-size (ctx-addr-size ctx))
+          (endianness (ctx-endianness ctx)))
+      (define (u8-ref pos) (bytevector-u8-ref loc pos))
+      (define (s8-ref pos) (bytevector-s8-ref loc pos))
+      (define (u16-ref pos) (bytevector-u16-ref loc pos endianness))
+      (define (s16-ref pos) (bytevector-s16-ref loc pos endianness))
+      (define (u32-ref pos) (bytevector-u32-ref loc pos endianness))
+      (define (s32-ref pos) (bytevector-s32-ref loc pos endianness))
+      (define (u64-ref pos) (bytevector-u64-ref loc pos endianness))
+      (define (s64-ref pos) (bytevector-s64-ref loc pos endianness))
+      (let lp ((pos 0) (out '()))
+        (if (= pos len)
+            (reverse out)
+            (let ((op (location-op->name (u8-ref pos))))
+              (case op
+                ((addr)
+                 (case addr-size
+                   ((4) (lp (+ pos 5) (cons (list op (u32-ref (1+ pos))) out)))
+                   ((8) (lp (+ pos 9) (cons (list op (u64-ref (1+ pos))) out)))
+                   (else (error "what!"))))
+                ((call-ref)
+                 (case addr-size
+                   ((4) (lp (+ pos 5)
+                            (cons (list op (+ (meta-info-start (ctx-meta ctx))
+                                              (u32-ref (1+ pos))))
+                                  out)))
+                   ((8) (lp (+ pos 9)
+                            (cons (list op (+ (meta-info-start (ctx-meta ctx))
+                                              (u64-ref (1+ pos))))
+                                  out)))
+                   (else (error "what!"))))
+                ((const1u pick deref-size xderef-size)
+                 (lp (+ pos 2) (cons (list op (u8-ref (1+ pos))) out)))
+                ((const1s)
+                 (lp (+ pos 2) (cons (list op (s8-ref (1+ pos))) out)))
+                ((const2u)
+                 (lp (+ pos 3) (cons (list op (u16-ref (1+ pos))) out)))
+                ((call2)
+                 (lp (+ pos 3) (cons (list op (+ (ctx-compile-unit-start ctx)
+                                                 (u16-ref (1+ pos))))
+                                     out)))
+                ((const2s skip bra)
+                 (lp (+ pos 3) (cons (list op (s16-ref (1+ pos))) out)))
+                ((const4u)
+                 (lp (+ pos 5) (cons (list op (u32-ref (1+ pos))) out)))
+                ((call4)
+                 (lp (+ pos 5) (cons (list op (+ (ctx-compile-unit-start ctx)
+                                                 (u32-ref (1+ pos))))
+                                     out)))
+                ((const4s)
+                 (lp (+ pos 5) (cons (list op (s32-ref (1+ pos))) out)))
+                ((const8u)
+                 (lp (+ pos 9) (cons (list op (u64-ref (1+ pos))) out)))
+                ((const8s)
+                 (lp (+ pos 9) (cons (list op (s64-ref (1+ pos))) out)))
+                ((plus-uconst regx piece)
+                 (let-values (((val pos) (%read-uleb128 loc (1+ pos))))
+                   (lp pos (cons (list op val) out))))
+                ((bit-piece)
+                 (let*-values (((bit-len pos) (%read-uleb128 loc (1+ pos)))
+                               ((bit-offset pos) (%read-uleb128 loc pos)))
+                   (lp pos (cons (list op bit-len bit-offset) out))))
+                ((breg0 breg1 breg2 breg3 breg4 breg5 breg6 breg7 breg8 breg9
+                        breg10 breg11 breg12 breg13 breg14 breg15 breg16 breg17
+                        breg18 breg19 breg20 breg21 breg22 breg23 breg24 breg25
+                        breg26 breg27 breg28 breg29 breg30 breg31 fbreg)
+                 (let-values (((val pos) (%read-sleb128 loc (1+ pos))))
+                   (lp pos (cons (list op val) out))))
+                (else
+                 (if (number? op)
+                     ;; We failed to parse this opcode; we have to give
+                     ;; up
+                     loc
+                     (lp (1+ pos) (cons (list op) out))))))))))
+   (else
+    (parse-location-list ctx loc))))
+
+(define-syntax-rule (define-attribute-parsers parse (name parser) ...)
+  (define parse
+    (let ((parsers (make-hash-table)))
+      (hashq-set! parsers 'name parser)
+      ...
+      (lambda (ctx attr val)
+        (cond
+         ((hashq-ref parsers attr) => (lambda (p) (p ctx val)))
+         (else val))))))
+
+(define-attribute-parsers parse-attribute
+  (encoding (lambda (ctx val) (type-encoding->name val)))
+  (accessibility (lambda (ctx val) (access-code->name val)))
+  (visibility (lambda (ctx val) (visibility-code->name val)))
+  (virtuality (lambda (ctx val) (virtuality-code->name val)))
+  (language (lambda (ctx val) (language-code->name val)))
+  (location parse-location)
+  (data-member-location parse-location)
+  (case-sensitive (lambda (ctx val) (case-sensitivity-code->name val)))
+  (calling-convention (lambda (ctx val) (calling-convention-code->name val)))
+  (inline (lambda (ctx val) (inline-code->name val)))
+  (ordering (lambda (ctx val) (ordering-code->name val)))
+  (discr-value (lambda (ctx val) (discriminant-code->name val))))
+
+;; "Debugging Information Entries": DIEs.
+;;
+(define-record-type <die>
+  (make-die ctx offset abbrev vals)
+  die?
+  (ctx die-ctx)
+  (offset die-offset)
+  (abbrev die-abbrev)
+  (vals %die-vals %set-die-vals!))
+
+(define (die-tag die)
+  (abbrev-tag (die-abbrev die)))
+
+(define (die-attrs die)
+  (abbrev-attrs (die-abbrev die)))
+
+(define (die-forms die)
+  (abbrev-forms (die-abbrev die)))
+
+(define (die-vals die)
+  (let ((vals (%die-vals die)))
+    (or vals
+        (begin
+          (%set-die-vals! die (read-values (die-ctx die) (skip-leb128 (die-ctx 
die) (die-offset die)) (die-abbrev die)))
+          (die-vals die)))))
+
+(define* (die-next-offset die #:optional offset-vals)
+  (let ((ctx (die-ctx die)))
+    (skip-values ctx (or offset-vals (skip-leb128 ctx (die-offset die)))
+                 (die-abbrev die))))
+
+(define* (die-ref die attr #:optional default)
+  (cond
+   ((list-index (die-attrs die) attr)
+    => (lambda (n) (list-ref (die-vals die) n)))
+   (else default)))
+
+(define (die-specification die)
+  (and=> (die-ref die 'specification)
+         (lambda (offset) (find-die-by-offset (die-ctx die) offset))))
+
+(define (die-name die)
+  (or (die-ref die 'name)
+      (and=> (die-specification die) die-name)))
+
+(define (die-qname die)
+  (cond
+   ((eq? (die-tag die) 'compile-unit) "")
+   ((die-ref die 'name)
+    => (lambda (name)
+         (if (eq? (die-tag (ctx-die (die-ctx die))) 'compile-unit)
+             name ; short cut
+             (string-append (die-qname (ctx-die (die-ctx die))) "::" name))))
+   ((die-specification die)
+    => die-qname)
+   (else #f)))
+
+(define (read-values ctx offset abbrev)
+  (let lp ((attrs (abbrev-attrs abbrev))
+           (forms (abbrev-forms abbrev))
+           (vals '())
+           (pos offset))
+    (if (null? forms)
+        (values (reverse vals) pos)
+        (let-values (((val pos) (read-value ctx pos (car forms))))
+          (lp (cdr attrs) (cdr forms)
+              (cons (parse-attribute ctx (car attrs) val) vals)
+              pos)))))
+
+(define (skip-values ctx offset abbrev)
+  (let lp ((forms (abbrev-forms abbrev))
+           (pos offset))
+    (if (null? forms)
+        pos
+        (lp (cdr forms) (skip-value ctx pos (car forms))))))
+
+(define (read-die-abbrev ctx offset)
+  (let*-values (((code pos) (read-uleb128 ctx offset)))
+    (values (cond ((zero? code) #f)
+                  ((vector-ref (ctx-abbrevs ctx) code))
+                  (else (error "unknown abbrev" ctx code)))
+            pos
+            #f pos)))
+
+(define (read-die ctx offset)
+  (let*-values (((abbrev pos) (read-die-abbrev ctx offset)))
+    (if abbrev
+        (values (make-die ctx offset abbrev #f)
+                (skip-values ctx pos abbrev))
+        (values #f pos))))
+
+(define* (die-sibling ctx abbrev offset #:optional offset-vals offset-end)
+  (cond
+   ((not (abbrev-has-children? abbrev))
+    (or offset-end
+        (skip-values ctx
+                     (or offset-vals (skip-leb128 ctx offset))
+                     abbrev)))
+   ((memq 'sibling (abbrev-attrs abbrev))
+    (let lp ((offset (or offset-vals (skip-leb128 ctx offset)))
+             (attrs (abbrev-attrs abbrev))
+             (forms (abbrev-forms abbrev)))
+      (if (eq? (car attrs) 'sibling)
+          (read-value ctx offset (car forms))
+          (lp (skip-value ctx offset (car forms))
+              (cdr attrs) (cdr forms)))))
+   (else
+    (call-with-values
+        (lambda ()
+          (fold-die-list ctx
+                         (or offset-end
+                             (skip-values ctx
+                                          (or offset-vals
+                                              (skip-leb128 ctx offset))
+                                          abbrev))
+                         (lambda (ctx offset abbrev) #t)
+                         error
+                         #f))
+      (lambda (seed pos)
+        pos)))))
+
+(define (find-die-context ctx offset)
+  (define (not-found)
+    (error "failed to find DIE by context" offset))
+  (define (in-context? ctx)
+    (and (<= (ctx-start ctx) offset)
+         (< offset (ctx-end ctx))))
+  (define (find-root ctx)
+    (if (in-context? ctx)
+        ctx
+        (find-root (or (ctx-parent ctx) (not-found)))))
+  (define (find-leaf ctx)
+    (let lp ((kids (ctx-children ctx)))
+      (if (null? kids)
+          ctx
+          (if (in-context? (car kids))
+              (find-leaf (car kids))
+              (lp (cdr kids))))))
+  (find-leaf (find-root ctx)))
+
+(define (find-die-by-offset ctx offset)
+  (or (read-die (find-die-context ctx offset) offset)
+      (error "Failed to read DIE at offset" offset)))
+
+(define-syntax-rule (let/ec k e e* ...)
+  (let ((tag (make-prompt-tag)))
+    (call-with-prompt
+     tag
+     (lambda ()
+       (let ((k (lambda args (apply abort-to-prompt tag args))))
+         e e* ...))
+     (lambda (_ res) res))))
+
+(define* (find-die roots pred #:key
+                   (skip? (lambda (ctx offset abbrev) #f))
+                   (recurse? (lambda (die) #t)))
+  (let/ec k
+    (define (visit-die die)
+      (cond
+       ((pred die)
+        (k die))
+       ((recurse? die)
+        (fold-die-children die (lambda (die seed) (visit-die die)) #f
+                           #:skip? skip?))
+       (else #f)))
+    (for-each visit-die roots)
+    #f))
+
+(define (find-die-by-pc roots pc)
+  ;; The result will be a subprogram.
+  (define (skip? ctx offset abbrev)
+    (case (abbrev-tag abbrev)
+      ((subprogram compile-unit) #f)
+      (else #t)))
+  (define (recurse? die)
+    (case (die-tag die)
+      ((compile-unit)
+       (not (or (and=> (die-ref die 'low-pc)
+                       (lambda (low) (< pc low)))
+                (and=> (die-ref die 'high-pc)
+                       (lambda (high) (<= high pc))))))
+      (else #f)))
+  (find-die roots
+            (lambda (die)
+              (and (eq? (die-tag die) 'subprogram)
+                   (equal? (die-ref die 'low-pc) pc)))
+            #:skip? skip? #:recurse? recurse?))
+
+(define (fold-die-list ctx offset skip? proc seed)
+  (let ((ctx (find-die-context ctx offset)))
+    (let lp ((offset offset) (seed seed))
+      (let-values (((abbrev pos) (read-die-abbrev ctx offset)))
+        (cond
+         ((not abbrev) (values seed pos))
+         ((skip? ctx offset abbrev)
+          (lp (die-sibling ctx abbrev offset pos) seed))
+         (else
+          (let-values (((vals pos) (read-values ctx pos abbrev)))
+            (let* ((die (make-die ctx offset abbrev vals))
+                   (seed (proc die seed)))
+              (lp (die-sibling ctx abbrev offset #f pos) seed)))))))))
+
+(define* (fold-die-children die proc seed #:key
+                            (skip? (lambda (ctx offset abbrev) #f)))
+  (if (abbrev-has-children? (die-abbrev die))
+      (values (fold-die-list (die-ctx die) (die-next-offset die)
+                             skip? proc seed))
+      seed))
+
+(define (die-children die)
+  (reverse (fold-die-children die cons '())))
+
+(define (add-to-parent! ctx)
+  (let ((parent (ctx-parent ctx)))
+    (set-children! parent
+                   (append (ctx-children parent) (list ctx)))
+    ctx))
+
+(define (make-compilation-unit-context ctx offset-size addr-size
+                                       abbrevs start len)
+  (unless (= addr-size (ctx-addr-size ctx))
+    (error "ELF word size not equal to compilation unit addrsize"))
+  (add-to-parent!
+   (make-dwarf-context (ctx-bv ctx)
+                       offset-size (ctx-endianness ctx)
+                       (ctx-meta ctx)
+                       abbrevs ctx #f start (+ start 4 len) '())))
+
+(define (make-child-context die)
+  (let ((ctx (die-ctx die)))
+    (add-to-parent!
+     (make-dwarf-context (ctx-bv ctx)
+                         (ctx-offset-size ctx) (ctx-endianness ctx)
+                         (ctx-meta ctx)
+                         (ctx-abbrevs ctx)
+                         ctx die
+                         (die-next-offset die)
+                         (die-sibling ctx (die-abbrev die) (die-offset die))
+                         '()))))
+
+(define (ctx-language ctx)
+  (or (and=> (ctx-die ctx) (lambda (x) (die-ref x 'language)))
+      (and=> (ctx-parent ctx) ctx-language)))
+
+(define (populate-context-tree! die)
+  (define (skip? ctx offset abbrev)
+    (case (abbrev-tag abbrev)
+      ((class-type structure-type namespace) #f)
+      (else #t)))
+  (case (die-tag die)
+    ((compile-unit class-type structure-type namespace)
+     (let ((ctx (make-child-context die)))
+       ;; For C++, descend into classes and structures so that we
+       ;; populate the context tree.  Note that for compile-unit, we
+       ;; still need to call `make-child-context' for its side effect of
+       ;; adding to the context tree.
+       (when (eq? (ctx-language ctx) 'c++)
+         (fold-die-children die
+                            (lambda (die seed) (populate-context-tree! die))
+                            #f
+                            #:skip? skip?))))))
+
+(define (read-compilation-unit ctx pos)
+  (let*-values (((start) pos)
+                ((len pos offset-size) (read-initial-length ctx pos))
+                ((version pos) (read-u16 ctx pos))
+                ((abbrevs-offset pos) (read-offset ctx pos offset-size))
+                ((av) (read-abbrevs ctx abbrevs-offset))
+                ((addrsize pos) (read-u8 ctx pos))
+                ((ctx) (make-compilation-unit-context ctx offset-size addrsize
+                                                      av start len))
+                ((die) (read-die ctx pos)))
+    (populate-context-tree! die)
+    (values die (ctx-end ctx))))
+
+(define (read-die-roots ctx)
+  (let lp ((dies '()) (pos (meta-info-start (ctx-meta ctx))))
+    (if (< pos (meta-info-end (ctx-meta ctx)))
+        (let-values (((die pos) (read-compilation-unit ctx pos)))
+          (if die
+              (lp (cons die dies) pos)
+              (reverse dies)))
+        (reverse dies))))
+
+(define (fold-pubname-set ctx pos folder seed)
+  (let*-values (((len pos offset-size) (read-initial-length ctx pos))
+                ((version pos) (read-u16 ctx pos))
+                ((info-offset pos) (read-offset ctx pos offset-size))
+                ((info-offset) (+ info-offset
+                                  (meta-info-start (ctx-meta ctx))))
+                ((info-len pos) (read-offset ctx pos offset-size)))
+    (let lp ((pos pos) (seed seed))
+      (let-values (((offset pos) (read-offset ctx pos offset-size)))
+        (if (zero? offset)
+            (values seed pos)
+            (let-values (((str pos) (read-string ctx pos)))
+              (lp pos
+                  (folder str (+ offset info-offset) seed))))))))
+
+(define (fold-pubnames ctx folder seed)
+  (let ((end (meta-pubnames-end (ctx-meta ctx))))
+    (if end
+        (let lp ((pos (meta-pubnames-start (ctx-meta ctx))) (seed seed))
+          (if (< pos end)
+              (let-values (((seed pos) (fold-pubname-set ctx pos folder seed)))
+                (lp pos seed))
+              seed))
+        seed)))
+
+(define (align address alignment)
+  (+ address
+     (modulo (- alignment (modulo address alignment)) alignment)))
+
+(define (fold-arange-set ctx pos folder seed)
+  (let*-values (((len pos offset-size) (read-initial-length ctx pos))
+                ((version pos) (read-u16 ctx pos))
+                ((info-offset pos) (read-offset ctx pos offset-size))
+                ((info-offset) (+ info-offset
+                                  (meta-info-start (ctx-meta ctx))))
+                ((addr-size pos) (read-u8 ctx pos))
+                ((segment-size pos) (read-u8 ctx pos)))
+    (let lp ((pos (align pos (* 2 (ctx-addr-size ctx)))) (seed seed))
+      (let*-values (((addr pos) (read-addr ctx pos))
+                    ((len pos) (read-addr ctx pos)))
+        (if (and (zero? addr) (zero? len))
+            (values seed pos)
+            (lp pos
+                (folder info-offset addr len seed)))))))
+
+(define (fold-aranges ctx folder seed)
+  (let ((end (meta-aranges-end (ctx-meta ctx))))
+    (if end
+        (let lp ((pos (meta-aranges-start (ctx-meta ctx))) (seed seed))
+          (if (< pos end)
+              (let-values (((seed pos) (fold-arange-set ctx pos folder seed)))
+                (lp pos seed))
+              seed))
+        seed)))
+
+(define* (elf->dwarf-context elf #:key (vaddr 0) (memsz 0)
+                             (path #f) (lib-path path))
+  (let* ((sections (elf-sections-by-name elf))
+         (info (assoc-ref sections ".debug_info"))
+         (abbrevs (assoc-ref sections ".debug_abbrev"))
+         (strtab (assoc-ref sections ".debug_str"))
+         (loc (assoc-ref sections ".debug_loc"))
+         (pubnames (assoc-ref sections ".debug_pubnames"))
+         (aranges (assoc-ref sections ".debug_aranges")))
+    (make-dwarf-context (elf-bytes elf)
+                        4 ;; initial offset size
+                        (elf-byte-order elf)
+                        (make-dwarf-meta
+                         (elf-word-size elf)
+                         vaddr memsz
+                         path lib-path
+                         (elf-section-offset info)
+                         (+ (elf-section-offset info)
+                            (elf-section-size info))
+                         (elf-section-offset abbrevs)
+                         (+ (elf-section-offset abbrevs)
+                            (elf-section-size abbrevs))
+                         (elf-section-offset strtab)
+                         (+ (elf-section-offset strtab)
+                            (elf-section-size strtab))
+                         (elf-section-offset loc)
+                         (+ (elf-section-offset loc)
+                            (elf-section-size loc))
+                         (and pubnames
+                              (elf-section-offset pubnames))
+                         (and pubnames
+                              (+ (elf-section-offset pubnames)
+                                 (elf-section-size pubnames)))
+                         (and aranges
+                              (elf-section-offset aranges))
+                         (and aranges
+                              (+ (elf-section-offset aranges)
+                                 (elf-section-size aranges))))
+                        #() #f #f
+                        (elf-section-offset info)
+                        (+ (elf-section-offset info)
+                           (elf-section-size info))
+                        '())))
+
+(define (die->tree die)
+  (cons* (die-tag die)
+         (cons 'offset (die-offset die))
+         (reverse! (fold-die-children
+                    die
+                    (lambda (die seed)
+                      (cons (die->tree die) seed))
+                    (fold acons '() (die-attrs die) (die-vals die))))))


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]