1 ;;; Guile DWARF reader and writer
3 ;; Copyright (C) 2012, 2013 Free Software Foundation, Inc.
5 ;; Parts of this file were derived from sysdeps/generic/dwarf2.h, from
6 ;; the GNU C Library. That file is available under the LGPL version 2
7 ;; or later, and is copyright:
9 ;; Copyright (C) 1992, 1993, 1995, 1996, 1997, 2000, 2011
10 ;; Free Software Foundation, Inc.
11 ;; Contributed by Gary Funck (gary@intrepid.com). Derived from the
12 ;; DWARF 1 implementation written by Ron Guilmette (rfg@monkeys.com).
14 ;;;; This library is free software; you can redistribute it and/or
15 ;;;; modify it under the terms of the GNU Lesser General Public
16 ;;;; License as published by the Free Software Foundation; either
17 ;;;; version 3 of the License, or (at your option) any later version.
19 ;;;; This library is distributed in the hope that it will be useful,
20 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
22 ;;;; Lesser General Public License for more details.
24 ;;;; You should have received a copy of the GNU Lesser General Public
25 ;;;; License along with this library; if not, write to the Free Software
26 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
30 ;; DWARF is a flexible format for describing compiled programs. It is
31 ;; used by Guile to record source positions, describe local variables,
32 ;; function arities, and other function metadata.
34 ;; Structurally, DWARF describes a tree of data. Each node in the tree
35 ;; is a debugging information entry ("DIE"). Each DIE has a "tag",
36 ;; possible a set of attributes, and possibly some child DIE nodes.
37 ;; That's basically it!
39 ;; The DIE nodes are contained in the .debug_info section of an ELF
40 ;; file. Attributes within the DIE nodes link them to mapped ranges of
41 ;; the ELF file (.rtl-text, .data, etc.).
43 ;; A .debug_info section logically contains a series of debugging
44 ;; "contributions", one for each compilation unit. Each contribution is
45 ;; prefixed by a header and contains a single DIE element whose tag is
46 ;; "compilation-unit". That node usually contains child nodes, for
47 ;; example of type "subprogram".
49 ;; Since usually one will end up producing many DIE nodes with the same
50 ;; tag and attribute types, DIE nodes are defined by referencing a known
51 ;; shape, and then filling in the values. The shapes are defined in the
52 ;; form of "abbrev" entries, which specify a specific combination of a
53 ;; tag and an ordered set of attributes, with corresponding attribute
54 ;; representations ("forms"). Abbrevs are written out to a separate
55 ;; section, .debug_abbrev. Abbrev nodes also specify whether the
56 ;; corresponding DIE node has children or not. When a DIE is written
57 ;; into the .debug_info section, it references one of the abbrevs in
58 ;; .debug_abbrev. You need the abbrev in order to parse the DIE.
60 ;; For completeness, the other sections that DWARF uses are .debug_str,
61 ;; .debug_loc, .debug_pubnames, .debug_aranges, .debug_frame, and
62 ;; .debug_line. These are described in section 6 of the DWARF 3.0
63 ;; specification, at http://dwarfstd.org/.
65 ;; This DWARF module is currently capable of parsing all of DWARF 2.0
66 ;; and parts of DWARF 3.0. For Guile's purposes, we also use DWARF as
67 ;; the format for our own debugging information. The DWARF generator is
68 ;; fairly minimal, and is not intended to be complete.
72 (define-module (system vm dwarf)
73 #:use-module (rnrs bytevectors)
74 #:use-module (system foreign)
75 #:use-module (system base target)
76 #:use-module (system vm elf)
77 #:use-module ((srfi srfi-1) #:select (fold))
78 #:use-module (srfi srfi-9)
79 #:use-module (srfi srfi-9 gnu)
80 #:use-module (srfi srfi-11)
81 #:export (elf->dwarf-context
83 fold-pubnames fold-aranges
88 call-frame-address-name->code
91 discriminant-name->code
97 sensitivity-name->code
100 visibility-name->code
103 abbrev-tag abbrev-has-children? abbrev-attrs abbrev-forms
105 die? die-ctx die-offset die-abbrev die-vals die-children
106 die-tag die-attrs die-forms die-ref
107 die-name die-specification die-qname die-low-pc die-high-pc
109 ctx-parent ctx-die ctx-start ctx-end ctx-children ctx-language
111 die-line-prog line-prog-advance line-prog-scan-to-pc
113 find-die-context find-die-by-offset find-die find-die-by-pc
114 read-die fold-die-list
116 fold-die-children die->tree))
119 ;;; First, define a number of constants. The figures numbers refer to
120 ;;; the DWARF 2.0 draft specification available on http://dwarfstd.org/.
121 ;;; Extra codes not defined in that document are taken from the dwarf2
125 (define-syntax-rule (define-enumeration code->name name->code
129 (let ((table (make-hash-table)))
130 (hashv-set! table value 'tag)
133 (hashv-ref table v v))))
135 (let ((table (make-hash-table)))
136 (hashv-set! table 'tag value)
139 (hashv-ref table v v))))))
141 ;; Figures 14 and 15: Tag names and codes.
143 (define-enumeration tag-code->name tag-name->code
148 (enumeration-type #x04)
149 (formal-parameter #x05)
150 (imported-declaration #x08)
155 (reference-type #x10)
158 (structure-type #x13)
159 (subroutine-type #x15)
162 (unspecified-parameters #x18)
165 (common-inclusion #x1b)
167 (inlined-subroutine #x1d)
169 (ptr-to-member-type #x1f)
173 (access-declaration #x23)
185 (template-type-param #x2f)
186 (template-value-param #x30)
193 (dwarf-procedure #x36)
195 (interface-type #x38)
197 (imported-module #x3a)
198 (unspecified-type #x3b)
204 (format-label #x4101)
205 (function-template #x4102)
206 (class-template #x4103)
212 ;; Figure 16: Flag that tells whether entry has a child or not.
214 (define-enumeration children-code->name children-name->code
218 ;; Figures 17 and 18: Attribute names and codes.
220 (define-enumeration attribute-code->name attribute-name->code
240 (common-reference #x1a)
243 (containing-type #x1d)
254 (abstract-origin #x31)
259 (calling-convention #x36)
261 (data-member-location #x38)
271 (identifier-case #x42)
273 (namelist-items #x44)
280 (variable-parameter #x4b)
282 (vtable-elem-location #x4d)
301 (picture-string #x60)
303 (threads-scaled #x62)
305 (object-pointer #x64)
311 (linkage-name #x2007)
321 ;; Figure 19: Form names and codes.
323 (define-enumeration form-code->name form-name->code
350 ;; Figures 22 and 23: Location atom names and codes.
352 (define-enumeration location-op->name location-name->op
499 (push-object-address #x97)
503 (form-tls-address #x9b)
504 (call-frame-cfa #x9c)
509 ;; Figure 24: Type encodings.
511 (define-enumeration type-encoding->name type-name->encoding
522 (imaginary-float #x09)
523 (packed-decimal #x0a)
524 (numeric-string #x0b)
527 (unsigned-fixed #x0e)
532 ;; Figure 25: Access attribute.
534 (define-enumeration access-code->name access-name->code
539 ;; Figure 26: Visibility.
541 (define-enumeration visibility-code->name visibility-name->code
546 ;; Figure 27: Virtuality.
548 (define-enumeration virtuality-code->name virtuality-name->code
553 ;; Figure 28: Source language names and codes.
555 (define-enumeration language-code->name language-name->code
576 (mips-assembler #x8001)
580 ;; FIXME: Ask for proper codes for these.
589 ;; Figure 29: Case sensitivity.
591 (define-enumeration case-sensitivity-code->name case-sensitivity-name->code
595 (case-insensitive 3))
597 ;; Figure 30: Calling convention.
599 (define-enumeration calling-convention-code->name calling-convention-name->code
606 ;; Figure 31: Inline attribute.
608 (define-enumeration inline-code->name inline-name->code
611 (declared-not-inlined 2)
612 (declared-inlined 3))
614 ;; Figure 32: Array ordering names and codes.
615 (define-enumeration ordering-code->name ordering-name->code
619 ;; Figure 33: Discriminant lists.
621 (define-enumeration discriminant-code->name discriminant-name->code
625 ;; Figure 34: "Standard" line number opcodes.
627 (define-enumeration standard-line-opcode->name standard-line-name->opcode
639 (set-prologue-end #x0a)
640 (set-epilogue-begin #x0b)
643 ;; Figure 35: "Extended" line number opcodes.
645 (define-enumeration extended-line-opcode->name extended-line-name->opcode
653 ;; Figure 36: Names and codes for macro information.
655 (define-enumeration macro-code->name macro-name->code
662 ;; Figure 37: Call frame information.
664 (define-enumeration call-frame-address-code->name call-frame-address-code->name
673 (offset-extended #x05)
674 (restore-extended #x06)
678 (remember-state #x0a)
681 (def-cfa-register #x0d)
682 (def-cfa-offset #x0e)
684 (def-cfa-expression #x0f)
686 (offset-extended-sf #x11)
688 (def-cfa-offset-sf #x13)
691 (val-expression #x16)
692 (GNU-window-save #x2d)
694 (GNU-negative-offset-extended #x2f)
700 ;(define CIE-ID #xffffffff)
701 ;(define CIE-VERSION 1)
702 ;(define ADDR-none 0)
706 ;;; A general configuration object.
709 (define-record-type <dwarf-meta>
710 (make-dwarf-meta addr-size
714 abbrevs-start abbrevs-end
715 strtab-start strtab-end
718 pubnames-start pubnames-end
719 aranges-start aranges-end)
721 (addr-size meta-addr-size)
725 (lib-path meta-lib-path)
726 (info-start meta-info-start)
727 (info-end meta-info-end)
728 (abbrevs-start meta-abbrevs-start)
729 (abbrevs-end meta-abbrevs-end)
730 (strtab-start meta-strtab-start)
731 (strtab-end meta-strtab-end)
732 (loc-start meta-loc-start)
733 (loc-end meta-loc-end)
734 (line-start meta-line-start)
735 (line-end meta-line-end)
736 (pubnames-start meta-pubnames-start)
737 (pubnames-end meta-pubnames-end)
738 (aranges-start meta-aranges-start)
739 (aranges-end meta-aranges-end))
741 ;; A context represents a namespace. The root context is the
742 ;; compilation unit. DIE nodes of type class-type, structure-type, or
743 ;; namespace may form child contexts.
745 (define-record-type <dwarf-context>
746 (make-dwarf-context bv offset-size endianness meta
748 parent die start end children)
751 (offset-size ctx-offset-size)
752 (endianness ctx-endianness)
754 (abbrevs ctx-abbrevs)
759 (children ctx-children set-children!))
762 (set-record-type-printer! <dwarf-context>
764 (format port "<dwarf-context ~a>"
765 (number->string (object-address x) 16))))
767 (define-inlinable (ctx-addr-size ctx)
768 (meta-addr-size (ctx-meta ctx)))
771 ;;; Procedures for reading DWARF data.
774 (define (read-u8 ctx pos)
775 (values (bytevector-u8-ref (ctx-bv ctx) pos)
777 (define (read-s8 ctx pos)
778 (values (bytevector-s8-ref (ctx-bv ctx) pos)
780 (define (skip-8 ctx pos)
783 (define (read-u16 ctx pos)
784 (values (bytevector-u16-ref (ctx-bv ctx) pos (ctx-endianness ctx))
786 (define (skip-16 ctx pos)
789 (define (read-u32 ctx pos)
790 (values (bytevector-u32-ref (ctx-bv ctx) pos (ctx-endianness ctx))
792 (define (skip-32 ctx pos)
795 (define (read-u64 ctx pos)
796 (values (bytevector-u64-ref (ctx-bv ctx) pos (ctx-endianness ctx))
798 (define (skip-64 ctx pos)
801 (define (read-addr ctx pos)
802 (case (ctx-addr-size ctx)
803 ((4) (read-u32 ctx pos))
804 ((8) (read-u64 ctx pos))
805 (else (error "unsupported word size" ctx))))
806 (define (skip-addr ctx pos)
807 (+ pos (ctx-addr-size ctx)))
809 (define (%read-uleb128 bv pos)
811 (let ((b (bytevector-u8-ref bv pos)))
812 (if (zero? (logand b #x80))
815 (let lp ((n (logxor #x80 b)) (pos (1+ pos)) (shift 7))
816 (let ((b (bytevector-u8-ref bv pos)))
817 (if (zero? (logand b #x80))
818 (values (logior (ash b shift) n)
820 (lp (logior (ash (logxor #x80 b) shift) n)
824 (define (%read-sleb128 bv pos)
825 (let lp ((n 0) (pos pos) (shift 0))
826 (let ((b (bytevector-u8-ref bv pos)))
827 (if (zero? (logand b #x80))
828 (values (logior (ash b shift) n
829 (if (zero? (logand #x40 b))
831 (- (ash 1 (+ shift 7)))))
833 (lp (logior (ash (logxor #x80 b) shift) n)
837 (define (read-uleb128 ctx pos)
838 (%read-uleb128 (ctx-bv ctx) pos))
840 (define (read-sleb128 ctx pos)
841 (%read-sleb128 (ctx-bv ctx) pos))
843 (define (skip-leb128 ctx pos)
844 (let ((bv (ctx-bv ctx)))
846 (let ((b (bytevector-u8-ref bv pos)))
847 (if (zero? (logand b #x80))
851 (define (read-initial-length ctx pos)
852 (let ((len (bytevector-u32-ref (ctx-bv ctx) pos (ctx-endianness ctx))))
855 (values (bytevector-u32-ref (ctx-bv ctx) (+ pos 4) (ctx-endianness ctx))
859 (error "bad initial length value" len))
865 (define* (read-offset ctx pos #:optional (offset-size (ctx-offset-size ctx)))
867 ((4) (values (read-u32 ctx pos) (+ pos 4)))
868 ((8) (values (read-u64 ctx pos) (+ pos 8)))
869 (else (error "bad word size" offset-size))))
871 (define* (skip-offset ctx pos #:optional (offset-size (ctx-offset-size ctx)))
874 (define (read-block ctx pos len)
875 (let ((bv (make-bytevector len)))
876 (bytevector-copy! (ctx-bv ctx) pos bv 0 len)
880 (define (read-string ctx pos)
881 (let ((bv (ctx-bv ctx)))
883 (if (zero? (bytevector-u8-ref bv end))
884 (let ((out (make-bytevector (- end pos))))
885 (bytevector-copy! bv pos out 0 (- end pos))
886 (values (utf8->string out)
890 (define (skip-string ctx pos)
891 (let ((bv (ctx-bv ctx)))
893 (if (zero? (bytevector-u8-ref bv end))
897 (define (read-string-seq ctx pos)
898 (let ((bv (ctx-bv ctx)))
899 (let lp ((pos pos) (strs '()))
900 (if (zero? (bytevector-u8-ref bv pos))
901 (values (list->vector (reverse strs)) (1+ pos))
902 (let-values (((str pos) (read-string ctx pos)))
903 (lp pos (cons str strs)))))))
905 (define-record-type <abbrev>
906 (make-abbrev code tag has-children? attrs forms)
910 (has-children? abbrev-has-children?)
912 (forms abbrev-forms))
914 (define (read-abbrev ctx pos)
915 (let*-values (((code pos) (read-uleb128 ctx pos))
916 ((tag pos) (read-uleb128 ctx pos))
917 ((children pos) (read-u8 ctx pos)))
918 (let lp ((attrs '()) (forms '()) (pos pos))
919 (let*-values (((attr pos) (read-uleb128 ctx pos))
920 ((form pos) (read-uleb128 ctx pos)))
921 (if (and (zero? attr) (zero? form))
922 (values (make-abbrev code
924 (eq? (children-code->name children) 'yes)
928 (lp (cons (attribute-code->name attr) attrs)
929 (cons (form-code->name form) forms)
932 (define* (read-abbrevs ctx pos
933 #:optional (start (meta-abbrevs-start
935 (end (meta-abbrevs-end
937 (let lp ((abbrevs '()) (pos (+ start pos)) (max-code -1))
938 (if (zero? (read-u8 ctx pos))
940 (let ((av (make-vector (1+ max-code) #f)))
941 (for-each (lambda (a)
942 (vector-set! av (abbrev-code a) a))
945 (error "Unexpected length" abbrevs pos start end))
946 (let-values (((abbrev pos) (read-abbrev ctx pos)))
947 (lp (cons abbrev abbrevs)
949 (max (abbrev-code abbrev) max-code))))))
951 (define (ctx-compile-unit-start ctx)
953 (ctx-compile-unit-start (ctx-parent ctx))
958 (define *readers* (make-hash-table))
959 (define *scanners* (make-hash-table))
960 (define-syntax define-value-reader
962 ((_ form reader scanner)
964 (hashq-set! *readers* 'form reader)
965 (hashq-set! *scanners* 'form scanner)))))
967 (define-value-reader addr read-addr skip-addr)
969 (define-value-reader block
971 (let-values (((len pos) (read-uleb128 ctx pos)))
972 (read-block ctx pos len)))
974 (let-values (((len pos) (read-uleb128 ctx pos)))
977 (define-value-reader block1
979 (let-values (((len pos) (read-u8 ctx pos)))
980 (read-block ctx pos len)))
982 (+ pos 1 (bytevector-u8-ref (ctx-bv ctx) pos))))
984 (define-value-reader block2
986 (let-values (((len pos) (read-u16 ctx pos)))
987 (read-block ctx pos len)))
989 (+ pos 2 (bytevector-u16-ref (ctx-bv ctx) pos (ctx-endianness ctx)))))
991 (define-value-reader block4
993 (let-values (((len pos) (read-u32 ctx pos)))
994 (read-block ctx pos len)))
996 (+ pos 4 (bytevector-u32-ref (ctx-bv ctx) pos (ctx-endianness ctx)))))
998 (define-value-reader data1 read-u8 skip-8)
999 (define-value-reader data2 read-u16 skip-16)
1000 (define-value-reader data4 read-u32 skip-32)
1001 (define-value-reader data8 read-u64 skip-64)
1002 (define-value-reader udata read-uleb128 skip-leb128)
1003 (define-value-reader sdata read-sleb128 skip-leb128)
1005 (define-value-reader flag
1007 (values (not (zero? (bytevector-u8-ref (ctx-bv ctx) pos)))
1011 (define-value-reader string
1015 (define-value-reader strp
1017 (let ((strtab (meta-strtab-start (ctx-meta ctx))))
1019 (error "expected a string table" ctx))
1020 (let-values (((offset pos) (read-offset ctx pos)))
1021 (values (read-string ctx (+ strtab offset))
1025 (define-value-reader ref-addr
1027 (let-values (((addr pos) (read-addr ctx pos)))
1028 (values (+ addr (meta-info-start (ctx-meta ctx)))
1032 (define-value-reader ref1
1034 (let-values (((addr pos) (read-u8 ctx pos)))
1035 (values (+ addr (ctx-compile-unit-start ctx))
1039 (define-value-reader ref2
1041 (let-values (((addr pos) (read-u16 ctx pos)))
1042 (values (+ addr (ctx-compile-unit-start ctx))
1046 (define-value-reader ref4
1048 (let-values (((addr pos) (read-u32 ctx pos)))
1049 (values (+ addr (ctx-compile-unit-start ctx))
1053 (define-value-reader ref8
1055 (let-values (((addr pos) (read-u64 ctx pos)))
1056 (values (+ addr (ctx-compile-unit-start ctx))
1060 (define-value-reader ref
1061 (lambda (udata ctx pos)
1062 (let-values (((addr pos) (read-uleb128 ctx pos)))
1063 (values (+ addr (ctx-compile-unit-start ctx))
1067 (define-value-reader indirect
1069 (let*-values (((form pos) (read-uleb128 ctx pos))
1070 ((val pos) (read-value ctx pos (form-code->name form))))
1071 (values (cons form val)
1074 (let*-values (((form pos) (read-uleb128 ctx pos)))
1075 (skip-value ctx pos (form-code->name form)))))
1077 (define-value-reader sec-offset
1081 (define-value-reader exprloc
1083 (let-values (((len pos) (read-uleb128 ctx pos)))
1084 (read-block ctx pos len)))
1086 (let-values (((len pos) (read-uleb128 ctx pos)))
1089 (define-value-reader flag-present
1095 (define-value-reader ref-sig8
1099 (define (read-value ctx pos form)
1100 ((or (hashq-ref *readers* form)
1101 (error "unrecognized form" form))
1104 (define (skip-value ctx pos form)
1105 ((or (hashq-ref *scanners* form)
1106 (error "unrecognized form" form))
1109 ;; Parsers for particular attributes.
1111 (define (parse-location-list ctx offset)
1112 (let lp ((pos (+ (meta-loc-start (ctx-meta ctx)) offset))
1114 (let*-values (((start pos) (read-addr ctx pos))
1115 ((end pos) (read-addr ctx pos)))
1116 (if (and (zero? start) (zero? end))
1118 (let*-values (((len pos) (read-u16 ctx pos))
1119 ((block pos) (read-block ctx pos len)))
1121 (cons (list start end (parse-location ctx block)) out)))))))
1123 (define (parse-location ctx loc)
1126 (let ((len (bytevector-length loc))
1127 (addr-size (ctx-addr-size ctx))
1128 (endianness (ctx-endianness ctx)))
1129 (define (u8-ref pos) (bytevector-u8-ref loc pos))
1130 (define (s8-ref pos) (bytevector-s8-ref loc pos))
1131 (define (u16-ref pos) (bytevector-u16-ref loc pos endianness))
1132 (define (s16-ref pos) (bytevector-s16-ref loc pos endianness))
1133 (define (u32-ref pos) (bytevector-u32-ref loc pos endianness))
1134 (define (s32-ref pos) (bytevector-s32-ref loc pos endianness))
1135 (define (u64-ref pos) (bytevector-u64-ref loc pos endianness))
1136 (define (s64-ref pos) (bytevector-s64-ref loc pos endianness))
1137 (let lp ((pos 0) (out '()))
1140 (let ((op (location-op->name (u8-ref pos))))
1144 ((4) (lp (+ pos 5) (cons (list op (u32-ref (1+ pos))) out)))
1145 ((8) (lp (+ pos 9) (cons (list op (u64-ref (1+ pos))) out)))
1146 (else (error "what!"))))
1150 (cons (list op (+ (meta-info-start (ctx-meta ctx))
1151 (u32-ref (1+ pos))))
1154 (cons (list op (+ (meta-info-start (ctx-meta ctx))
1155 (u64-ref (1+ pos))))
1157 (else (error "what!"))))
1158 ((const1u pick deref-size xderef-size)
1159 (lp (+ pos 2) (cons (list op (u8-ref (1+ pos))) out)))
1161 (lp (+ pos 2) (cons (list op (s8-ref (1+ pos))) out)))
1163 (lp (+ pos 3) (cons (list op (u16-ref (1+ pos))) out)))
1165 (lp (+ pos 3) (cons (list op (+ (ctx-compile-unit-start ctx)
1166 (u16-ref (1+ pos))))
1169 (lp (+ pos 3) (cons (list op (s16-ref (1+ pos))) out)))
1171 (lp (+ pos 5) (cons (list op (u32-ref (1+ pos))) out)))
1173 (lp (+ pos 5) (cons (list op (+ (ctx-compile-unit-start ctx)
1174 (u32-ref (1+ pos))))
1177 (lp (+ pos 5) (cons (list op (s32-ref (1+ pos))) out)))
1179 (lp (+ pos 9) (cons (list op (u64-ref (1+ pos))) out)))
1181 (lp (+ pos 9) (cons (list op (s64-ref (1+ pos))) out)))
1182 ((plus-uconst regx piece)
1183 (let-values (((val pos) (%read-uleb128 loc (1+ pos))))
1184 (lp pos (cons (list op val) out))))
1186 (let*-values (((bit-len pos) (%read-uleb128 loc (1+ pos)))
1187 ((bit-offset pos) (%read-uleb128 loc pos)))
1188 (lp pos (cons (list op bit-len bit-offset) out))))
1189 ((breg0 breg1 breg2 breg3 breg4 breg5 breg6 breg7 breg8 breg9
1190 breg10 breg11 breg12 breg13 breg14 breg15 breg16 breg17
1191 breg18 breg19 breg20 breg21 breg22 breg23 breg24 breg25
1192 breg26 breg27 breg28 breg29 breg30 breg31 fbreg)
1193 (let-values (((val pos) (%read-sleb128 loc (1+ pos))))
1194 (lp pos (cons (list op val) out))))
1197 ;; We failed to parse this opcode; we have to give
1200 (lp (1+ pos) (cons (list op) out))))))))))
1202 (parse-location-list ctx loc))))
1204 ;; Statement programs.
1205 (define-record-type <lregs>
1206 (make-lregs pos pc file line column)
1208 (pos lregs-pos set-lregs-pos!)
1209 (pc lregs-pc set-lregs-pc!)
1210 (file lregs-file set-lregs-file!)
1211 (line lregs-line set-lregs-line!)
1212 (column lregs-column set-lregs-column!))
1214 (define-record-type <line-prog>
1215 (%make-line-prog ctx version
1216 header-offset program-offset end
1217 min-insn-length max-insn-ops default-stmt?
1218 line-base line-range opcode-base
1219 standard-opcode-lengths
1220 include-directories file-names
1224 (version line-prog-version)
1225 (header-offset line-prog-header-offset)
1226 (program-offset line-prog-program-offset)
1228 (min-insn-length line-prog-min-insn-length)
1229 (max-insn-ops line-prog-max-insn-ops)
1230 (default-stmt? line-prog-default-stmt?)
1231 (line-base line-prog-line-base)
1232 (line-range line-prog-line-range)
1233 (opcode-base line-prog-opcode-base)
1234 (standard-opcode-lengths line-prog-standard-opcode-lengths)
1235 (include-directories line-prog-include-directories)
1236 (file-names line-prog-file-names)
1237 (regs line-prog-regs))
1239 (define (make-line-prog ctx header-pos end)
1240 (unless (> end (+ header-pos 12))
1241 (error "statement program header too short"))
1242 (let-values (((len pos offset-size) (read-initial-length ctx header-pos)))
1243 (unless (<= (+ pos len) end)
1244 (error (".debug_line too short")))
1245 (let*-values (((version pos) (read-u16 ctx pos))
1246 ((prologue-len prologue-pos) (read-u32 ctx pos))
1247 ((min-insn-len pos) (read-u8 ctx prologue-pos))
1248 ;; The maximum_operations_per_instruction field is
1249 ;; only present in DWARFv4.
1250 ((max-insn-ops pos) (if (< version 4)
1253 ((default-stmt pos) (read-u8 ctx pos))
1254 ((line-base pos) (read-s8 ctx pos))
1255 ((line-range pos) (read-u8 ctx pos))
1256 ((opcode-base pos) (read-u8 ctx pos))
1257 ((opcode-lens pos) (read-block ctx pos (1- opcode-base)))
1258 ((include-directories pos) (read-string-seq ctx pos))
1260 (let lp ((pos pos) (strs '()))
1261 (if (zero? (bytevector-u8-ref (ctx-bv ctx) pos))
1262 (values (reverse strs) (1+ pos))
1263 (let-values (((str pos) (read-string ctx pos)))
1264 (let* ((pos (skip-leb128 ctx pos)) ; skip dir
1265 (pos (skip-leb128 ctx pos)) ; skip mtime
1266 (pos (skip-leb128 ctx pos))) ; skip len
1267 (lp pos (cons str strs))))))))
1268 (unless (= pos (+ prologue-pos prologue-len))
1269 (error "unexpected prologue length"))
1270 (%make-line-prog ctx version header-pos pos end
1271 min-insn-len max-insn-ops (not (zero? default-stmt))
1272 line-base line-range opcode-base opcode-lens
1273 include-directories file-names
1274 ;; Initial state: file=1, line=1, col=0
1275 (make-lregs pos 0 1 1 0)))))
1277 (define (line-prog-next-row prog pos pc file line col)
1278 (let ((ctx (line-prog-ctx prog))
1279 (end (line-prog-end prog))
1280 (min-insn-len (line-prog-min-insn-length prog))
1281 (line-base (line-prog-line-base prog))
1282 (line-range (line-prog-line-range prog))
1283 (opcode-base (line-prog-opcode-base prog))
1284 (opcode-lens (line-prog-standard-opcode-lengths prog)))
1286 (let lp ((pos pos) (pc pc) (file file) (line line) (col col))
1289 (values #f #f #f #f #f))
1291 (let-values (((op pos) (read-u8 ctx pos)))
1293 ((zero? op) ; extended opcodes
1294 (let*-values (((len pos*) (read-uleb128 ctx pos))
1295 ((op pos) (read-u8 ctx pos*)))
1298 (values pos pc file line col))
1300 (let-values (((addr pos) (read-addr ctx pos)))
1301 (unless (>= addr pc)
1302 (error "pc not advancing"))
1303 (lp pos addr file line col)))
1305 (warn "define-file unimplemented")
1306 (lp (+ pos* len) pc file line col))
1307 ((4) ; set-discriminator; ignore.
1308 (lp (+ pos* len) pc file line col))
1310 (warn "unknown extended op" op)
1311 (lp (+ pos* len) pc file line col)))))
1313 ((< op opcode-base) ; standard opcodes
1316 (values pos pc file line col))
1318 (let-values (((advance pos) (read-uleb128 ctx pos)))
1319 (lp pos (+ pc (* advance min-insn-len)) file line col)))
1321 (let-values (((diff pos) (read-sleb128 ctx pos)))
1322 (lp pos pc file (+ line diff) col)))
1324 (let-values (((file pos) (read-uleb128 ctx pos)))
1325 (lp pos pc file line col)))
1327 (let-values (((col pos) (read-uleb128 ctx pos)))
1328 (lp pos pc file line col)))
1330 (lp pos pc file line col))
1331 ((7) ; set-basic-block
1332 (lp pos pc file line col))
1334 (let ((advance (floor/ (- 255 opcode-base) line-range)))
1335 (lp pos (+ pc (* advance min-insn-len)) file line col)))
1336 ((9) ; fixed-advance-pc
1337 (let-values (((advance pos) (read-u16 ctx pos)))
1338 (lp pos (+ pc (* advance min-insn-len)) file line col)))
1340 ;; fixme: read args and move on
1341 (error "unknown extended op" op))))
1342 (else ; special opcodes
1343 (let-values (((quo rem) (floor/ (- op opcode-base) line-range)))
1344 (values pos (+ pc (* quo min-insn-len))
1345 file (+ line (+ rem line-base)) col))))))))))
1347 (define (line-prog-advance prog)
1348 (let ((regs (line-prog-regs prog)))
1349 (call-with-values (lambda ()
1350 (line-prog-next-row prog
1355 (lregs-column regs)))
1356 (lambda (pos pc file line col)
1359 (values #f #f #f #f))
1361 (set-lregs-pos! regs pos)
1362 (set-lregs-pc! regs pc)
1363 (set-lregs-file! regs file)
1364 (set-lregs-line! regs line)
1365 (set-lregs-column! regs col)
1366 ;; Return DWARF-numbered lines and columns (1-based).
1370 (list-ref (line-prog-file-names prog) (1- file)))
1371 (if (zero? line) #f line)
1372 (if (zero? col) #f col))))))))
1374 (define (line-prog-scan-to-pc prog target-pc)
1375 (let ((regs (line-prog-regs prog)))
1376 (define (finish pos pc file line col)
1377 (set-lregs-pos! regs pos)
1378 (set-lregs-pc! regs pc)
1379 (set-lregs-file! regs file)
1380 (set-lregs-line! regs line)
1381 (set-lregs-column! regs col)
1382 ;; Return DWARF-numbered lines and columns (1-based).
1386 (list-ref (line-prog-file-names prog) (1- file)))
1387 (if (zero? line) #f line)
1388 (if (zero? col) #f col)))
1389 (define (scan pos pc file line col)
1390 (call-with-values (lambda ()
1391 (line-prog-next-row prog pos pc file line col))
1392 (lambda (pos* pc* file* line* col*)
1395 (values #f #f #f #f))
1397 (scan pos* pc* file* line* col*))
1399 (finish pos* pc* file* line* col*))
1401 ;; We scanned from the beginning didn't find any info.
1402 (values #f #f #f #f))
1404 (finish pos pc file line col))))))
1405 (let ((pos (lregs-pos regs))
1406 (pc (lregs-pc regs))
1407 (file (lregs-file regs))
1408 (line (lregs-line regs))
1409 (col (lregs-column regs)))
1410 (if (< pc target-pc)
1411 (scan pos pc file line col)
1412 (scan (line-prog-program-offset prog) 0 1 1 0)))))
1414 (define-syntax-rule (define-attribute-parsers parse (name parser) ...)
1416 (let ((parsers (make-hash-table)))
1417 (hashq-set! parsers 'name parser)
1419 (lambda (ctx attr val)
1421 ((hashq-ref parsers attr) => (lambda (p) (p ctx val)))
1424 (define-attribute-parsers parse-attribute
1425 (encoding (lambda (ctx val) (type-encoding->name val)))
1426 (accessibility (lambda (ctx val) (access-code->name val)))
1427 (visibility (lambda (ctx val) (visibility-code->name val)))
1428 (virtuality (lambda (ctx val) (virtuality-code->name val)))
1429 (language (lambda (ctx val) (language-code->name val)))
1430 (location parse-location)
1431 (data-member-location parse-location)
1432 (case-sensitive (lambda (ctx val) (case-sensitivity-code->name val)))
1433 (calling-convention (lambda (ctx val) (calling-convention-code->name val)))
1434 (inline (lambda (ctx val) (inline-code->name val)))
1435 (ordering (lambda (ctx val) (ordering-code->name val)))
1436 (discr-value (lambda (ctx val) (discriminant-code->name val))))
1438 ;; "Debugging Information Entries": DIEs.
1440 (define-record-type <die>
1441 (make-die ctx offset abbrev vals)
1446 (vals %die-vals %set-die-vals!))
1448 (define (die-tag die)
1449 (abbrev-tag (die-abbrev die)))
1451 (define (die-attrs die)
1452 (abbrev-attrs (die-abbrev die)))
1454 (define (die-forms die)
1455 (abbrev-forms (die-abbrev die)))
1457 (define (die-vals die)
1458 (let ((vals (%die-vals die)))
1461 (%set-die-vals! die (read-values (die-ctx die) (skip-leb128 (die-ctx die) (die-offset die)) (die-abbrev die)))
1464 (define* (die-next-offset die #:optional offset-vals)
1465 (let ((ctx (die-ctx die)))
1466 (skip-values ctx (or offset-vals (skip-leb128 ctx (die-offset die)))
1469 (define* (die-ref die attr #:optional default)
1471 ((list-index (die-attrs die) attr)
1472 => (lambda (n) (list-ref (die-vals die) n)))
1475 (define (die-specification die)
1476 (and=> (die-ref die 'specification)
1477 (lambda (offset) (find-die-by-offset (die-ctx die) offset))))
1479 (define (die-name die)
1480 (or (die-ref die 'name)
1481 (and=> (die-specification die) die-name)))
1483 (define (die-qname die)
1485 ((eq? (die-tag die) 'compile-unit) "")
1486 ((die-ref die 'name)
1488 (if (eq? (die-tag (ctx-die (die-ctx die))) 'compile-unit)
1490 (string-append (die-qname (ctx-die (die-ctx die))) "::" name))))
1491 ((die-specification die)
1495 (define (die-line-prog die)
1496 (let ((stmt-list (die-ref die 'stmt-list)))
1498 (let* ((ctx (die-ctx die))
1499 (meta (ctx-meta ctx)))
1501 (+ (meta-line-start meta) stmt-list)
1502 (meta-line-end meta))))))
1504 (define (read-values ctx offset abbrev)
1505 (let lp ((attrs (abbrev-attrs abbrev))
1506 (forms (abbrev-forms abbrev))
1510 (values (reverse vals) pos)
1511 (let-values (((val pos) (read-value ctx pos (car forms))))
1512 (lp (cdr attrs) (cdr forms)
1513 (cons (parse-attribute ctx (car attrs) val) vals)
1516 (define (skip-values ctx offset abbrev)
1517 (let lp ((forms (abbrev-forms abbrev))
1521 (lp (cdr forms) (skip-value ctx pos (car forms))))))
1523 (define (read-die-abbrev ctx offset)
1524 (let*-values (((code pos) (read-uleb128 ctx offset)))
1525 (values (cond ((zero? code) #f)
1526 ((vector-ref (ctx-abbrevs ctx) code))
1527 (else (error "unknown abbrev" ctx code)))
1530 (define (read-die ctx offset)
1531 (let*-values (((abbrev pos) (read-die-abbrev ctx offset)))
1533 (values (make-die ctx offset abbrev #f)
1534 (skip-values ctx pos abbrev))
1537 (define* (die-sibling ctx abbrev offset #:optional offset-vals offset-end)
1539 ((not (abbrev-has-children? abbrev))
1542 (or offset-vals (skip-leb128 ctx offset))
1544 ((memq 'sibling (abbrev-attrs abbrev))
1545 (let lp ((offset (or offset-vals (skip-leb128 ctx offset)))
1546 (attrs (abbrev-attrs abbrev))
1547 (forms (abbrev-forms abbrev)))
1548 (if (eq? (car attrs) 'sibling)
1549 (read-value ctx offset (car forms))
1550 (lp (skip-value ctx offset (car forms))
1551 (cdr attrs) (cdr forms)))))
1559 (skip-leb128 ctx offset))
1561 (lambda (ctx offset abbrev) #t)
1567 (define (find-die-context ctx offset)
1569 (error "failed to find DIE by context" offset))
1570 (define (in-context? ctx)
1571 (and (<= (ctx-start ctx) offset)
1572 (< offset (ctx-end ctx))))
1573 (define (find-root ctx)
1574 (if (in-context? ctx)
1576 (find-root (or (ctx-parent ctx) (not-found)))))
1577 (define (find-leaf ctx)
1578 (let lp ((kids (ctx-children ctx)))
1581 (if (in-context? (car kids))
1582 (find-leaf (car kids))
1584 (find-leaf (find-root ctx)))
1586 (define (find-die-by-offset ctx offset)
1587 (or (read-die (find-die-context ctx offset) offset)
1588 (error "Failed to read DIE at offset" offset)))
1590 (define-syntax-rule (let/ec k e e* ...)
1591 (let ((tag (make-prompt-tag)))
1595 (let ((k (lambda args (apply abort-to-prompt tag args))))
1597 (lambda (_ res) res))))
1599 (define* (find-die roots pred #:key
1600 (skip? (lambda (ctx offset abbrev) #f))
1601 (recurse? (lambda (die) #t)))
1603 (define (visit-die die)
1608 (fold-die-children die (lambda (die seed) (visit-die die)) #f
1611 (for-each visit-die roots)
1614 (define (die-low-pc die)
1615 (die-ref die 'low-pc))
1616 (define (die-high-pc die)
1617 (let ((val (die-ref die 'high-pc)))
1619 (let ((idx (list-index (die-attrs die) 'high-pc)))
1620 (case (list-ref (die-forms die) idx)
1622 (else (+ val (die-low-pc die))))))))
1624 (define (find-die-by-pc roots pc)
1625 ;; The result will be a subprogram.
1626 (define (skip? ctx offset abbrev)
1627 (case (abbrev-tag abbrev)
1628 ((subprogram compile-unit) #f)
1630 (define (recurse? die)
1633 (not (or (and=> (die-low-pc die)
1634 (lambda (low) (< pc low)))
1635 (and=> (die-high-pc die)
1636 (lambda (high) (<= high pc))))))
1640 (and (eq? (die-tag die) 'subprogram)
1641 (equal? (die-low-pc die) pc)))
1642 #:skip? skip? #:recurse? recurse?))
1644 (define (fold-die-list ctx offset skip? proc seed)
1645 (let ((ctx (find-die-context ctx offset)))
1646 (let lp ((offset offset) (seed seed))
1647 (let-values (((abbrev pos) (read-die-abbrev ctx offset)))
1649 ((not abbrev) (values seed pos))
1650 ((skip? ctx offset abbrev)
1651 (lp (die-sibling ctx abbrev offset pos) seed))
1653 (let-values (((vals pos) (read-values ctx pos abbrev)))
1654 (let* ((die (make-die ctx offset abbrev vals))
1655 (seed (proc die seed)))
1656 (lp (die-sibling ctx abbrev offset #f pos) seed)))))))))
1658 (define* (fold-die-children die proc seed #:key
1659 (skip? (lambda (ctx offset abbrev) #f)))
1660 (if (abbrev-has-children? (die-abbrev die))
1661 (values (fold-die-list (die-ctx die) (die-next-offset die)
1665 (define (die-children die)
1666 (reverse (fold-die-children die cons '())))
1668 (define (add-to-parent! ctx)
1669 (let ((parent (ctx-parent ctx)))
1670 (set-children! parent
1671 (append (ctx-children parent) (list ctx)))
1674 (define (make-compilation-unit-context ctx offset-size addr-size
1676 (unless (= addr-size (ctx-addr-size ctx))
1677 (error "ELF word size not equal to compilation unit addrsize"))
1679 (make-dwarf-context (ctx-bv ctx)
1680 offset-size (ctx-endianness ctx)
1682 abbrevs ctx #f start (+ start 4 len) '())))
1684 (define (make-child-context die)
1685 (let ((ctx (die-ctx die)))
1687 (make-dwarf-context (ctx-bv ctx)
1688 (ctx-offset-size ctx) (ctx-endianness ctx)
1692 (die-next-offset die)
1693 (die-sibling ctx (die-abbrev die) (die-offset die))
1696 (define (ctx-language ctx)
1697 (or (and=> (ctx-die ctx) (lambda (x) (die-ref x 'language)))
1698 (and=> (ctx-parent ctx) ctx-language)))
1700 (define (populate-context-tree! die)
1701 (define (skip? ctx offset abbrev)
1702 (case (abbrev-tag abbrev)
1703 ((class-type structure-type namespace) #f)
1706 ((compile-unit class-type structure-type namespace)
1707 (let ((ctx (make-child-context die)))
1708 ;; For C++, descend into classes and structures so that we
1709 ;; populate the context tree. Note that for compile-unit, we
1710 ;; still need to call `make-child-context' for its side effect of
1711 ;; adding to the context tree.
1712 (when (eq? (ctx-language ctx) 'c++)
1713 (fold-die-children die
1714 (lambda (die seed) (populate-context-tree! die))
1718 (define (read-compilation-unit ctx pos)
1719 (let*-values (((start) pos)
1720 ((len pos offset-size) (read-initial-length ctx pos))
1721 ((version pos) (read-u16 ctx pos))
1722 ((abbrevs-offset pos) (read-offset ctx pos offset-size))
1723 ((av) (read-abbrevs ctx abbrevs-offset))
1724 ((addrsize pos) (read-u8 ctx pos))
1725 ((ctx) (make-compilation-unit-context ctx offset-size addrsize
1727 ((die pos) (read-die ctx pos)))
1728 (populate-context-tree! die)
1729 (values die (ctx-end ctx))))
1731 (define (read-die-roots ctx)
1732 (let lp ((dies '()) (pos (meta-info-start (ctx-meta ctx))))
1733 (if (< pos (meta-info-end (ctx-meta ctx)))
1734 (let-values (((die pos) (read-compilation-unit ctx pos)))
1736 (lp (cons die dies) pos)
1740 (define (fold-pubname-set ctx pos folder seed)
1741 (let*-values (((len pos offset-size) (read-initial-length ctx pos))
1742 ((version pos) (read-u16 ctx pos))
1743 ((info-offset pos) (read-offset ctx pos offset-size))
1744 ((info-offset) (+ info-offset
1745 (meta-info-start (ctx-meta ctx))))
1746 ((info-len pos) (read-offset ctx pos offset-size)))
1747 (let lp ((pos pos) (seed seed))
1748 (let-values (((offset pos) (read-offset ctx pos offset-size)))
1751 (let-values (((str pos) (read-string ctx pos)))
1753 (folder str (+ offset info-offset) seed))))))))
1755 (define (fold-pubnames ctx folder seed)
1756 (let ((end (meta-pubnames-end (ctx-meta ctx))))
1758 (let lp ((pos (meta-pubnames-start (ctx-meta ctx))) (seed seed))
1760 (let-values (((seed pos) (fold-pubname-set ctx pos folder seed)))
1765 (define (align address alignment)
1767 (modulo (- alignment (modulo address alignment)) alignment)))
1769 (define (fold-arange-set ctx pos folder seed)
1770 (let*-values (((len pos offset-size) (read-initial-length ctx pos))
1771 ((version pos) (read-u16 ctx pos))
1772 ((info-offset pos) (read-offset ctx pos offset-size))
1773 ((info-offset) (+ info-offset
1774 (meta-info-start (ctx-meta ctx))))
1775 ((addr-size pos) (read-u8 ctx pos))
1776 ((segment-size pos) (read-u8 ctx pos)))
1777 (let lp ((pos (align pos (* 2 (ctx-addr-size ctx)))) (seed seed))
1778 (let*-values (((addr pos) (read-addr ctx pos))
1779 ((len pos) (read-addr ctx pos)))
1780 (if (and (zero? addr) (zero? len))
1783 (folder info-offset addr len seed)))))))
1785 (define (fold-aranges ctx folder seed)
1786 (let ((end (meta-aranges-end (ctx-meta ctx))))
1788 (let lp ((pos (meta-aranges-start (ctx-meta ctx))) (seed seed))
1790 (let-values (((seed pos) (fold-arange-set ctx pos folder seed)))
1795 (define* (elf->dwarf-context elf #:key (vaddr 0) (memsz 0)
1796 (path #f) (lib-path path))
1797 (let* ((sections (elf-sections-by-name elf))
1798 (info (assoc-ref sections ".debug_info"))
1799 (abbrevs (assoc-ref sections ".debug_abbrev"))
1800 (strtab (assoc-ref sections ".debug_str"))
1801 (loc (assoc-ref sections ".debug_loc"))
1802 (line (assoc-ref sections ".debug_line"))
1803 (pubnames (assoc-ref sections ".debug_pubnames"))
1804 (aranges (assoc-ref sections ".debug_aranges")))
1805 (make-dwarf-context (elf-bytes elf)
1806 4 ;; initial offset size
1807 (elf-byte-order elf)
1812 (elf-section-offset info)
1813 (+ (elf-section-offset info)
1814 (elf-section-size info))
1815 (elf-section-offset abbrevs)
1816 (+ (elf-section-offset abbrevs)
1817 (elf-section-size abbrevs))
1818 (elf-section-offset strtab)
1819 (+ (elf-section-offset strtab)
1820 (elf-section-size strtab))
1821 (elf-section-offset loc)
1822 (+ (elf-section-offset loc)
1823 (elf-section-size loc))
1825 (elf-section-offset line))
1827 (+ (elf-section-offset line)
1828 (elf-section-size line)))
1830 (elf-section-offset pubnames))
1832 (+ (elf-section-offset pubnames)
1833 (elf-section-size pubnames)))
1835 (elf-section-offset aranges))
1837 (+ (elf-section-offset aranges)
1838 (elf-section-size aranges))))
1840 (elf-section-offset info)
1841 (+ (elf-section-offset info)
1842 (elf-section-size info))
1845 (define (die->tree die)
1846 (cons* (die-tag die)
1847 (cons 'offset (die-offset die))
1848 (reverse! (fold-die-children
1851 (cons (die->tree die) seed))
1852 (fold acons '() (die-attrs die) (die-vals die))))))
HCoop / bpt / guile.git / blob