[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-207-gae07b8e
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-207-gae07b8e |
|
Date: |
Thu, 03 Oct 2013 14:18:24 +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=ae07b8e70bfc53220d7017bb7edcdb6c329d5bd5
The branch, master has been updated
via ae07b8e70bfc53220d7017bb7edcdb6c329d5bd5 (commit)
via c0ada5a766ec049b57209c7177e65468227ccd54 (commit)
via 1ed81e0229a825f09e4e8a86eaa8697b9666644f (commit)
via d56ab5a9139f4a9791c18a83f5fb0e3eb4251ced (commit)
from 0a7340ac98245fc41a4f4bdf3e99dd65602623ed (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 ae07b8e70bfc53220d7017bb7edcdb6c329d5bd5
Author: Andy Wingo <address@hidden>
Date: Thu Oct 3 16:13:56 2013 +0200
Add source location test
* test-suite/tests/dwarf.test: New test, testing that source location
information survives the round-trip through the compiler, back out to
the (system vm debug) interfaces.
commit c0ada5a766ec049b57209c7177e65468227ccd54
Author: Andy Wingo <address@hidden>
Date: Thu Oct 3 14:44:30 2013 +0200
Add (system vm debug) interface to source location information
* module/system/vm/debug.scm (<source>, source-pre-pc)
(source-post-pc, source-file, source-line, source-column)
(source-line-for-user): New data type for source location
information.
(find-source-for-addr, find-program-sources): New procedures to get
source location information for a particular address.
commit 1ed81e0229a825f09e4e8a86eaa8697b9666644f
Author: Andy Wingo <address@hidden>
Date: Thu Oct 3 14:42:49 2013 +0200
Add interface to read .debug_line data
* module/system/vm/dwarf.scm (die-line-prog):
(line-prog-advance, line-prog-scan-to-pc): New public interfaces,
allowing clients to interpret the "statement programs" from
.debug_line DWARF sections.
(<meta>, elf->dwarf-context): Record the bounds of the .debug_line
section.
commit d56ab5a9139f4a9791c18a83f5fb0e3eb4251ced
Author: Andy Wingo <address@hidden>
Date: Wed Oct 2 21:34:38 2013 +0200
Serialize source positions into .debug_line
* module/system/vm/assembler.scm (link-debug): Generate a correct DWARF2
line program. Tests come next.
-----------------------------------------------------------------------
Summary of changes:
module/system/vm/assembler.scm | 109 +++++++++++++++--
module/system/vm/debug.scm | 93 ++++++++++++++-
module/system/vm/dwarf.scm | 256 +++++++++++++++++++++++++++++++++++++++-
test-suite/Makefile.am | 1 +
test-suite/tests/dwarf.test | 88 ++++++++++++++
5 files changed, 528 insertions(+), 19 deletions(-)
create mode 100644 test-suite/tests/dwarf.test
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 44a88d8..34abc7e 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1518,6 +1518,14 @@ it will be added to the GC roots at runtime."
(put-u8 port (logior #x80 (logand val #x7f)))
(lp next))))))
+ (define (put-sleb128 port val)
+ (let lp ((val val))
+ (if (<= 0 (+ val 64) 128)
+ (put-u8 port (logand val #x7f))
+ (begin
+ (put-u8 port (logior #x80 (logand val #x7f)))
+ (lp (ash val -7))))))
+
(define (port-position port)
(seek port 0 SEEK_CUR))
@@ -1579,13 +1587,26 @@ it will be added to the GC roots at runtime."
code))))
(define (write-sources)
+ ;; Choose line base and line range values that will allow for an
+ ;; address advance range of 16 words. The special opcode range is
+ ;; from 10 to 255, so 246 values.
+ (define base -4)
+ (define range 15)
+
(let lp ((sources (asm-sources asm)) (out '()))
(match sources
- (((pos . s) . sources)
+ (((pc . s) . sources)
(let ((file (assq-ref s 'filename))
(line (assq-ref s 'line))
(col (assq-ref s 'column)))
- (lp sources (cons (list pos (intern-file file) line col) out))))
+ (lp sources
+ ;; Guile line and column numbers are 0-indexed, but
+ ;; they are 1-indexed for DWARF.
+ (cons (list pc
+ (if file (intern-file file) 0)
+ (if line (1+ line))
+ (if col (1+ col)))
+ out))))
(()
;; Compilation unit header for .debug_line. We write in
;; DWARF 2 format because more tools understand it than DWARF
@@ -1597,8 +1618,8 @@ it will be added to the GC roots at runtime."
(put-u8 line-port 4) ; Minimum instruction length: 4 bytes.
(put-u8 line-port 1) ; Default is-stmt: true.
- (put-s8 line-port 0) ; Line base. See the DWARF standard.
- (put-u8 line-port 0) ; Line range. See the DWARF standard.
+ (put-s8 line-port base) ; Line base. See the DWARF standard.
+ (put-u8 line-port range) ; Line range. See the DWARF standard.
(put-u8 line-port 10) ; Opcode base: the first "special" opcode.
;; A table of the number of uleb128 arguments taken by each
@@ -1639,14 +1660,76 @@ it will be added to the GC roots at runtime."
(put-u32 line-port (- offset 10))
(seek line-port offset SEEK_SET))
- ;; Now write sources.
- ;; ...
-
- ;; End sequence.
- (put-u8 line-port 0) ; extended opcode:
- (put-uleb128 line-port 1) ; one byte
- (put-u8 line-port 1) ; end sequence.
- ))))
+ ;; Now write the statement program.
+ (let ()
+ (define (extended-op opcode payload-len)
+ (put-u8 line-port 0) ; extended op
+ (put-uleb128 line-port (1+ payload-len)) ; payload-len + opcode
+ (put-uleb128 line-port opcode))
+ (define (set-address sym)
+ (define (add-reloc! kind)
+ (set! line-relocs
+ (cons (make-linker-reloc kind
+ (port-position line-port)
+ 0
+ sym)
+ line-relocs)))
+ (match (asm-word-size asm)
+ (4
+ (extended-op 2 4)
+ (add-reloc! 'abs32/1)
+ (put-u32 line-port 0))
+ (8
+ (extended-op 2 8)
+ (add-reloc! 'abs64/1)
+ (put-u64 line-port 0))))
+ (define (end-sequence pc)
+ (let ((pc-inc (- (asm-pos asm) pc)))
+ (put-u8 line-port 2) ; advance-pc
+ (put-uleb128 line-port pc-inc))
+ (extended-op 1 0))
+ (define (advance-pc pc-inc line-inc)
+ (let ((spec (+ (- line-inc base) (* pc-inc range) 10)))
+ (cond
+ ((or (< line-inc base) (>= line-inc (+ base range)))
+ (advance-line line-inc)
+ (advance-pc pc-inc 0))
+ ((<= spec 255)
+ (put-u8 line-port spec))
+ ((< spec 500)
+ (put-u8 line-port 8) ; const-advance-pc
+ (advance-pc (- pc-inc (floor/ (- 255 10) range))
+ line-inc))
+ (else
+ (put-u8 line-port 2) ; advance-pc
+ (put-uleb128 line-port pc-inc)
+ (advance-pc 0 line-inc)))))
+ (define (advance-line inc)
+ (put-u8 line-port 3)
+ (put-sleb128 line-port inc))
+ (define (set-file file)
+ (put-u8 line-port 4)
+ (put-uleb128 line-port file))
+ (define (set-column col)
+ (put-u8 line-port 5)
+ (put-uleb128 line-port col))
+
+ (set-address '.rtl-text)
+
+ (let lp ((in out) (pc 0) (file 1) (line 1) (col 0))
+ (match in
+ (() (end-sequence pc))
+ (((pc* file* line* col*) . in*)
+ (cond
+ ((and (eqv? file file*) (eqv? line line*) (eqv? col col*))
+ (lp in* pc file line col))
+ (else
+ (unless (eqv? col col*)
+ (set-column col*))
+ (unless (eqv? file file*)
+ (set-file file*))
+ (advance-pc (- pc* pc) (- line* line))
+ (lp in* pc* file* line* col*)))))))))))
(define (compute-code attr val)
(match attr
@@ -1687,7 +1770,7 @@ it will be added to the GC roots at runtime."
('data4 (put-u32 die-port code))
('data8 (put-u64 die-port code))
('uleb128 (put-uleb128 die-port code))
- ('sleb128 (error "not yet implemented"))
+ ('sleb128 (put-sleb128 die-port code))
('addr
(match (asm-word-size asm)
(4
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 2289ec3..0531188 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -26,6 +26,7 @@
(define-module (system vm debug)
#:use-module (system vm elf)
+ #:use-module (system vm dwarf)
#:use-module (system vm objcode)
#:use-module (system foreign)
#:use-module (rnrs bytevectors)
@@ -63,7 +64,17 @@
find-program-docstring
- find-program-properties))
+ find-program-properties
+
+ source?
+ source-pre-pc
+ source-post-pc
+ source-file
+ source-line
+ source-line-for-user
+ source-column
+ find-source-for-addr
+ find-program-sources))
;;; A compiled procedure comes from a specific loaded ELF image. A
;;; debug context identifies that image.
@@ -425,4 +436,82 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
'())
(else
(load-non-immediate
- (bytevector-u32-native-ref bv (+ pos 4))))))))))))
+ (bytevector-u32-native-ref bv (+ pos 4)))))))))
+ (else '()))))
+
+(define-record-type <source>
+ (make-source pre-pc file line column)
+ source?
+ (pre-pc source-pre-pc)
+ (file source-file)
+ (line source-line)
+ (column source-column))
+
+(define (make-source/dwarf pc file line column)
+ (make-source pc file
+ ;; Convert DWARF-numbered (1-based) lines and
+ ;; columns to Guile conventions (0-based).
+ (and line (1- line)) (and column (1- column))))
+
+;; FIXME
+(define (source-post-pc source)
+ (source-pre-pc source))
+
+;; Lines are zero-indexed inside Guile, but users expect them to be
+;; one-indexed. Columns, on the other hand, are zero-indexed to both. Go
+;; figure.
+(define (source-line-for-user source)
+ (1+ (source-line source)))
+
+(define* (find-source-for-addr addr #:optional
+ (context (find-debug-context addr))
+ #:key exact?)
+ (let* ((base (debug-context-base context))
+ (pc (- addr base)))
+ (and=>
+ (false-if-exception
+ (elf->dwarf-context (debug-context-elf context)))
+ (lambda (dwarf-ctx)
+ (or-map (lambda (die)
+ (and=>
+ (die-line-prog die)
+ (lambda (prog)
+ (call-with-values
+ (lambda () (line-prog-scan-to-pc prog pc))
+ (lambda (pc* file line col)
+ (and pc* (or (= pc pc*) (not exact?))
+ (make-source/dwarf (+ pc* base)
+ file line col)))))))
+ (read-die-roots dwarf-ctx))))))
+
+(define* (find-program-die addr #:optional
+ (context (find-debug-context addr)))
+ (and=> (false-if-exception
+ (elf->dwarf-context (debug-context-elf context)))
+ (lambda (dwarf-ctx)
+ (find-die-by-pc (read-die-roots dwarf-ctx)
+ (- addr (debug-context-base context))))))
+
+(define* (find-program-sources addr #:optional
+ (context (find-debug-context addr)))
+ (and=>
+ (find-program-die addr context)
+ (lambda (die)
+ (let* ((base (debug-context-base context))
+ (low-pc (die-ref die 'low-pc))
+ (high-pc (die-high-pc die))
+ (prog (let line-prog ((die die))
+ (and die
+ (or (die-line-prog die)
+ (line-prog (ctx-die (die-ctx die))))))))
+ (cond
+ ((and low-pc high-pc prog)
+ (line-prog-scan-to-pc prog (1- low-pc))
+ (let lp ((sources '()))
+ (call-with-values (lambda () (line-prog-advance prog))
+ (lambda (pc file line col)
+ (if (and pc (< pc high-pc))
+ (lp (cons (make-source/dwarf (+ pc base) file line col)
+ sources))
+ (reverse sources))))))
+ (else '()))))))
diff --git a/module/system/vm/dwarf.scm b/module/system/vm/dwarf.scm
index 90f2df8..352cb22 100644
--- a/module/system/vm/dwarf.scm
+++ b/module/system/vm/dwarf.scm
@@ -104,10 +104,12 @@
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
+ die-name die-specification die-qname die-low-pc die-high-pc
ctx-parent ctx-die ctx-start ctx-end ctx-children ctx-language
+ die-line-prog line-prog-advance line-prog-scan-to-pc
+
find-die-context find-die-by-offset find-die find-die-by-pc
read-die fold-die-list
@@ -712,6 +714,7 @@
abbrevs-start abbrevs-end
strtab-start strtab-end
loc-start loc-end
+ line-start line-end
pubnames-start pubnames-end
aranges-start aranges-end)
dwarf-meta?
@@ -728,6 +731,8 @@
(strtab-end meta-strtab-end)
(loc-start meta-loc-start)
(loc-end meta-loc-end)
+ (line-start meta-line-start)
+ (line-end meta-line-end)
(pubnames-start meta-pubnames-start)
(pubnames-end meta-pubnames-end)
(aranges-start meta-aranges-start)
@@ -769,6 +774,9 @@
(define (read-u8 ctx pos)
(values (bytevector-u8-ref (ctx-bv ctx) pos)
(1+ pos)))
+(define (read-s8 ctx pos)
+ (values (bytevector-s8-ref (ctx-bv ctx) pos)
+ (1+ pos)))
(define (skip-8 ctx pos)
(+ pos 1))
@@ -886,6 +894,14 @@
(1+ end)
(lp (1+ end))))))
+(define (read-string-seq ctx pos)
+ (let ((bv (ctx-bv ctx)))
+ (let lp ((pos pos) (strs '()))
+ (if (zero? (bytevector-u8-ref bv pos))
+ (values (list->vector (reverse strs)) (1+ pos))
+ (let-values (((str pos) (read-string ctx pos)))
+ (lp pos (cons str strs)))))))
+
(define-record-type <abbrev>
(make-abbrev code tag has-children? attrs forms)
abbrev?
@@ -1185,6 +1201,213 @@
(else
(parse-location-list ctx loc))))
+;; Statement programs.
+(define-record-type <lregs>
+ (make-lregs pos pc file line column)
+ lregs?
+ (pos lregs-pos set-lregs-pos!)
+ (pc lregs-pc set-lregs-pc!)
+ (file lregs-file set-lregs-file!)
+ (line lregs-line set-lregs-line!)
+ (column lregs-column set-lregs-column!))
+
+(define-record-type <line-prog>
+ (%make-line-prog ctx version
+ header-offset program-offset end
+ min-insn-length max-insn-ops default-stmt?
+ line-base line-range opcode-base
+ standard-opcode-lengths
+ include-directories file-names
+ regs)
+ line-prog?
+ (ctx line-prog-ctx)
+ (version line-prog-version)
+ (header-offset line-prog-header-offset)
+ (program-offset line-prog-program-offset)
+ (end line-prog-end)
+ (min-insn-length line-prog-min-insn-length)
+ (max-insn-ops line-prog-max-insn-ops)
+ (default-stmt? line-prog-default-stmt?)
+ (line-base line-prog-line-base)
+ (line-range line-prog-line-range)
+ (opcode-base line-prog-opcode-base)
+ (standard-opcode-lengths line-prog-standard-opcode-lengths)
+ (include-directories line-prog-include-directories)
+ (file-names line-prog-file-names)
+ (regs line-prog-regs))
+
+(define (make-line-prog ctx header-pos end)
+ (unless (> end (+ header-pos 12))
+ (error "statement program header too short"))
+ (let-values (((len pos offset-size) (read-initial-length ctx header-pos)))
+ (unless (<= (+ pos len) end)
+ (error (".debug_line too short")))
+ (let*-values (((version pos) (read-u16 ctx pos))
+ ((prologue-len prologue-pos) (read-u32 ctx pos))
+ ((min-insn-len pos) (read-u8 ctx prologue-pos))
+ ;; The maximum_operations_per_instruction field is
+ ;; only present in DWARFv4.
+ ((max-insn-ops pos) (if (< version 4)
+ (values 1 pos)
+ (read-u8 ctx pos)))
+ ((default-stmt pos) (read-u8 ctx pos))
+ ((line-base pos) (read-s8 ctx pos))
+ ((line-range pos) (read-u8 ctx pos))
+ ((opcode-base pos) (read-u8 ctx pos))
+ ((opcode-lens pos) (read-block ctx pos (1- opcode-base)))
+ ((include-directories pos) (read-string-seq ctx pos))
+ ((file-names pos)
+ (let lp ((pos pos) (strs '()))
+ (if (zero? (bytevector-u8-ref (ctx-bv ctx) pos))
+ (values (reverse strs) (1+ pos))
+ (let-values (((str pos) (read-string ctx pos)))
+ (let* ((pos (skip-leb128 ctx pos)) ; skip dir
+ (pos (skip-leb128 ctx pos)) ; skip mtime
+ (pos (skip-leb128 ctx pos))) ; skip len
+ (lp pos (cons str strs))))))))
+ (unless (= pos (+ prologue-pos prologue-len))
+ (error "unexpected prologue length"))
+ (%make-line-prog ctx version header-pos pos end
+ min-insn-len max-insn-ops (not (zero? default-stmt))
+ line-base line-range opcode-base opcode-lens
+ include-directories file-names
+ ;; Initial state: file=1, line=1, col=0
+ (make-lregs pos 0 1 1 0)))))
+
+(define (line-prog-next-row prog pos pc file line col)
+ (let ((ctx (line-prog-ctx prog))
+ (end (line-prog-end prog))
+ (min-insn-len (line-prog-min-insn-length prog))
+ (line-base (line-prog-line-base prog))
+ (line-range (line-prog-line-range prog))
+ (opcode-base (line-prog-opcode-base prog))
+ (opcode-lens (line-prog-standard-opcode-lengths prog)))
+
+ (let lp ((pos pos) (pc pc) (file file) (line line) (col col))
+ (cond
+ ((>= pos end)
+ (values #f #f #f #f #f))
+ (else
+ (let-values (((op pos) (read-u8 ctx pos)))
+ (cond
+ ((zero? op) ; extended opcodes
+ (let*-values (((len pos*) (read-uleb128 ctx pos))
+ ((op pos) (read-u8 ctx pos*)))
+ (case op
+ ((1) ; end-sequence
+ (values pos pc file line col))
+ ((2) ; set-address
+ (let-values (((addr pos) (read-addr ctx pos)))
+ (unless (>= addr pc)
+ (error "pc not advancing"))
+ (lp pos addr file line col)))
+ ((3) ; define-file
+ (warn "define-file unimplemented")
+ (lp (+ pos* len) pc file line col))
+ ((4) ; set-discriminator; ignore.
+ (lp (+ pos* len) pc file line col))
+ (else
+ (warn "unknown extended op" op)
+ (lp (+ pos* len) pc file line col)))))
+
+ ((< op opcode-base) ; standard opcodes
+ (case op
+ ((1) ; copy
+ (values pos pc file line col))
+ ((2) ; advance-pc
+ (let-values (((advance pos) (read-uleb128 ctx pos)))
+ (lp pos (+ pc (* advance min-insn-len)) file line col)))
+ ((3) ; advance-line
+ (let-values (((diff pos) (read-sleb128 ctx pos)))
+ (lp pos pc file (+ line diff) col)))
+ ((4) ; set-file
+ (let-values (((file pos) (read-uleb128 ctx pos)))
+ (lp pos pc file line col)))
+ ((5) ; set-column
+ (let-values (((col pos) (read-uleb128 ctx pos)))
+ (lp pos pc file line col)))
+ ((6) ; negate-line
+ (lp pos pc file line col))
+ ((7) ; set-basic-block
+ (lp pos pc file line col))
+ ((8) ; const-add-pc
+ (let ((advance (floor/ (- 255 opcode-base) line-range)))
+ (lp pos (+ pc (* advance min-insn-len)) file line col)))
+ ((9) ; fixed-advance-pc
+ (let-values (((advance pos) (read-u16 ctx pos)))
+ (lp pos (+ pc (* advance min-insn-len)) file line col)))
+ (else
+ ;; fixme: read args and move on
+ (error "unknown extended op" op))))
+ (else ; special opcodes
+ (let-values (((quo rem) (floor/ (- op opcode-base) line-range)))
+ (values pos (+ pc (* quo min-insn-len))
+ file (+ line (+ rem line-base)) col))))))))))
+
+(define (line-prog-advance prog)
+ (let ((regs (line-prog-regs prog)))
+ (call-with-values (lambda ()
+ (line-prog-next-row prog
+ (lregs-pos regs)
+ (lregs-pc regs)
+ (lregs-file regs)
+ (lregs-line regs)
+ (lregs-column regs)))
+ (lambda (pos pc file line col)
+ (cond
+ ((not pos)
+ (values #f #f #f #f))
+ (else
+ (set-lregs-pos! regs pos)
+ (set-lregs-pc! regs pc)
+ (set-lregs-file! regs file)
+ (set-lregs-line! regs line)
+ (set-lregs-column! regs col)
+ ;; Return DWARF-numbered lines and columns (1-based).
+ (values pc
+ (if (zero? file)
+ #f
+ (list-ref (line-prog-file-names prog) (1- file)))
+ (if (zero? line) #f line)
+ (if (zero? col) #f col))))))))
+
+(define (line-prog-scan-to-pc prog target-pc)
+ (let ((regs (line-prog-regs prog)))
+ (define (finish pos pc file line col)
+ (set-lregs-pos! regs pos)
+ (set-lregs-pc! regs pc)
+ (set-lregs-file! regs file)
+ (set-lregs-line! regs line)
+ (set-lregs-column! regs col)
+ ;; Return DWARF-numbered lines and columns (1-based).
+ (values pc
+ (if (zero? file)
+ #f
+ (list-ref (line-prog-file-names prog) (1- file)))
+ (if (zero? line) #f line)
+ (if (zero? col) #f col)))
+ (define (scan pos pc file line col)
+ (call-with-values (lambda ()
+ (line-prog-next-row prog pos pc file line col))
+ (lambda (pos* pc* file* line* col*)
+ (cond
+ ((not pos*)
+ (values #f #f #f #f))
+ ((< pc* target-pc)
+ (scan pos* pc* file* line* col*))
+ ((= pc* target-pc)
+ (finish pos* pc* file* line* col*))
+ (else
+ (finish pos pc file line col))))))
+ (let ((pos (lregs-pos regs))
+ (pc (lregs-pc regs))
+ (file (lregs-file regs))
+ (line (lregs-line regs))
+ (col (lregs-column regs)))
+ (if (< pc target-pc)
+ (scan pos pc file line col)
+ (scan (line-prog-program-offset prog) 0 1 1 0)))))
+
(define-syntax-rule (define-attribute-parsers parse (name parser) ...)
(define parse
(let ((parsers (make-hash-table)))
@@ -1266,6 +1489,15 @@
=> die-qname)
(else #f)))
+(define (die-line-prog die)
+ (let ((stmt-list (die-ref die 'stmt-list)))
+ (and stmt-list
+ (let* ((ctx (die-ctx die))
+ (meta (ctx-meta ctx)))
+ (make-line-prog ctx
+ (+ (meta-line-start meta) stmt-list)
+ (meta-line-end meta))))))
+
(define (read-values ctx offset abbrev)
(let lp ((attrs (abbrev-attrs abbrev))
(forms (abbrev-forms abbrev))
@@ -1377,6 +1609,16 @@
(for-each visit-die roots)
#f))
+(define (die-low-pc die)
+ (die-ref die 'low-pc))
+(define (die-high-pc die)
+ (let ((val (die-ref die 'high-pc)))
+ (and val
+ (let ((idx (list-index (die-attrs die) 'high-pc)))
+ (case (list-ref (die-forms die) idx)
+ ((addr) val)
+ (else (+ val (die-low-pc die))))))))
+
(define (find-die-by-pc roots pc)
;; The result will be a subprogram.
(define (skip? ctx offset abbrev)
@@ -1386,15 +1628,15 @@
(define (recurse? die)
(case (die-tag die)
((compile-unit)
- (not (or (and=> (die-ref die 'low-pc)
+ (not (or (and=> (die-low-pc die)
(lambda (low) (< pc low)))
- (and=> (die-ref die 'high-pc)
+ (and=> (die-high-pc die)
(lambda (high) (<= high pc))))))
(else #f)))
(find-die roots
(lambda (die)
(and (eq? (die-tag die) 'subprogram)
- (equal? (die-ref die 'low-pc) pc)))
+ (equal? (die-low-pc die) pc)))
#:skip? skip? #:recurse? recurse?))
(define (fold-die-list ctx offset skip? proc seed)
@@ -1555,6 +1797,7 @@
(abbrevs (assoc-ref sections ".debug_abbrev"))
(strtab (assoc-ref sections ".debug_str"))
(loc (assoc-ref sections ".debug_loc"))
+ (line (assoc-ref sections ".debug_line"))
(pubnames (assoc-ref sections ".debug_pubnames"))
(aranges (assoc-ref sections ".debug_aranges")))
(make-dwarf-context (elf-bytes elf)
@@ -1576,6 +1819,11 @@
(elf-section-offset loc)
(+ (elf-section-offset loc)
(elf-section-size loc))
+ (and line
+ (elf-section-offset line))
+ (and line
+ (+ (elf-section-offset line)
+ (elf-section-size line)))
(and pubnames
(elf-section-offset pubnames))
(and pubnames
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index c4e4d1f..19789db 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -42,6 +42,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/coverage.test \
tests/cse.test \
tests/curried-definitions.test \
+ tests/dwarf.test \
tests/ecmascript.test \
tests/elisp.test \
tests/elisp-compiler.test \
diff --git a/test-suite/tests/dwarf.test b/test-suite/tests/dwarf.test
new file mode 100644
index 0000000..b999ab1
--- /dev/null
+++ b/test-suite/tests/dwarf.test
@@ -0,0 +1,88 @@
+;;;; dwarf.test -*- scheme -*-
+;;;;
+;;;; Copyright 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
+
+(define-module (test-suite test-dwarf)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 match)
+ #:use-module (system base compile)
+ #:use-module (system vm debug)
+ #:use-module (system vm program)
+ #:use-module (system vm objcode))
+
+(define prog
+ (string-concatenate
+ ;; Every open parenthesis is a possible source location.
+ '("(define (qux f)\n"
+ ;^ 0:0
+ " (+ 32 (f)))\n"
+ ; ^1:2 ^1:8
+ "\n"
+ "(define bar\n"
+ ;^ 3;0
+ " (lambda (a)\n"
+ ; ^ 4:2
+ " 13))\n"
+ "'success\n")
+ ))
+
+(let* ((port (open-input-string prog))
+ (bv (begin
+ (set-port-filename! port "foo.scm")
+ (read-and-compile port #:to 'rtl))))
+ (pass-if-equal 'success
+ ((load-thunk-from-memory bv)))
+
+ (pass-if-equal 13 (bar 10))
+
+ (let ((source (find-source-for-addr (rtl-program-code qux))))
+ (pass-if-equal "foo.scm" (source-file source))
+ (pass-if-equal 0 (source-line source))
+ (pass-if-equal 1 (source-line-for-user source))
+ (pass-if-equal 0 (source-column source)))
+
+ (let ((source (find-source-for-addr (rtl-program-code bar))))
+ (pass-if-equal "foo.scm" (source-file source))
+ (pass-if-equal 4 (source-line source))
+ (pass-if-equal 5 (source-line-for-user source))
+ (pass-if-equal 2 (source-column source)))
+
+ (match (find-program-sources (rtl-program-code qux))
+ ((s1 s2)
+ (pass-if-equal "foo.scm" (source-file s1))
+ (pass-if-equal 0 (source-line s1))
+ (pass-if-equal 1 (source-line-for-user s1))
+ (pass-if-equal 0 (source-column s1))
+
+ ;; FIXME: For some reason the source location for the + isn't
+ ;; getting propagated.
+
+ (pass-if-equal "foo.scm" (source-file s2))
+ (pass-if-equal 1 (source-line s2))
+ (pass-if-equal 2 (source-line-for-user s2))
+ (pass-if-equal 8 (source-column s2)))
+ (sources
+ (error "unexpected sources" sources)))
+
+ (match (find-program-sources (rtl-program-code bar))
+ ((source)
+ (pass-if-equal "foo.scm" (source-file source))
+ (pass-if-equal 4 (source-line source))
+ (pass-if-equal 5 (source-line-for-user source))
+ (pass-if-equal 2 (source-column source)))
+ (sources
+ (error "unexpected sources" sources))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-207-gae07b8e,
Andy Wingo <=