Commit | Line | Data |
---|---|---|
35558f75 AW |
1 | ;;; Guile DWARF reader and writer |
2 | ||
3 | ;; Copyright (C) 2012, 2013 Free Software Foundation, Inc. | |
4 | ||
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: | |
8 | ;; | |
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). | |
13 | ||
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. | |
18 | ;;;; | |
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. | |
23 | ;;;; | |
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 | |
27 | ||
28 | ;;; Commentary: | |
29 | ;; | |
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. | |
33 | ;; | |
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! | |
38 | ;; | |
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 | |
691697de | 41 | ;; the ELF file (.rtl-text, .data, etc.). |
35558f75 AW |
42 | ;; |
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". | |
48 | ;; | |
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. | |
59 | ;; | |
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/. | |
64 | ;; | |
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. | |
69 | ;; | |
70 | ;;; Code: | |
71 | ||
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 | |
82 | read-die-roots | |
83 | fold-pubnames fold-aranges | |
84 | ||
85 | access-name->code | |
86 | address-name->code | |
87 | attribute-name->code | |
88 | call-frame-address-name->code | |
89 | children-name->code | |
90 | convention-name->code | |
91 | discriminant-name->code | |
92 | form-name->code | |
93 | inline-name->code | |
94 | language-name->code | |
95 | macro-name->code | |
96 | ordering-name->code | |
97 | sensitivity-name->code | |
98 | tag-name->code | |
99 | virtuality-name->code | |
100 | visibility-name->code | |
101 | ||
102 | abbrev? abbrev-code | |
103 | abbrev-tag abbrev-has-children? abbrev-attrs abbrev-forms | |
104 | ||
105 | die? die-ctx die-offset die-abbrev die-vals die-children | |
106 | die-tag die-attrs die-forms die-ref | |
1ed81e02 | 107 | die-name die-specification die-qname die-low-pc die-high-pc |
35558f75 AW |
108 | |
109 | ctx-parent ctx-die ctx-start ctx-end ctx-children ctx-language | |
110 | ||
1ed81e02 AW |
111 | die-line-prog line-prog-advance line-prog-scan-to-pc |
112 | ||
35558f75 AW |
113 | find-die-context find-die-by-offset find-die find-die-by-pc |
114 | read-die fold-die-list | |
115 | ||
116 | fold-die-children die->tree)) | |
117 | ||
118 | ;;; | |
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 | |
122 | ;;; header in glibc. | |
123 | ;;; | |
124 | ||
125 | (define-syntax-rule (define-enumeration code->name name->code | |
126 | (tag value) ...) | |
127 | (begin | |
128 | (define code->name | |
129 | (let ((table (make-hash-table))) | |
130 | (hashv-set! table value 'tag) | |
131 | ... | |
132 | (lambda (v) | |
133 | (hashv-ref table v v)))) | |
134 | (define name->code | |
135 | (let ((table (make-hash-table))) | |
136 | (hashv-set! table 'tag value) | |
137 | ... | |
138 | (lambda (v) | |
139 | (hashv-ref table v v)))))) | |
140 | ||
141 | ;; Figures 14 and 15: Tag names and codes. | |
142 | ;; | |
143 | (define-enumeration tag-code->name tag-name->code | |
144 | (padding #x00) | |
145 | (array-type #x01) | |
146 | (class-type #x02) | |
147 | (entry-point #x03) | |
148 | (enumeration-type #x04) | |
149 | (formal-parameter #x05) | |
150 | (imported-declaration #x08) | |
151 | (label #x0a) | |
152 | (lexical-block #x0b) | |
153 | (member #x0d) | |
154 | (pointer-type #x0f) | |
155 | (reference-type #x10) | |
156 | (compile-unit #x11) | |
157 | (string-type #x12) | |
158 | (structure-type #x13) | |
159 | (subroutine-type #x15) | |
160 | (typedef #x16) | |
161 | (union-type #x17) | |
162 | (unspecified-parameters #x18) | |
163 | (variant #x19) | |
164 | (common-block #x1a) | |
165 | (common-inclusion #x1b) | |
166 | (inheritance #x1c) | |
167 | (inlined-subroutine #x1d) | |
168 | (module #x1e) | |
169 | (ptr-to-member-type #x1f) | |
170 | (set-type #x20) | |
171 | (subrange-type #x21) | |
172 | (with-stmt #x22) | |
173 | (access-declaration #x23) | |
174 | (base-type #x24) | |
175 | (catch-block #x25) | |
176 | (const-type #x26) | |
177 | (constant #x27) | |
178 | (enumerator #x28) | |
179 | (file-type #x29) | |
180 | (friend #x2a) | |
181 | (namelist #x2b) | |
182 | (namelist-item #x2c) | |
183 | (packed-type #x2d) | |
184 | (subprogram #x2e) | |
185 | (template-type-param #x2f) | |
186 | (template-value-param #x30) | |
187 | (thrown-type #x31) | |
188 | (try-block #x32) | |
189 | (variant-part #x33) | |
190 | (variable #x34) | |
191 | (volatile-type #x35) | |
192 | ;; DWARF 3. | |
193 | (dwarf-procedure #x36) | |
194 | (restrict-type #x37) | |
195 | (interface-type #x38) | |
196 | (namespace #x39) | |
197 | (imported-module #x3a) | |
198 | (unspecified-type #x3b) | |
199 | (partial-unit #x3c) | |
200 | (imported-unit #x3d) | |
201 | (condition #x3f) | |
202 | (shared-type #x40) | |
203 | ;; Extensions. | |
204 | (format-label #x4101) | |
205 | (function-template #x4102) | |
206 | (class-template #x4103) | |
207 | (GNU-BINCL #x4104) | |
208 | (GNU-EINCL #x4105) | |
209 | (lo-user #x4080) | |
210 | (hi-user #xffff)) | |
211 | ||
212 | ;; Figure 16: Flag that tells whether entry has a child or not. | |
213 | ;; | |
214 | (define-enumeration children-code->name children-name->code | |
215 | (no 0) | |
216 | (yes 1)) | |
217 | ||
218 | ;; Figures 17 and 18: Attribute names and codes. | |
219 | ;; | |
220 | (define-enumeration attribute-code->name attribute-name->code | |
221 | (sibling #x01) | |
222 | (location #x02) | |
223 | (name #x03) | |
224 | (ordering #x09) | |
225 | (subscr-data #x0a) | |
226 | (byte-size #x0b) | |
227 | (bit-offset #x0c) | |
228 | (bit-size #x0d) | |
229 | (element-list #x0f) | |
230 | (stmt-list #x10) | |
231 | (low-pc #x11) | |
232 | (high-pc #x12) | |
233 | (language #x13) | |
234 | (member #x14) | |
235 | (discr #x15) | |
236 | (discr-value #x16) | |
237 | (visibility #x17) | |
238 | (import #x18) | |
239 | (string-length #x19) | |
240 | (common-reference #x1a) | |
241 | (comp-dir #x1b) | |
242 | (const-value #x1c) | |
243 | (containing-type #x1d) | |
244 | (default-value #x1e) | |
245 | (inline #x20) | |
246 | (is-optional #x21) | |
247 | (lower-bound #x22) | |
248 | (producer #x25) | |
249 | (prototyped #x27) | |
250 | (return-addr #x2a) | |
251 | (start-scope #x2c) | |
252 | (stride-size #x2e) | |
253 | (upper-bound #x2f) | |
254 | (abstract-origin #x31) | |
255 | (accessibility #x32) | |
256 | (address-class #x33) | |
257 | (artificial #x34) | |
258 | (base-types #x35) | |
259 | (calling-convention #x36) | |
260 | (count #x37) | |
261 | (data-member-location #x38) | |
262 | (decl-column #x39) | |
263 | (decl-file #x3a) | |
264 | (decl-line #x3b) | |
265 | (declaration #x3c) | |
266 | (discr-list #x3d) | |
267 | (encoding #x3e) | |
268 | (external #x3f) | |
269 | (frame-base #x40) | |
270 | (friend #x41) | |
271 | (identifier-case #x42) | |
272 | (macro-info #x43) | |
273 | (namelist-items #x44) | |
274 | (priority #x45) | |
275 | (segment #x46) | |
276 | (specification #x47) | |
277 | (static-link #x48) | |
278 | (type #x49) | |
279 | (use-location #x4a) | |
280 | (variable-parameter #x4b) | |
281 | (virtuality #x4c) | |
282 | (vtable-elem-location #x4d) | |
283 | ;; DWARF 3. | |
284 | (associated #x4f) | |
285 | (data-location #x50) | |
286 | (byte-stride #x51) | |
287 | (entry-pc #x52) | |
288 | (use-UTF8 #x53) | |
289 | (extension #x54) | |
290 | (ranges #x55) | |
291 | (trampoline #x56) | |
292 | (call-column #x57) | |
293 | (call-file #x58) | |
294 | (call-line #x59) | |
295 | (description #x5a) | |
296 | (binary-scale #x5b) | |
297 | (decimal-scale #x5c) | |
298 | (small #x5d) | |
299 | (decimal-sign #x5e) | |
300 | (digit-count #x5f) | |
301 | (picture-string #x60) | |
302 | (mutable #x61) | |
303 | (threads-scaled #x62) | |
304 | (explicit #x63) | |
305 | (object-pointer #x64) | |
306 | (endianity #x65) | |
307 | (elemental #x66) | |
308 | (pure #x67) | |
309 | (recursive #x68) | |
310 | ;; Extensions. | |
311 | (linkage-name #x2007) | |
312 | (sf-names #x2101) | |
313 | (src-info #x2102) | |
314 | (mac-info #x2103) | |
315 | (src-coords #x2104) | |
316 | (body-begin #x2105) | |
317 | (body-end #x2106) | |
318 | (lo-user #x2000) | |
319 | (hi-user #x3fff)) | |
320 | ||
321 | ;; Figure 19: Form names and codes. | |
322 | ;; | |
323 | (define-enumeration form-code->name form-name->code | |
324 | (addr #x01) | |
325 | (block2 #x03) | |
326 | (block4 #x04) | |
327 | (data2 #x05) | |
328 | (data4 #x06) | |
329 | (data8 #x07) | |
330 | (string #x08) | |
331 | (block #x09) | |
332 | (block1 #x0a) | |
333 | (data1 #x0b) | |
334 | (flag #x0c) | |
335 | (sdata #x0d) | |
336 | (strp #x0e) | |
337 | (udata #x0f) | |
338 | (ref-addr #x10) | |
339 | (ref1 #x11) | |
340 | (ref2 #x12) | |
341 | (ref4 #x13) | |
342 | (ref8 #x14) | |
343 | (ref-udata #x15) | |
344 | (indirect #x16) | |
345 | (sec-offset #x17) | |
346 | (exprloc #x18) | |
347 | (flag-present #x19) | |
348 | (ref-sig8 #x20)) | |
349 | ||
350 | ;; Figures 22 and 23: Location atom names and codes. | |
351 | ;; | |
352 | (define-enumeration location-op->name location-name->op | |
353 | (addr #x03) | |
354 | (deref #x06) | |
355 | (const1u #x08) | |
356 | (const1s #x09) | |
357 | (const2u #x0a) | |
358 | (const2s #x0b) | |
359 | (const4u #x0c) | |
360 | (const4s #x0d) | |
361 | (const8u #x0e) | |
362 | (const8s #x0f) | |
363 | (constu #x10) | |
364 | (consts #x11) | |
365 | (dup #x12) | |
366 | (drop #x13) | |
367 | (over #x14) | |
368 | (pick #x15) | |
369 | (swap #x16) | |
370 | (rot #x17) | |
371 | (xderef #x18) | |
372 | (abs #x19) | |
373 | (and #x1a) | |
374 | (div #x1b) | |
375 | (minus #x1c) | |
376 | (mod #x1d) | |
377 | (mul #x1e) | |
378 | (neg #x1f) | |
379 | (not #x20) | |
380 | (or #x21) | |
381 | (plus #x22) | |
382 | (plus-uconst #x23) | |
383 | (shl #x24) | |
384 | (shr #x25) | |
385 | (shra #x26) | |
386 | (xor #x27) | |
387 | (bra #x28) | |
388 | (eq #x29) | |
389 | (ge #x2a) | |
390 | (gt #x2b) | |
391 | (le #x2c) | |
392 | (lt #x2d) | |
393 | (ne #x2e) | |
394 | (skip #x2f) | |
395 | (lit0 #x30) | |
396 | (lit1 #x31) | |
397 | (lit2 #x32) | |
398 | (lit3 #x33) | |
399 | (lit4 #x34) | |
400 | (lit5 #x35) | |
401 | (lit6 #x36) | |
402 | (lit7 #x37) | |
403 | (lit8 #x38) | |
404 | (lit9 #x39) | |
405 | (lit10 #x3a) | |
406 | (lit11 #x3b) | |
407 | (lit12 #x3c) | |
408 | (lit13 #x3d) | |
409 | (lit14 #x3e) | |
410 | (lit15 #x3f) | |
411 | (lit16 #x40) | |
412 | (lit17 #x41) | |
413 | (lit18 #x42) | |
414 | (lit19 #x43) | |
415 | (lit20 #x44) | |
416 | (lit21 #x45) | |
417 | (lit22 #x46) | |
418 | (lit23 #x47) | |
419 | (lit24 #x48) | |
420 | (lit25 #x49) | |
421 | (lit26 #x4a) | |
422 | (lit27 #x4b) | |
423 | (lit28 #x4c) | |
424 | (lit29 #x4d) | |
425 | (lit30 #x4e) | |
426 | (lit31 #x4f) | |
427 | (reg0 #x50) | |
428 | (reg1 #x51) | |
429 | (reg2 #x52) | |
430 | (reg3 #x53) | |
431 | (reg4 #x54) | |
432 | (reg5 #x55) | |
433 | (reg6 #x56) | |
434 | (reg7 #x57) | |
435 | (reg8 #x58) | |
436 | (reg9 #x59) | |
437 | (reg10 #x5a) | |
438 | (reg11 #x5b) | |
439 | (reg12 #x5c) | |
440 | (reg13 #x5d) | |
441 | (reg14 #x5e) | |
442 | (reg15 #x5f) | |
443 | (reg16 #x60) | |
444 | (reg17 #x61) | |
445 | (reg18 #x62) | |
446 | (reg19 #x63) | |
447 | (reg20 #x64) | |
448 | (reg21 #x65) | |
449 | (reg22 #x66) | |
450 | (reg23 #x67) | |
451 | (reg24 #x68) | |
452 | (reg25 #x69) | |
453 | (reg26 #x6a) | |
454 | (reg27 #x6b) | |
455 | (reg28 #x6c) | |
456 | (reg29 #x6d) | |
457 | (reg30 #x6e) | |
458 | (reg31 #x6f) | |
459 | (breg0 #x70) | |
460 | (breg1 #x71) | |
461 | (breg2 #x72) | |
462 | (breg3 #x73) | |
463 | (breg4 #x74) | |
464 | (breg5 #x75) | |
465 | (breg6 #x76) | |
466 | (breg7 #x77) | |
467 | (breg8 #x78) | |
468 | (breg9 #x79) | |
469 | (breg10 #x7a) | |
470 | (breg11 #x7b) | |
471 | (breg12 #x7c) | |
472 | (breg13 #x7d) | |
473 | (breg14 #x7e) | |
474 | (breg15 #x7f) | |
475 | (breg16 #x80) | |
476 | (breg17 #x81) | |
477 | (breg18 #x82) | |
478 | (breg19 #x83) | |
479 | (breg20 #x84) | |
480 | (breg21 #x85) | |
481 | (breg22 #x86) | |
482 | (breg23 #x87) | |
483 | (breg24 #x88) | |
484 | (breg25 #x89) | |
485 | (breg26 #x8a) | |
486 | (breg27 #x8b) | |
487 | (breg28 #x8c) | |
488 | (breg29 #x8d) | |
489 | (breg30 #x8e) | |
490 | (breg31 #x8f) | |
491 | (regx #x90) | |
492 | (fbreg #x91) | |
493 | (bregx #x92) | |
494 | (piece #x93) | |
495 | (deref-size #x94) | |
496 | (xderef-size #x95) | |
497 | (nop #x96) | |
498 | ;; DWARF 3. | |
499 | (push-object-address #x97) | |
500 | (call2 #x98) | |
501 | (call4 #x99) | |
502 | (call-ref #x9a) | |
503 | (form-tls-address #x9b) | |
504 | (call-frame-cfa #x9c) | |
505 | (bit-piece #x9d) | |
506 | (lo-user #x80) | |
507 | (hi-user #xff)) | |
508 | ||
509 | ;; Figure 24: Type encodings. | |
510 | ;; | |
511 | (define-enumeration type-encoding->name type-name->encoding | |
512 | (void #x0) | |
513 | (address #x1) | |
514 | (boolean #x2) | |
515 | (complex-float #x3) | |
516 | (float #x4) | |
517 | (signed #x5) | |
518 | (signed-char #x6) | |
519 | (unsigned #x7) | |
520 | (unsigned-char #x8) | |
521 | ;; DWARF 3. | |
522 | (imaginary-float #x09) | |
523 | (packed-decimal #x0a) | |
524 | (numeric-string #x0b) | |
525 | (edited #x0c) | |
526 | (signed-fixed #x0d) | |
527 | (unsigned-fixed #x0e) | |
528 | (decimal-float #x0f) | |
529 | (lo-user #x80) | |
530 | (hi-user #xff)) | |
531 | ||
532 | ;; Figure 25: Access attribute. | |
533 | ;; | |
534 | (define-enumeration access-code->name access-name->code | |
535 | (public 1) | |
536 | (protected 2) | |
537 | (private 3)) | |
538 | ||
539 | ;; Figure 26: Visibility. | |
540 | ;; | |
541 | (define-enumeration visibility-code->name visibility-name->code | |
542 | (local 1) | |
543 | (exported 2) | |
544 | (qualified 3)) | |
545 | ||
546 | ;; Figure 27: Virtuality. | |
547 | ;; | |
548 | (define-enumeration virtuality-code->name virtuality-name->code | |
549 | (none 0) | |
550 | (virtual 1) | |
551 | (pure-virtual 2)) | |
552 | ||
553 | ;; Figure 28: Source language names and codes. | |
554 | ;; | |
555 | (define-enumeration language-code->name language-name->code | |
556 | (c89 #x0001) | |
557 | (c #x0002) | |
558 | (ada83 #x0003) | |
559 | (c++ #x0004) | |
560 | (cobol74 #x0005) | |
561 | (cobol85 #x0006) | |
562 | (fortran77 #x0007) | |
563 | (fortran90 #x0008) | |
564 | (pascal83 #x0009) | |
565 | (modula2 #x000a) | |
566 | (java #x000b) | |
567 | (c99 #x000c) | |
568 | (ada95 #x000d) | |
569 | (fortran95 #x000e) | |
570 | (pli #x000f) | |
571 | (objc #x0010) | |
572 | (objc++ #x0011) | |
573 | (upc #x0012) | |
574 | (d #x0013) | |
575 | (python #x0014) | |
576 | (mips-assembler #x8001) | |
577 | ||
578 | (lo-user #x8000) | |
579 | ||
580 | ;; FIXME: Ask for proper codes for these. | |
581 | (scheme #xaf33) | |
582 | (emacs-lisp #xaf34) | |
583 | (ecmascript #xaf35) | |
584 | (lua #xaf36) | |
585 | (brainfuck #xaf37) | |
586 | ||
587 | (hi-user #xffff)) | |
588 | ||
589 | ;; Figure 29: Case sensitivity. | |
590 | ;; | |
591 | (define-enumeration case-sensitivity-code->name case-sensitivity-name->code | |
592 | (case-sensitive 0) | |
593 | (up-case 1) | |
594 | (down-case 2) | |
595 | (case-insensitive 3)) | |
596 | ||
597 | ;; Figure 30: Calling convention. | |
598 | ;; | |
599 | (define-enumeration calling-convention-code->name calling-convention-name->code | |
600 | (normal #x1) | |
601 | (program #x2) | |
602 | (nocall #x3) | |
603 | (lo-user #x40) | |
604 | (hi-user #xff)) | |
605 | ||
606 | ;; Figure 31: Inline attribute. | |
607 | ;; | |
608 | (define-enumeration inline-code->name inline-name->code | |
609 | (not-inlined 0) | |
610 | (inlined 1) | |
611 | (declared-not-inlined 2) | |
612 | (declared-inlined 3)) | |
613 | ||
614 | ;; Figure 32: Array ordering names and codes. | |
615 | (define-enumeration ordering-code->name ordering-name->code | |
616 | (row-major 0) | |
617 | (col-major 1)) | |
618 | ||
619 | ;; Figure 33: Discriminant lists. | |
620 | ;; | |
621 | (define-enumeration discriminant-code->name discriminant-name->code | |
622 | (label 0) | |
623 | (range 1)) | |
624 | ||
625 | ;; Figure 34: "Standard" line number opcodes. | |
626 | ;; | |
627 | (define-enumeration standard-line-opcode->name standard-line-name->opcode | |
628 | (extended-op 0) | |
629 | (copy 1) | |
630 | (advance-pc 2) | |
631 | (advance-line 3) | |
632 | (set-file 4) | |
633 | (set-column 5) | |
634 | (negate-stmt 6) | |
635 | (set-basic-block 7) | |
636 | (const-add-pc 8) | |
637 | (fixed-advance-pc 9) | |
638 | ;; DWARF 3. | |
639 | (set-prologue-end #x0a) | |
640 | (set-epilogue-begin #x0b) | |
641 | (set-isa #x0c)) | |
642 | ||
643 | ;; Figure 35: "Extended" line number opcodes. | |
644 | ;; | |
645 | (define-enumeration extended-line-opcode->name extended-line-name->opcode | |
646 | (end-sequence 1) | |
647 | (set-address 2) | |
648 | (define-file 3) | |
649 | ;; DWARF 3. | |
650 | (lo-user #x80) | |
651 | (hi-user #xff)) | |
652 | ||
653 | ;; Figure 36: Names and codes for macro information. | |
654 | ;; | |
655 | (define-enumeration macro-code->name macro-name->code | |
656 | (define 1) | |
657 | (undef 2) | |
658 | (start-file 3) | |
659 | (end-file 4) | |
660 | (vendor-ext 255)) | |
661 | ||
662 | ;; Figure 37: Call frame information. | |
663 | ;; | |
664 | (define-enumeration call-frame-address-code->name call-frame-address-code->name | |
665 | (advance-loc #x40) | |
666 | (offset #x80) | |
667 | (restore #xc0) | |
668 | (nop #x00) | |
669 | (set-loc #x01) | |
670 | (advance-loc1 #x02) | |
671 | (advance-loc2 #x03) | |
672 | (advance-loc4 #x04) | |
673 | (offset-extended #x05) | |
674 | (restore-extended #x06) | |
675 | (undefined #x07) | |
676 | (same-value #x08) | |
677 | (register #x09) | |
678 | (remember-state #x0a) | |
679 | (restore-state #x0b) | |
680 | (def-cfa #x0c) | |
681 | (def-cfa-register #x0d) | |
682 | (def-cfa-offset #x0e) | |
683 | ;; DWARF 3. | |
684 | (def-cfa-expression #x0f) | |
685 | (expression #x10) | |
686 | (offset-extended-sf #x11) | |
687 | (def-cfa-sf #x12) | |
688 | (def-cfa-offset-sf #x13) | |
689 | (val-offset #x14) | |
690 | (val-offset-sf #x15) | |
691 | (val-expression #x16) | |
692 | (GNU-window-save #x2d) | |
693 | (GNU-args-size #x2e) | |
694 | (GNU-negative-offset-extended #x2f) | |
695 | ||
696 | (extended 0) | |
697 | (low-user #x1c) | |
698 | (high-user #x3f)) | |
699 | ||
700 | ;(define CIE-ID #xffffffff) | |
701 | ;(define CIE-VERSION 1) | |
702 | ;(define ADDR-none 0) | |
703 | ||
704 | ||
705 | ;;; | |
706 | ;;; A general configuration object. | |
707 | ;;; | |
708 | ||
709 | (define-record-type <dwarf-meta> | |
710 | (make-dwarf-meta addr-size | |
711 | vaddr memsz | |
712 | path lib-path | |
713 | info-start info-end | |
714 | abbrevs-start abbrevs-end | |
715 | strtab-start strtab-end | |
716 | loc-start loc-end | |
1ed81e02 | 717 | line-start line-end |
35558f75 AW |
718 | pubnames-start pubnames-end |
719 | aranges-start aranges-end) | |
720 | dwarf-meta? | |
721 | (addr-size meta-addr-size) | |
722 | (vaddr meta-vaddr) | |
723 | (memsz meta-memsz) | |
724 | (path meta-path) | |
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) | |
1ed81e02 AW |
734 | (line-start meta-line-start) |
735 | (line-end meta-line-end) | |
35558f75 AW |
736 | (pubnames-start meta-pubnames-start) |
737 | (pubnames-end meta-pubnames-end) | |
738 | (aranges-start meta-aranges-start) | |
739 | (aranges-end meta-aranges-end)) | |
740 | ||
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. | |
744 | ;; | |
745 | (define-record-type <dwarf-context> | |
746 | (make-dwarf-context bv offset-size endianness meta | |
747 | abbrevs | |
748 | parent die start end children) | |
749 | dwarf-context? | |
750 | (bv ctx-bv) | |
751 | (offset-size ctx-offset-size) | |
752 | (endianness ctx-endianness) | |
753 | (meta ctx-meta) | |
754 | (abbrevs ctx-abbrevs) | |
755 | (parent ctx-parent) | |
756 | (die ctx-die) | |
757 | (start ctx-start) | |
758 | (end ctx-end) | |
759 | (children ctx-children set-children!)) | |
760 | ||
761 | ||
762 | (set-record-type-printer! <dwarf-context> | |
763 | (lambda (x port) | |
764 | (format port "<dwarf-context ~a>" | |
765 | (number->string (object-address x) 16)))) | |
766 | ||
767 | (define-inlinable (ctx-addr-size ctx) | |
768 | (meta-addr-size (ctx-meta ctx))) | |
769 | ||
770 | ;;; | |
771 | ;;; Procedures for reading DWARF data. | |
772 | ;;; | |
773 | ||
774 | (define (read-u8 ctx pos) | |
775 | (values (bytevector-u8-ref (ctx-bv ctx) pos) | |
776 | (1+ pos))) | |
1ed81e02 AW |
777 | (define (read-s8 ctx pos) |
778 | (values (bytevector-s8-ref (ctx-bv ctx) pos) | |
779 | (1+ pos))) | |
35558f75 AW |
780 | (define (skip-8 ctx pos) |
781 | (+ pos 1)) | |
782 | ||
783 | (define (read-u16 ctx pos) | |
784 | (values (bytevector-u16-ref (ctx-bv ctx) pos (ctx-endianness ctx)) | |
785 | (+ pos 2))) | |
786 | (define (skip-16 ctx pos) | |
787 | (+ pos 2)) | |
788 | ||
789 | (define (read-u32 ctx pos) | |
790 | (values (bytevector-u32-ref (ctx-bv ctx) pos (ctx-endianness ctx)) | |
791 | (+ pos 4))) | |
792 | (define (skip-32 ctx pos) | |
793 | (+ pos 4)) | |
794 | ||
795 | (define (read-u64 ctx pos) | |
796 | (values (bytevector-u64-ref (ctx-bv ctx) pos (ctx-endianness ctx)) | |
797 | (+ pos 8))) | |
798 | (define (skip-64 ctx pos) | |
799 | (+ pos 8)) | |
800 | ||
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))) | |
808 | ||
809 | (define (%read-uleb128 bv pos) | |
810 | ;; Unrolled by one. | |
811 | (let ((b (bytevector-u8-ref bv pos))) | |
812 | (if (zero? (logand b #x80)) | |
813 | (values b | |
814 | (1+ pos)) | |
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) | |
819 | (1+ pos)) | |
820 | (lp (logior (ash (logxor #x80 b) shift) n) | |
821 | (1+ pos) | |
822 | (+ shift 7)))))))) | |
823 | ||
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)) | |
830 | 0 | |
831 | (- (ash 1 (+ shift 7))))) | |
832 | (1+ pos)) | |
833 | (lp (logior (ash (logxor #x80 b) shift) n) | |
834 | (1+ pos) | |
835 | (+ shift 7)))))) | |
836 | ||
837 | (define (read-uleb128 ctx pos) | |
838 | (%read-uleb128 (ctx-bv ctx) pos)) | |
839 | ||
840 | (define (read-sleb128 ctx pos) | |
841 | (%read-sleb128 (ctx-bv ctx) pos)) | |
842 | ||
843 | (define (skip-leb128 ctx pos) | |
844 | (let ((bv (ctx-bv ctx))) | |
845 | (let lp ((pos pos)) | |
846 | (let ((b (bytevector-u8-ref bv pos))) | |
847 | (if (zero? (logand b #x80)) | |
848 | (1+ pos) | |
849 | (lp (1+ pos))))))) | |
850 | ||
851 | (define (read-initial-length ctx pos) | |
852 | (let ((len (bytevector-u32-ref (ctx-bv ctx) pos (ctx-endianness ctx)))) | |
853 | (cond | |
854 | ((= len #xffffffff) | |
855 | (values (bytevector-u32-ref (ctx-bv ctx) (+ pos 4) (ctx-endianness ctx)) | |
856 | (+ pos 12) | |
857 | 8)) | |
858 | ((>= len #xfffffff0) | |
859 | (error "bad initial length value" len)) | |
860 | (else | |
861 | (values len | |
862 | (+ pos 4) | |
863 | 4))))) | |
864 | ||
865 | (define* (read-offset ctx pos #:optional (offset-size (ctx-offset-size ctx))) | |
866 | (case offset-size | |
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)))) | |
870 | ||
871 | (define* (skip-offset ctx pos #:optional (offset-size (ctx-offset-size ctx))) | |
872 | (+ pos offset-size)) | |
873 | ||
874 | (define (read-block ctx pos len) | |
875 | (let ((bv (make-bytevector len))) | |
876 | (bytevector-copy! (ctx-bv ctx) pos bv 0 len) | |
877 | (values bv | |
878 | (+ pos len)))) | |
879 | ||
880 | (define (read-string ctx pos) | |
881 | (let ((bv (ctx-bv ctx))) | |
882 | (let lp ((end pos)) | |
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) | |
887 | (1+ end))) | |
888 | (lp (1+ end)))))) | |
889 | ||
890 | (define (skip-string ctx pos) | |
891 | (let ((bv (ctx-bv ctx))) | |
892 | (let lp ((end pos)) | |
893 | (if (zero? (bytevector-u8-ref bv end)) | |
894 | (1+ end) | |
895 | (lp (1+ end)))))) | |
896 | ||
1ed81e02 AW |
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))))))) | |
904 | ||
35558f75 AW |
905 | (define-record-type <abbrev> |
906 | (make-abbrev code tag has-children? attrs forms) | |
907 | abbrev? | |
908 | (code abbrev-code) | |
909 | (tag abbrev-tag) | |
910 | (has-children? abbrev-has-children?) | |
911 | (attrs abbrev-attrs) | |
912 | (forms abbrev-forms)) | |
913 | ||
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 | |
923 | (tag-code->name tag) | |
924 | (eq? (children-code->name children) 'yes) | |
925 | (reverse attrs) | |
926 | (reverse forms)) | |
927 | pos) | |
928 | (lp (cons (attribute-code->name attr) attrs) | |
929 | (cons (form-code->name form) forms) | |
930 | pos)))))) | |
931 | ||
932 | (define* (read-abbrevs ctx pos | |
933 | #:optional (start (meta-abbrevs-start | |
934 | (ctx-meta ctx))) | |
935 | (end (meta-abbrevs-end | |
936 | (ctx-meta ctx)))) | |
937 | (let lp ((abbrevs '()) (pos (+ start pos)) (max-code -1)) | |
938 | (if (zero? (read-u8 ctx pos)) | |
939 | (if (< pos end) | |
940 | (let ((av (make-vector (1+ max-code) #f))) | |
941 | (for-each (lambda (a) | |
942 | (vector-set! av (abbrev-code a) a)) | |
943 | abbrevs) | |
944 | av) | |
945 | (error "Unexpected length" abbrevs pos start end)) | |
946 | (let-values (((abbrev pos) (read-abbrev ctx pos))) | |
947 | (lp (cons abbrev abbrevs) | |
948 | pos | |
949 | (max (abbrev-code abbrev) max-code)))))) | |
950 | ||
951 | (define (ctx-compile-unit-start ctx) | |
952 | (if (ctx-die ctx) | |
953 | (ctx-compile-unit-start (ctx-parent ctx)) | |
954 | (ctx-start ctx))) | |
955 | ||
956 | ;; Values. | |
957 | ;; | |
958 | (define *readers* (make-hash-table)) | |
959 | (define *scanners* (make-hash-table)) | |
960 | (define-syntax define-value-reader | |
961 | (syntax-rules () | |
962 | ((_ form reader scanner) | |
963 | (begin | |
964 | (hashq-set! *readers* 'form reader) | |
965 | (hashq-set! *scanners* 'form scanner))))) | |
966 | ||
967 | (define-value-reader addr read-addr skip-addr) | |
968 | ||
969 | (define-value-reader block | |
970 | (lambda (ctx pos) | |
971 | (let-values (((len pos) (read-uleb128 ctx pos))) | |
972 | (read-block ctx pos len))) | |
973 | (lambda (ctx pos) | |
974 | (let-values (((len pos) (read-uleb128 ctx pos))) | |
975 | (+ pos len)))) | |
976 | ||
977 | (define-value-reader block1 | |
978 | (lambda (ctx pos) | |
979 | (let-values (((len pos) (read-u8 ctx pos))) | |
980 | (read-block ctx pos len))) | |
981 | (lambda (ctx pos) | |
982 | (+ pos 1 (bytevector-u8-ref (ctx-bv ctx) pos)))) | |
983 | ||
984 | (define-value-reader block2 | |
985 | (lambda (ctx pos) | |
986 | (let-values (((len pos) (read-u16 ctx pos))) | |
987 | (read-block ctx pos len))) | |
988 | (lambda (ctx pos) | |
989 | (+ pos 2 (bytevector-u16-ref (ctx-bv ctx) pos (ctx-endianness ctx))))) | |
990 | ||
991 | (define-value-reader block4 | |
992 | (lambda (ctx pos) | |
993 | (let-values (((len pos) (read-u32 ctx pos))) | |
994 | (read-block ctx pos len))) | |
995 | (lambda (ctx pos) | |
996 | (+ pos 4 (bytevector-u32-ref (ctx-bv ctx) pos (ctx-endianness ctx))))) | |
997 | ||
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) | |
1004 | ||
1005 | (define-value-reader flag | |
1006 | (lambda (ctx pos) | |
1007 | (values (not (zero? (bytevector-u8-ref (ctx-bv ctx) pos))) | |
1008 | (1+ pos))) | |
1009 | skip-8) | |
1010 | ||
1011 | (define-value-reader string | |
1012 | read-string | |
1013 | skip-string) | |
1014 | ||
1015 | (define-value-reader strp | |
1016 | (lambda (ctx pos) | |
1017 | (let ((strtab (meta-strtab-start (ctx-meta ctx)))) | |
1018 | (unless strtab | |
1019 | (error "expected a string table" ctx)) | |
1020 | (let-values (((offset pos) (read-offset ctx pos))) | |
1021 | (values (read-string ctx (+ strtab offset)) | |
1022 | pos)))) | |
1023 | skip-32) | |
1024 | ||
1025 | (define-value-reader ref-addr | |
1026 | (lambda (ctx pos) | |
1027 | (let-values (((addr pos) (read-addr ctx pos))) | |
1028 | (values (+ addr (meta-info-start (ctx-meta ctx))) | |
1029 | pos))) | |
1030 | skip-addr) | |
1031 | ||
1032 | (define-value-reader ref1 | |
1033 | (lambda (ctx pos) | |
1034 | (let-values (((addr pos) (read-u8 ctx pos))) | |
1035 | (values (+ addr (ctx-compile-unit-start ctx)) | |
1036 | pos))) | |
1037 | skip-8) | |
1038 | ||
1039 | (define-value-reader ref2 | |
1040 | (lambda (ctx pos) | |
1041 | (let-values (((addr pos) (read-u16 ctx pos))) | |
1042 | (values (+ addr (ctx-compile-unit-start ctx)) | |
1043 | pos))) | |
1044 | skip-16) | |
1045 | ||
1046 | (define-value-reader ref4 | |
1047 | (lambda (ctx pos) | |
1048 | (let-values (((addr pos) (read-u32 ctx pos))) | |
1049 | (values (+ addr (ctx-compile-unit-start ctx)) | |
1050 | pos))) | |
1051 | skip-32) | |
1052 | ||
1053 | (define-value-reader ref8 | |
1054 | (lambda (ctx pos) | |
1055 | (let-values (((addr pos) (read-u64 ctx pos))) | |
1056 | (values (+ addr (ctx-compile-unit-start ctx)) | |
1057 | pos))) | |
1058 | skip-64) | |
1059 | ||
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)) | |
1064 | pos))) | |
1065 | skip-leb128) | |
1066 | ||
1067 | (define-value-reader indirect | |
1068 | (lambda (ctx pos) | |
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) | |
1072 | pos))) | |
1073 | (lambda (ctx pos) | |
1074 | (let*-values (((form pos) (read-uleb128 ctx pos))) | |
1075 | (skip-value ctx pos (form-code->name form))))) | |
1076 | ||
1077 | (define-value-reader sec-offset | |
1078 | read-offset | |
1079 | skip-offset) | |
1080 | ||
1081 | (define-value-reader exprloc | |
1082 | (lambda (ctx pos) | |
1083 | (let-values (((len pos) (read-uleb128 ctx pos))) | |
1084 | (read-block ctx pos len))) | |
1085 | (lambda (ctx pos) | |
1086 | (let-values (((len pos) (read-uleb128 ctx pos))) | |
1087 | (+ pos len)))) | |
1088 | ||
1089 | (define-value-reader flag-present | |
1090 | (lambda (ctx pos) | |
1091 | (values #t pos)) | |
1092 | (lambda (ctx pos) | |
1093 | pos)) | |
1094 | ||
1095 | (define-value-reader ref-sig8 | |
1096 | read-u64 | |
1097 | skip-64) | |
1098 | ||
1099 | (define (read-value ctx pos form) | |
1100 | ((or (hashq-ref *readers* form) | |
1101 | (error "unrecognized form" form)) | |
1102 | ctx pos)) | |
1103 | ||
1104 | (define (skip-value ctx pos form) | |
1105 | ((or (hashq-ref *scanners* form) | |
1106 | (error "unrecognized form" form)) | |
1107 | ctx pos)) | |
1108 | ||
1109 | ;; Parsers for particular attributes. | |
1110 | ;; | |
1111 | (define (parse-location-list ctx offset) | |
1112 | (let lp ((pos (+ (meta-loc-start (ctx-meta ctx)) offset)) | |
1113 | (out '())) | |
1114 | (let*-values (((start pos) (read-addr ctx pos)) | |
1115 | ((end pos) (read-addr ctx pos))) | |
1116 | (if (and (zero? start) (zero? end)) | |
1117 | (reverse out) | |
1118 | (let*-values (((len pos) (read-u16 ctx pos)) | |
1119 | ((block pos) (read-block ctx pos len))) | |
1120 | (lp pos | |
1121 | (cons (list start end (parse-location ctx block)) out))))))) | |
1122 | ||
1123 | (define (parse-location ctx loc) | |
1124 | (cond | |
1125 | ((bytevector? 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 '())) | |
1138 | (if (= pos len) | |
1139 | (reverse out) | |
1140 | (let ((op (location-op->name (u8-ref pos)))) | |
1141 | (case op | |
1142 | ((addr) | |
1143 | (case addr-size | |
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!")))) | |
1147 | ((call-ref) | |
1148 | (case addr-size | |
1149 | ((4) (lp (+ pos 5) | |
1150 | (cons (list op (+ (meta-info-start (ctx-meta ctx)) | |
1151 | (u32-ref (1+ pos)))) | |
1152 | out))) | |
1153 | ((8) (lp (+ pos 9) | |
1154 | (cons (list op (+ (meta-info-start (ctx-meta ctx)) | |
1155 | (u64-ref (1+ pos)))) | |
1156 | out))) | |
1157 | (else (error "what!")))) | |
1158 | ((const1u pick deref-size xderef-size) | |
1159 | (lp (+ pos 2) (cons (list op (u8-ref (1+ pos))) out))) | |
1160 | ((const1s) | |
1161 | (lp (+ pos 2) (cons (list op (s8-ref (1+ pos))) out))) | |
1162 | ((const2u) | |
1163 | (lp (+ pos 3) (cons (list op (u16-ref (1+ pos))) out))) | |
1164 | ((call2) | |
1165 | (lp (+ pos 3) (cons (list op (+ (ctx-compile-unit-start ctx) | |
1166 | (u16-ref (1+ pos)))) | |
1167 | out))) | |
1168 | ((const2s skip bra) | |
1169 | (lp (+ pos 3) (cons (list op (s16-ref (1+ pos))) out))) | |
1170 | ((const4u) | |
1171 | (lp (+ pos 5) (cons (list op (u32-ref (1+ pos))) out))) | |
1172 | ((call4) | |
1173 | (lp (+ pos 5) (cons (list op (+ (ctx-compile-unit-start ctx) | |
1174 | (u32-ref (1+ pos)))) | |
1175 | out))) | |
1176 | ((const4s) | |
1177 | (lp (+ pos 5) (cons (list op (s32-ref (1+ pos))) out))) | |
1178 | ((const8u) | |
1179 | (lp (+ pos 9) (cons (list op (u64-ref (1+ pos))) out))) | |
1180 | ((const8s) | |
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)))) | |
1185 | ((bit-piece) | |
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)))) | |
1195 | (else | |
1196 | (if (number? op) | |
1197 | ;; We failed to parse this opcode; we have to give | |
1198 | ;; up | |
1199 | loc | |
1200 | (lp (1+ pos) (cons (list op) out)))))))))) | |
1201 | (else | |
1202 | (parse-location-list ctx loc)))) | |
1203 | ||
1ed81e02 AW |
1204 | ;; Statement programs. |
1205 | (define-record-type <lregs> | |
1206 | (make-lregs pos pc file line column) | |
1207 | lregs? | |
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!)) | |
1213 | ||
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 | |
1221 | regs) | |
1222 | line-prog? | |
1223 | (ctx line-prog-ctx) | |
1224 | (version line-prog-version) | |
1225 | (header-offset line-prog-header-offset) | |
1226 | (program-offset line-prog-program-offset) | |
1227 | (end line-prog-end) | |
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)) | |
1238 | ||
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) | |
1251 | (values 1 pos) | |
1252 | (read-u8 ctx pos))) | |
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)) | |
1259 | ((file-names 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))))) | |
1276 | ||
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))) | |
1285 | ||
1286 | (let lp ((pos pos) (pc pc) (file file) (line line) (col col)) | |
1287 | (cond | |
1288 | ((>= pos end) | |
1289 | (values #f #f #f #f #f)) | |
1290 | (else | |
1291 | (let-values (((op pos) (read-u8 ctx pos))) | |
1292 | (cond | |
1293 | ((zero? op) ; extended opcodes | |
1294 | (let*-values (((len pos*) (read-uleb128 ctx pos)) | |
1295 | ((op pos) (read-u8 ctx pos*))) | |
1296 | (case op | |
1297 | ((1) ; end-sequence | |
1298 | (values pos pc file line col)) | |
1299 | ((2) ; set-address | |
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))) | |
1304 | ((3) ; define-file | |
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)) | |
1309 | (else | |
1310 | (warn "unknown extended op" op) | |
1311 | (lp (+ pos* len) pc file line col))))) | |
1312 | ||
1313 | ((< op opcode-base) ; standard opcodes | |
1314 | (case op | |
1315 | ((1) ; copy | |
1316 | (values pos pc file line col)) | |
1317 | ((2) ; advance-pc | |
1318 | (let-values (((advance pos) (read-uleb128 ctx pos))) | |
1319 | (lp pos (+ pc (* advance min-insn-len)) file line col))) | |
1320 | ((3) ; advance-line | |
1321 | (let-values (((diff pos) (read-sleb128 ctx pos))) | |
1322 | (lp pos pc file (+ line diff) col))) | |
1323 | ((4) ; set-file | |
1324 | (let-values (((file pos) (read-uleb128 ctx pos))) | |
1325 | (lp pos pc file line col))) | |
1326 | ((5) ; set-column | |
1327 | (let-values (((col pos) (read-uleb128 ctx pos))) | |
1328 | (lp pos pc file line col))) | |
1329 | ((6) ; negate-line | |
1330 | (lp pos pc file line col)) | |
1331 | ((7) ; set-basic-block | |
1332 | (lp pos pc file line col)) | |
1333 | ((8) ; const-add-pc | |
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))) | |
1339 | (else | |
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)))))))))) | |
1346 | ||
1347 | (define (line-prog-advance prog) | |
1348 | (let ((regs (line-prog-regs prog))) | |
1349 | (call-with-values (lambda () | |
1350 | (line-prog-next-row prog | |
1351 | (lregs-pos regs) | |
1352 | (lregs-pc regs) | |
1353 | (lregs-file regs) | |
1354 | (lregs-line regs) | |
1355 | (lregs-column regs))) | |
1356 | (lambda (pos pc file line col) | |
1357 | (cond | |
1358 | ((not pos) | |
1359 | (values #f #f #f #f)) | |
1360 | (else | |
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). | |
1367 | (values pc | |
1368 | (if (zero? file) | |
1369 | #f | |
1370 | (list-ref (line-prog-file-names prog) (1- file))) | |
1371 | (if (zero? line) #f line) | |
1372 | (if (zero? col) #f col)))))))) | |
1373 | ||
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). | |
1383 | (values pc | |
1384 | (if (zero? file) | |
1385 | #f | |
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*) | |
1393 | (cond | |
1394 | ((not pos*) | |
1395 | (values #f #f #f #f)) | |
1396 | ((< pc* target-pc) | |
1397 | (scan pos* pc* file* line* col*)) | |
1398 | ((= pc* target-pc) | |
1399 | (finish pos* pc* file* line* col*)) | |
6b71a767 AW |
1400 | ((zero? pc) |
1401 | ;; We scanned from the beginning didn't find any info. | |
1402 | (values #f #f #f #f)) | |
1ed81e02 AW |
1403 | (else |
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))))) | |
1413 | ||
35558f75 AW |
1414 | (define-syntax-rule (define-attribute-parsers parse (name parser) ...) |
1415 | (define parse | |
1416 | (let ((parsers (make-hash-table))) | |
1417 | (hashq-set! parsers 'name parser) | |
1418 | ... | |
1419 | (lambda (ctx attr val) | |
1420 | (cond | |
1421 | ((hashq-ref parsers attr) => (lambda (p) (p ctx val))) | |
1422 | (else val)))))) | |
1423 | ||
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)))) | |
1437 | ||
1438 | ;; "Debugging Information Entries": DIEs. | |
1439 | ;; | |
1440 | (define-record-type <die> | |
1441 | (make-die ctx offset abbrev vals) | |
1442 | die? | |
1443 | (ctx die-ctx) | |
1444 | (offset die-offset) | |
1445 | (abbrev die-abbrev) | |
1446 | (vals %die-vals %set-die-vals!)) | |
1447 | ||
1448 | (define (die-tag die) | |
1449 | (abbrev-tag (die-abbrev die))) | |
1450 | ||
1451 | (define (die-attrs die) | |
1452 | (abbrev-attrs (die-abbrev die))) | |
1453 | ||
1454 | (define (die-forms die) | |
1455 | (abbrev-forms (die-abbrev die))) | |
1456 | ||
1457 | (define (die-vals die) | |
1458 | (let ((vals (%die-vals die))) | |
1459 | (or vals | |
1460 | (begin | |
1461 | (%set-die-vals! die (read-values (die-ctx die) (skip-leb128 (die-ctx die) (die-offset die)) (die-abbrev die))) | |
1462 | (die-vals die))))) | |
1463 | ||
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))) | |
1467 | (die-abbrev die)))) | |
1468 | ||
1469 | (define* (die-ref die attr #:optional default) | |
1470 | (cond | |
1471 | ((list-index (die-attrs die) attr) | |
1472 | => (lambda (n) (list-ref (die-vals die) n))) | |
1473 | (else default))) | |
1474 | ||
1475 | (define (die-specification die) | |
1476 | (and=> (die-ref die 'specification) | |
1477 | (lambda (offset) (find-die-by-offset (die-ctx die) offset)))) | |
1478 | ||
1479 | (define (die-name die) | |
1480 | (or (die-ref die 'name) | |
1481 | (and=> (die-specification die) die-name))) | |
1482 | ||
1483 | (define (die-qname die) | |
1484 | (cond | |
1485 | ((eq? (die-tag die) 'compile-unit) "") | |
1486 | ((die-ref die 'name) | |
1487 | => (lambda (name) | |
1488 | (if (eq? (die-tag (ctx-die (die-ctx die))) 'compile-unit) | |
1489 | name ; short cut | |
1490 | (string-append (die-qname (ctx-die (die-ctx die))) "::" name)))) | |
1491 | ((die-specification die) | |
1492 | => die-qname) | |
1493 | (else #f))) | |
1494 | ||
1ed81e02 AW |
1495 | (define (die-line-prog die) |
1496 | (let ((stmt-list (die-ref die 'stmt-list))) | |
1497 | (and stmt-list | |
1498 | (let* ((ctx (die-ctx die)) | |
1499 | (meta (ctx-meta ctx))) | |
1500 | (make-line-prog ctx | |
1501 | (+ (meta-line-start meta) stmt-list) | |
1502 | (meta-line-end meta)))))) | |
1503 | ||
35558f75 AW |
1504 | (define (read-values ctx offset abbrev) |
1505 | (let lp ((attrs (abbrev-attrs abbrev)) | |
1506 | (forms (abbrev-forms abbrev)) | |
1507 | (vals '()) | |
1508 | (pos offset)) | |
1509 | (if (null? forms) | |
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) | |
1514 | pos))))) | |
1515 | ||
1516 | (define (skip-values ctx offset abbrev) | |
1517 | (let lp ((forms (abbrev-forms abbrev)) | |
1518 | (pos offset)) | |
1519 | (if (null? forms) | |
1520 | pos | |
1521 | (lp (cdr forms) (skip-value ctx pos (car forms)))))) | |
1522 | ||
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))) | |
2700f198 | 1528 | pos))) |
35558f75 AW |
1529 | |
1530 | (define (read-die ctx offset) | |
1531 | (let*-values (((abbrev pos) (read-die-abbrev ctx offset))) | |
1532 | (if abbrev | |
1533 | (values (make-die ctx offset abbrev #f) | |
1534 | (skip-values ctx pos abbrev)) | |
1535 | (values #f pos)))) | |
1536 | ||
1537 | (define* (die-sibling ctx abbrev offset #:optional offset-vals offset-end) | |
1538 | (cond | |
1539 | ((not (abbrev-has-children? abbrev)) | |
1540 | (or offset-end | |
1541 | (skip-values ctx | |
1542 | (or offset-vals (skip-leb128 ctx offset)) | |
1543 | abbrev))) | |
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))))) | |
1552 | (else | |
1553 | (call-with-values | |
1554 | (lambda () | |
1555 | (fold-die-list ctx | |
1556 | (or offset-end | |
1557 | (skip-values ctx | |
1558 | (or offset-vals | |
1559 | (skip-leb128 ctx offset)) | |
1560 | abbrev)) | |
1561 | (lambda (ctx offset abbrev) #t) | |
1562 | error | |
1563 | #f)) | |
1564 | (lambda (seed pos) | |
1565 | pos))))) | |
1566 | ||
1567 | (define (find-die-context ctx offset) | |
1568 | (define (not-found) | |
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) | |
1575 | ctx | |
1576 | (find-root (or (ctx-parent ctx) (not-found))))) | |
1577 | (define (find-leaf ctx) | |
1578 | (let lp ((kids (ctx-children ctx))) | |
1579 | (if (null? kids) | |
1580 | ctx | |
1581 | (if (in-context? (car kids)) | |
1582 | (find-leaf (car kids)) | |
1583 | (lp (cdr kids)))))) | |
1584 | (find-leaf (find-root ctx))) | |
1585 | ||
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))) | |
1589 | ||
1590 | (define-syntax-rule (let/ec k e e* ...) | |
1591 | (let ((tag (make-prompt-tag))) | |
1592 | (call-with-prompt | |
1593 | tag | |
1594 | (lambda () | |
1595 | (let ((k (lambda args (apply abort-to-prompt tag args)))) | |
1596 | e e* ...)) | |
1597 | (lambda (_ res) res)))) | |
1598 | ||
1599 | (define* (find-die roots pred #:key | |
1600 | (skip? (lambda (ctx offset abbrev) #f)) | |
1601 | (recurse? (lambda (die) #t))) | |
1602 | (let/ec k | |
1603 | (define (visit-die die) | |
1604 | (cond | |
1605 | ((pred die) | |
1606 | (k die)) | |
1607 | ((recurse? die) | |
1608 | (fold-die-children die (lambda (die seed) (visit-die die)) #f | |
1609 | #:skip? skip?)) | |
1610 | (else #f))) | |
1611 | (for-each visit-die roots) | |
1612 | #f)) | |
1613 | ||
1ed81e02 AW |
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))) | |
1618 | (and val | |
1619 | (let ((idx (list-index (die-attrs die) 'high-pc))) | |
1620 | (case (list-ref (die-forms die) idx) | |
1621 | ((addr) val) | |
1622 | (else (+ val (die-low-pc die)))))))) | |
1623 | ||
35558f75 AW |
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) | |
1629 | (else #t))) | |
1630 | (define (recurse? die) | |
1631 | (case (die-tag die) | |
1632 | ((compile-unit) | |
1ed81e02 | 1633 | (not (or (and=> (die-low-pc die) |
35558f75 | 1634 | (lambda (low) (< pc low))) |
1ed81e02 | 1635 | (and=> (die-high-pc die) |
35558f75 AW |
1636 | (lambda (high) (<= high pc)))))) |
1637 | (else #f))) | |
1638 | (find-die roots | |
1639 | (lambda (die) | |
1640 | (and (eq? (die-tag die) 'subprogram) | |
1ed81e02 | 1641 | (equal? (die-low-pc die) pc))) |
35558f75 AW |
1642 | #:skip? skip? #:recurse? recurse?)) |
1643 | ||
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))) | |
1648 | (cond | |
1649 | ((not abbrev) (values seed pos)) | |
1650 | ((skip? ctx offset abbrev) | |
1651 | (lp (die-sibling ctx abbrev offset pos) seed)) | |
1652 | (else | |
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))))))))) | |
1657 | ||
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) | |
1662 | skip? proc seed)) | |
1663 | seed)) | |
1664 | ||
1665 | (define (die-children die) | |
1666 | (reverse (fold-die-children die cons '()))) | |
1667 | ||
1668 | (define (add-to-parent! ctx) | |
1669 | (let ((parent (ctx-parent ctx))) | |
1670 | (set-children! parent | |
1671 | (append (ctx-children parent) (list ctx))) | |
1672 | ctx)) | |
1673 | ||
1674 | (define (make-compilation-unit-context ctx offset-size addr-size | |
1675 | abbrevs start len) | |
1676 | (unless (= addr-size (ctx-addr-size ctx)) | |
1677 | (error "ELF word size not equal to compilation unit addrsize")) | |
1678 | (add-to-parent! | |
1679 | (make-dwarf-context (ctx-bv ctx) | |
1680 | offset-size (ctx-endianness ctx) | |
1681 | (ctx-meta ctx) | |
1682 | abbrevs ctx #f start (+ start 4 len) '()))) | |
1683 | ||
1684 | (define (make-child-context die) | |
1685 | (let ((ctx (die-ctx die))) | |
1686 | (add-to-parent! | |
1687 | (make-dwarf-context (ctx-bv ctx) | |
1688 | (ctx-offset-size ctx) (ctx-endianness ctx) | |
1689 | (ctx-meta ctx) | |
1690 | (ctx-abbrevs ctx) | |
1691 | ctx die | |
1692 | (die-next-offset die) | |
1693 | (die-sibling ctx (die-abbrev die) (die-offset die)) | |
1694 | '())))) | |
1695 | ||
1696 | (define (ctx-language ctx) | |
1697 | (or (and=> (ctx-die ctx) (lambda (x) (die-ref x 'language))) | |
1698 | (and=> (ctx-parent ctx) ctx-language))) | |
1699 | ||
1700 | (define (populate-context-tree! die) | |
1701 | (define (skip? ctx offset abbrev) | |
1702 | (case (abbrev-tag abbrev) | |
1703 | ((class-type structure-type namespace) #f) | |
1704 | (else #t))) | |
1705 | (case (die-tag die) | |
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)) | |
1715 | #f | |
1716 | #:skip? skip?)))))) | |
1717 | ||
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 | |
1726 | av start len)) | |
2700f198 | 1727 | ((die pos) (read-die ctx pos))) |
35558f75 AW |
1728 | (populate-context-tree! die) |
1729 | (values die (ctx-end ctx)))) | |
1730 | ||
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))) | |
1735 | (if die | |
1736 | (lp (cons die dies) pos) | |
1737 | (reverse dies))) | |
1738 | (reverse dies)))) | |
1739 | ||
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))) | |
1749 | (if (zero? offset) | |
1750 | (values seed pos) | |
1751 | (let-values (((str pos) (read-string ctx pos))) | |
1752 | (lp pos | |
1753 | (folder str (+ offset info-offset) seed)))))))) | |
1754 | ||
1755 | (define (fold-pubnames ctx folder seed) | |
1756 | (let ((end (meta-pubnames-end (ctx-meta ctx)))) | |
1757 | (if end | |
1758 | (let lp ((pos (meta-pubnames-start (ctx-meta ctx))) (seed seed)) | |
1759 | (if (< pos end) | |
1760 | (let-values (((seed pos) (fold-pubname-set ctx pos folder seed))) | |
1761 | (lp pos seed)) | |
1762 | seed)) | |
1763 | seed))) | |
1764 | ||
1765 | (define (align address alignment) | |
1766 | (+ address | |
1767 | (modulo (- alignment (modulo address alignment)) alignment))) | |
1768 | ||
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)) | |
1781 | (values seed pos) | |
1782 | (lp pos | |
1783 | (folder info-offset addr len seed))))))) | |
1784 | ||
1785 | (define (fold-aranges ctx folder seed) | |
1786 | (let ((end (meta-aranges-end (ctx-meta ctx)))) | |
1787 | (if end | |
1788 | (let lp ((pos (meta-aranges-start (ctx-meta ctx))) (seed seed)) | |
1789 | (if (< pos end) | |
1790 | (let-values (((seed pos) (fold-arange-set ctx pos folder seed))) | |
1791 | (lp pos seed)) | |
1792 | seed)) | |
1793 | seed))) | |
1794 | ||
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")) | |
1ed81e02 | 1802 | (line (assoc-ref sections ".debug_line")) |
35558f75 AW |
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) | |
1808 | (make-dwarf-meta | |
1809 | (elf-word-size elf) | |
1810 | vaddr memsz | |
1811 | path lib-path | |
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)) | |
1ed81e02 AW |
1824 | (and line |
1825 | (elf-section-offset line)) | |
1826 | (and line | |
1827 | (+ (elf-section-offset line) | |
1828 | (elf-section-size line))) | |
35558f75 AW |
1829 | (and pubnames |
1830 | (elf-section-offset pubnames)) | |
1831 | (and pubnames | |
1832 | (+ (elf-section-offset pubnames) | |
1833 | (elf-section-size pubnames))) | |
1834 | (and aranges | |
1835 | (elf-section-offset aranges)) | |
1836 | (and aranges | |
1837 | (+ (elf-section-offset aranges) | |
1838 | (elf-section-size aranges)))) | |
1839 | #() #f #f | |
1840 | (elf-section-offset info) | |
1841 | (+ (elf-section-offset info) | |
1842 | (elf-section-size info)) | |
1843 | '()))) | |
1844 | ||
1845 | (define (die->tree die) | |
1846 | (cons* (die-tag die) | |
1847 | (cons 'offset (die-offset die)) | |
1848 | (reverse! (fold-die-children | |
1849 | die | |
1850 | (lambda (die seed) | |
1851 | (cons (die->tree die) seed)) | |
1852 | (fold acons '() (die-attrs die) (die-vals die)))))) |