Commit | Line | Data |
---|---|---|
cb86cbd7 AW |
1 | ;;; Guile runtime debug information |
2 | ||
bec786c1 | 3 | ;;; Copyright (C) 2013, 2014 Free Software Foundation, Inc. |
cb86cbd7 AW |
4 | ;;; |
5 | ;;; This library is free software; you can redistribute it and/or | |
6 | ;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;; License as published by the Free Software Foundation; either | |
8 | ;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;; | |
10 | ;;; This library is distributed in the hope that it will be useful, | |
11 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;; Lesser General Public License for more details. | |
14 | ;;; | |
15 | ;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;; License along with this library; if not, write to the Free Software | |
17 | ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ||
19 | ;;; Commentary: | |
20 | ;;; | |
691697de AW |
21 | ;;; Guile's bytecode compiler and linker serialize debugging information |
22 | ;;; into separate sections of the ELF image. This module reads those | |
cb86cbd7 AW |
23 | ;;; sections. |
24 | ;;; | |
25 | ;;; Code: | |
26 | ||
27 | (define-module (system vm debug) | |
28 | #:use-module (system vm elf) | |
c0ada5a7 | 29 | #:use-module (system vm dwarf) |
4cbc95f1 | 30 | #:use-module (system vm loader) |
cb86cbd7 AW |
31 | #:use-module (system foreign) |
32 | #:use-module (rnrs bytevectors) | |
33 | #:use-module (ice-9 match) | |
0128bb9c | 34 | #:use-module ((srfi srfi-1) #:select (fold)) |
cb86cbd7 AW |
35 | #:use-module (srfi srfi-9) |
36 | #:export (debug-context-image | |
82e299f3 | 37 | debug-context-base |
581a4eb8 | 38 | debug-context-length |
610295ec | 39 | debug-context-text-base |
cb86cbd7 AW |
40 | |
41 | program-debug-info-name | |
42 | program-debug-info-context | |
43 | program-debug-info-image | |
44 | program-debug-info-offset | |
e391f179 | 45 | program-debug-info-size |
cb86cbd7 AW |
46 | program-debug-info-addr |
47 | program-debug-info-u32-offset | |
48 | program-debug-info-u32-offset-end | |
49 | ||
f88e574d AW |
50 | arity? |
51 | arity-low-pc | |
52 | arity-high-pc | |
53 | arity-nreq | |
54 | arity-nopt | |
55 | arity-has-rest? | |
56 | arity-allow-other-keys? | |
57 | arity-has-keyword-args? | |
bec786c1 | 58 | arity-keyword-args |
f88e574d AW |
59 | arity-is-case-lambda? |
60 | ||
610295ec | 61 | debug-context-from-image |
0128bb9c | 62 | fold-all-debug-contexts |
610295ec | 63 | for-each-elf-symbol |
cb86cbd7 | 64 | find-debug-context |
f88e574d AW |
65 | find-program-debug-info |
66 | arity-arguments-alist | |
eb2bc00f | 67 | find-program-arities |
bec786c1 | 68 | find-program-arity |
34cf09cc | 69 | find-program-minimum-arity |
bf8328ec | 70 | |
c4c098e3 AW |
71 | find-program-docstring |
72 | ||
c0ada5a7 AW |
73 | find-program-properties |
74 | ||
75 | source? | |
76 | source-pre-pc | |
77 | source-post-pc | |
78 | source-file | |
79 | source-line | |
80 | source-line-for-user | |
81 | source-column | |
82 | find-source-for-addr | |
0128bb9c AW |
83 | find-program-sources |
84 | fold-source-locations)) | |
cb86cbd7 AW |
85 | |
86 | ;;; A compiled procedure comes from a specific loaded ELF image. A | |
87 | ;;; debug context identifies that image. | |
88 | ;;; | |
89 | (define-record-type <debug-context> | |
90 | (make-debug-context elf base text-base) | |
91 | debug-context? | |
92 | (elf debug-context-elf) | |
93 | ;; Address at which this image is loaded in memory, in bytes. | |
94 | (base debug-context-base) | |
95 | ;; Offset of the text section relative to the image start, in bytes. | |
96 | (text-base debug-context-text-base)) | |
97 | ||
98 | (define (debug-context-image context) | |
99 | "Return the bytevector aliasing the mapped ELF image corresponding to | |
100 | @var{context}." | |
101 | (elf-bytes (debug-context-elf context))) | |
102 | ||
581a4eb8 AW |
103 | (define (debug-context-length context) |
104 | "Return the size of the mapped ELF image corresponding to | |
105 | @var{context}, in bytes." | |
106 | (bytevector-length (debug-context-image context))) | |
107 | ||
610295ec AW |
108 | (define (for-each-elf-symbol context proc) |
109 | "Call @var{proc} on each symbol in the symbol table of @var{context}." | |
110 | (let ((elf (debug-context-elf context))) | |
111 | (cond | |
112 | ((elf-section-by-name elf ".symtab") | |
113 | => (lambda (symtab) | |
114 | (let ((len (elf-symbol-table-len symtab)) | |
115 | (strtab (elf-section elf (elf-section-link symtab)))) | |
116 | (let lp ((n 0)) | |
117 | (when (< n len) | |
118 | (proc (elf-symbol-table-ref elf symtab n strtab)) | |
119 | (lp (1+ n)))))))))) | |
120 | ||
cb86cbd7 AW |
121 | ;;; A program debug info (PDI) is a handle on debugging meta-data for a |
122 | ;;; particular program. | |
123 | ;;; | |
124 | (define-record-type <program-debug-info> | |
125 | (make-program-debug-info context name offset size) | |
126 | program-debug-info? | |
127 | (context program-debug-info-context) | |
128 | (name program-debug-info-name) | |
129 | ;; Offset of the procedure in the text section, in bytes. | |
130 | (offset program-debug-info-offset) | |
131 | (size program-debug-info-size)) | |
132 | ||
133 | (define (program-debug-info-addr pdi) | |
134 | "Return the address in memory of the entry of the program represented | |
135 | by the debugging info @var{pdi}." | |
136 | (+ (program-debug-info-offset pdi) | |
137 | (debug-context-text-base (program-debug-info-context pdi)) | |
138 | (debug-context-base (program-debug-info-context pdi)))) | |
139 | ||
140 | (define (program-debug-info-image pdi) | |
141 | "Return the ELF image containing @var{pdi}, as a bytevector." | |
142 | (debug-context-image (program-debug-info-context pdi))) | |
143 | ||
144 | (define (program-debug-info-u32-offset pdi) | |
145 | "Return the start address of the program represented by @var{pdi}, as | |
146 | an offset from the beginning of the ELF image in 32-bit units." | |
147 | (/ (+ (program-debug-info-offset pdi) | |
148 | (debug-context-text-base (program-debug-info-context pdi))) | |
149 | 4)) | |
150 | ||
151 | (define (program-debug-info-u32-offset-end pdi) | |
152 | "Return the end address of the program represented by @var{pdi}, as an | |
153 | offset from the beginning of the ELF image in 32-bit units." | |
154 | (/ (+ (program-debug-info-size pdi) | |
155 | (program-debug-info-offset pdi) | |
156 | (debug-context-text-base (program-debug-info-context pdi))) | |
157 | 4)) | |
158 | ||
610295ec AW |
159 | (define (debug-context-from-image bv) |
160 | "Build a debugging context corresponding to a given ELF image." | |
161 | (let* ((elf (parse-elf bv)) | |
cb86cbd7 AW |
162 | (base (pointer-address (bytevector->pointer (elf-bytes elf)))) |
163 | (text-base (elf-section-offset | |
164 | (or (elf-section-by-name elf ".rtl-text") | |
165 | (error "ELF object has no text section"))))) | |
166 | (make-debug-context elf base text-base))) | |
167 | ||
0128bb9c AW |
168 | (define (fold-all-debug-contexts proc seed) |
169 | "Fold @var{proc} over debug contexts corresponding to all images that | |
170 | are mapped at the time this procedure is called. Any images mapped | |
171 | during the fold are omitted." | |
172 | (fold (lambda (image seed) | |
173 | (proc (debug-context-from-image image) seed)) | |
174 | seed | |
175 | (all-mapped-elf-images))) | |
176 | ||
610295ec AW |
177 | (define (find-debug-context addr) |
178 | "Find and return the debugging context corresponding to the ELF image | |
f8fb13ef | 179 | containing the address @var{addr}. @var{addr} is an integer. If no ELF |
691697de AW |
180 | image is found, return @code{#f}. It's possible for an bytecode program |
181 | not to have an ELF image if the program was defined in as a stub in C." | |
f8fb13ef AW |
182 | (and=> (find-mapped-elf-image addr) |
183 | debug-context-from-image)) | |
610295ec | 184 | |
695e6b75 AW |
185 | (define-inlinable (binary-search start end inc try failure) |
186 | (let lp ((start start) (end end)) | |
187 | (if (eqv? start end) | |
188 | (failure) | |
189 | (let ((mid (+ start (* inc (floor/ (- end start) (* 2 inc)))))) | |
190 | (try mid | |
191 | (lambda () | |
192 | (lp start mid)) | |
193 | (lambda () | |
194 | (lp (+ mid inc) end))))))) | |
195 | ||
cb86cbd7 AW |
196 | (define (find-elf-symbol elf text-offset) |
197 | "Search the symbol table of @var{elf} for the ELF symbol containing | |
198 | @var{text-offset}. @var{text-offset} is a byte offset in the text | |
199 | section of the ELF image. Returns an ELF symbol, or @code{#f}." | |
200 | (and=> | |
201 | (elf-section-by-name elf ".symtab") | |
202 | (lambda (symtab) | |
695e6b75 AW |
203 | (let ((strtab (elf-section elf (elf-section-link symtab)))) |
204 | (binary-search | |
205 | 0 (elf-symbol-table-len symtab) 1 | |
206 | (lambda (n continue-before continue-after) | |
207 | (let* ((sym (elf-symbol-table-ref elf symtab n strtab)) | |
208 | (val (elf-symbol-value sym)) | |
209 | (size (elf-symbol-size sym))) | |
210 | (cond | |
211 | ((< text-offset val) (continue-before)) | |
212 | ((<= (+ val size) text-offset) (continue-after)) | |
213 | (else sym)))) | |
214 | (lambda () | |
215 | #f)))))) | |
cb86cbd7 AW |
216 | |
217 | (define* (find-program-debug-info addr #:optional | |
218 | (context (find-debug-context addr))) | |
219 | "Find and return the @code{<program-debug-info>} containing | |
220 | @var{addr}, or @code{#f}." | |
221 | (cond | |
f8fb13ef AW |
222 | ((and context |
223 | (find-elf-symbol (debug-context-elf context) | |
224 | (- addr | |
225 | (debug-context-base context) | |
226 | (debug-context-text-base context)))) | |
cb86cbd7 AW |
227 | => (lambda (sym) |
228 | (make-program-debug-info context | |
229 | (and=> (elf-symbol-name sym) | |
230 | ;; The name might be #f if | |
231 | ;; the string table was | |
232 | ;; stripped somehow. | |
233 | (lambda (x) | |
234 | (and (string? x) | |
235 | (not (string-null? x)) | |
236 | (string->symbol x)))) | |
237 | (elf-symbol-value sym) | |
238 | (elf-symbol-size sym)))) | |
239 | (else #f))) | |
f88e574d AW |
240 | |
241 | (define-record-type <arity> | |
242 | (make-arity context base header-offset) | |
243 | arity? | |
244 | (context arity-context) | |
245 | (base arity-base) | |
246 | (header-offset arity-header-offset)) | |
247 | ||
248 | (define arities-prefix-len 4) | |
249 | (define arity-header-len (* 6 4)) | |
250 | ||
251 | ;;; struct arity_header { | |
252 | ;;; uint32_t low_pc; | |
253 | ;;; uint32_t high_pc; | |
254 | ;;; uint32_t offset; | |
255 | ;;; uint32_t flags; | |
256 | ;;; uint32_t nreq; | |
257 | ;;; uint32_t nopt; | |
258 | ;;; } | |
259 | ||
260 | (define (arity-low-pc* bv header-pos) | |
261 | (bytevector-u32-native-ref bv (+ header-pos (* 0 4)))) | |
262 | (define (arity-high-pc* bv header-pos) | |
263 | (bytevector-u32-native-ref bv (+ header-pos (* 1 4)))) | |
264 | (define (arity-offset* bv header-pos) | |
265 | (bytevector-u32-native-ref bv (+ header-pos (* 2 4)))) | |
266 | (define (arity-flags* bv header-pos) | |
267 | (bytevector-u32-native-ref bv (+ header-pos (* 3 4)))) | |
268 | (define (arity-nreq* bv header-pos) | |
269 | (bytevector-u32-native-ref bv (+ header-pos (* 4 4)))) | |
270 | (define (arity-nopt* bv header-pos) | |
271 | (bytevector-u32-native-ref bv (+ header-pos (* 5 4)))) | |
272 | ||
273 | ;;; #x1: has-rest? | |
274 | ;;; #x2: allow-other-keys? | |
275 | ;;; #x4: has-keyword-args? | |
276 | ;;; #x8: is-case-lambda? | |
d8595af5 | 277 | ;;; #x10: is-in-case-lambda? |
f88e574d AW |
278 | |
279 | (define (has-rest? flags) (not (zero? (logand flags (ash 1 0))))) | |
280 | (define (allow-other-keys? flags) (not (zero? (logand flags (ash 1 1))))) | |
281 | (define (has-keyword-args? flags) (not (zero? (logand flags (ash 1 2))))) | |
282 | (define (is-case-lambda? flags) (not (zero? (logand flags (ash 1 3))))) | |
d8595af5 | 283 | (define (is-in-case-lambda? flags) (not (zero? (logand flags (ash 1 4))))) |
f88e574d | 284 | |
9dff1df9 | 285 | (define (arity-low-pc arity) |
0e3a59f7 AW |
286 | (let ((ctx (arity-context arity))) |
287 | (+ (debug-context-base ctx) | |
288 | (debug-context-text-base ctx) | |
289 | (arity-low-pc* (elf-bytes (debug-context-elf ctx)) | |
290 | (arity-header-offset arity))))) | |
9dff1df9 AW |
291 | |
292 | (define (arity-high-pc arity) | |
0e3a59f7 AW |
293 | (let ((ctx (arity-context arity))) |
294 | (+ (debug-context-base ctx) | |
295 | (debug-context-text-base ctx) | |
296 | (arity-high-pc* (elf-bytes (debug-context-elf ctx)) | |
297 | (arity-header-offset arity))))) | |
9dff1df9 | 298 | |
f88e574d AW |
299 | (define (arity-nreq arity) |
300 | (arity-nreq* (elf-bytes (debug-context-elf (arity-context arity))) | |
301 | (arity-header-offset arity))) | |
302 | ||
303 | (define (arity-nopt arity) | |
304 | (arity-nopt* (elf-bytes (debug-context-elf (arity-context arity))) | |
305 | (arity-header-offset arity))) | |
306 | ||
307 | (define (arity-flags arity) | |
308 | (arity-flags* (elf-bytes (debug-context-elf (arity-context arity))) | |
309 | (arity-header-offset arity))) | |
310 | ||
311 | (define (arity-has-rest? arity) (has-rest? (arity-flags arity))) | |
312 | (define (arity-allow-other-keys? arity) (allow-other-keys? (arity-flags arity))) | |
313 | (define (arity-has-keyword-args? arity) (has-keyword-args? (arity-flags arity))) | |
314 | (define (arity-is-case-lambda? arity) (is-case-lambda? (arity-flags arity))) | |
d8595af5 | 315 | (define (arity-is-in-case-lambda? arity) (is-in-case-lambda? (arity-flags arity))) |
f88e574d AW |
316 | |
317 | (define (arity-load-symbol arity) | |
318 | (let ((elf (debug-context-elf (arity-context arity)))) | |
319 | (cond | |
320 | ((elf-section-by-name elf ".guile.arities") | |
321 | => | |
322 | (lambda (sec) | |
323 | (let* ((strtab (elf-section elf (elf-section-link sec))) | |
324 | (bv (elf-bytes elf)) | |
325 | (strtab-offset (elf-section-offset strtab))) | |
326 | (lambda (n) | |
327 | (string->symbol (string-table-ref bv (+ strtab-offset n))))))) | |
328 | (else (error "couldn't find arities section"))))) | |
329 | ||
bec786c1 | 330 | (define (arity-keyword-args arity) |
cade4c8f AW |
331 | (define (unpack-scm n) |
332 | (pointer->scm (make-pointer n))) | |
333 | (if (arity-has-keyword-args? arity) | |
334 | (let* ((bv (elf-bytes (debug-context-elf (arity-context arity)))) | |
335 | (header (arity-header-offset arity)) | |
336 | (link-offset (arity-offset* bv header)) | |
337 | (link (+ (arity-base arity) link-offset)) | |
338 | (offset (bytevector-u32-native-ref bv link))) | |
339 | (unpack-scm (+ (debug-context-base (arity-context arity)) offset))) | |
340 | '())) | |
bec786c1 | 341 | |
f88e574d AW |
342 | (define (arity-arguments-alist arity) |
343 | (let* ((bv (elf-bytes (debug-context-elf (arity-context arity)))) | |
344 | (%load-symbol (arity-load-symbol arity)) | |
345 | (header (arity-header-offset arity)) | |
f88e574d AW |
346 | (flags (arity-flags* bv header)) |
347 | (nreq (arity-nreq* bv header)) | |
cade4c8f AW |
348 | (nopt (arity-nopt* bv header)) |
349 | (link-offset (arity-offset* bv header)) | |
350 | (link (+ (arity-base arity) | |
351 | link-offset | |
352 | (if (has-keyword-args? flags) 4 0)))) | |
f88e574d AW |
353 | (define (load-symbol idx) |
354 | (%load-symbol (bytevector-u32-native-ref bv (+ link (* idx 4))))) | |
355 | (define (load-symbols skip n) | |
356 | (let lp ((n n) (out '())) | |
357 | (if (zero? n) | |
358 | out | |
359 | (lp (1- n) | |
360 | (cons (load-symbol (+ skip (1- n))) out))))) | |
f88e574d AW |
361 | (and (not (is-case-lambda? flags)) |
362 | `((required . ,(load-symbols 0 nreq)) | |
363 | (optional . ,(load-symbols nreq nopt)) | |
cade4c8f | 364 | (keyword . ,(arity-keyword-args arity)) |
f41accb9 AW |
365 | (allow-other-keys? . ,(allow-other-keys? flags)) |
366 | (rest . ,(and (has-rest? flags) (load-symbol (+ nreq nopt)))))))) | |
f88e574d AW |
367 | |
368 | (define (find-first-arity context base addr) | |
369 | (let* ((bv (elf-bytes (debug-context-elf context))) | |
370 | (text-offset (- addr | |
371 | (debug-context-text-base context) | |
d8595af5 AW |
372 | (debug-context-base context)))) |
373 | (binary-search | |
374 | (+ base arities-prefix-len) | |
375 | (+ base (bytevector-u32-native-ref bv base)) | |
376 | arity-header-len | |
377 | (lambda (pos continue-before continue-after) | |
378 | (let lp ((pos pos)) | |
379 | (cond | |
380 | ((is-in-case-lambda? (arity-flags* bv pos)) | |
381 | (lp (- pos arity-header-len))) | |
382 | ((< text-offset (arity-low-pc* bv pos)) | |
383 | (continue-before)) | |
384 | ((<= (arity-high-pc* bv pos) text-offset) | |
385 | (continue-after)) | |
386 | (else | |
387 | (make-arity context base pos))))) | |
388 | (lambda () | |
389 | #f)))) | |
f88e574d AW |
390 | |
391 | (define (read-sub-arities context base outer-header-offset) | |
392 | (let* ((bv (elf-bytes (debug-context-elf context))) | |
393 | (headers-end (+ base (bytevector-u32-native-ref bv base))) | |
394 | (low-pc (arity-low-pc* bv outer-header-offset)) | |
395 | (high-pc (arity-high-pc* bv outer-header-offset))) | |
396 | (let lp ((pos (+ outer-header-offset arity-header-len)) (out '())) | |
397 | (if (and (< pos headers-end) (<= (arity-high-pc* bv pos) high-pc)) | |
398 | (lp (+ pos arity-header-len) | |
399 | (cons (make-arity context base pos) out)) | |
400 | (reverse out))))) | |
401 | ||
402 | (define* (find-program-arities addr #:optional | |
403 | (context (find-debug-context addr))) | |
404 | (and=> | |
f8fb13ef AW |
405 | (and context |
406 | (elf-section-by-name (debug-context-elf context) ".guile.arities")) | |
f88e574d AW |
407 | (lambda (sec) |
408 | (let* ((base (elf-section-offset sec)) | |
409 | (first (find-first-arity context base addr))) | |
f88e574d AW |
410 | (cond |
411 | ((not first) '()) | |
412 | ((arity-is-case-lambda? first) | |
413 | (read-sub-arities context base (arity-header-offset first))) | |
414 | (else (list first))))))) | |
415 | ||
bec786c1 AW |
416 | (define* (find-program-arity addr #:optional |
417 | (context (find-debug-context addr))) | |
418 | (let lp ((arities (or (find-program-arities addr context) '()))) | |
419 | (match arities | |
420 | (() #f) | |
421 | ((arity . arities) | |
422 | (if (and (<= (arity-low-pc arity) addr) | |
423 | (< addr (arity-high-pc arity))) | |
424 | arity | |
425 | (lp arities)))))) | |
426 | ||
34cf09cc AW |
427 | (define* (find-program-minimum-arity addr #:optional |
428 | (context (find-debug-context addr))) | |
f88e574d | 429 | (and=> |
f8fb13ef AW |
430 | (and context |
431 | (elf-section-by-name (debug-context-elf context) ".guile.arities")) | |
f88e574d AW |
432 | (lambda (sec) |
433 | (let* ((base (elf-section-offset sec)) | |
434 | (first (find-first-arity context base addr))) | |
435 | (if (arity-is-case-lambda? first) | |
87342295 AW |
436 | (let ((arities (read-sub-arities context base |
437 | (arity-header-offset first)))) | |
438 | (and (pair? arities) | |
439 | (list (apply min (map arity-nreq arities)) | |
440 | 0 | |
441 | (or-map (lambda (arity) | |
442 | (or (positive? (arity-nopt arity)) | |
443 | (arity-has-rest? arity) | |
444 | (arity-has-keyword-args? arity) | |
445 | (arity-allow-other-keys? arity))) | |
446 | arities)))) | |
f88e574d AW |
447 | (list (arity-nreq first) |
448 | (arity-nopt first) | |
449 | (arity-has-rest? first))))))) | |
bf8328ec AW |
450 | |
451 | (define* (find-program-docstring addr #:optional | |
452 | (context (find-debug-context addr))) | |
453 | (and=> | |
f8fb13ef AW |
454 | (and context |
455 | (elf-section-by-name (debug-context-elf context) ".guile.docstrs")) | |
bf8328ec AW |
456 | (lambda (sec) |
457 | ;; struct docstr { | |
458 | ;; uint32_t pc; | |
459 | ;; uint32_t str; | |
460 | ;; } | |
d81658a7 AW |
461 | (let ((start (elf-section-offset sec)) |
462 | (bv (elf-bytes (debug-context-elf context))) | |
463 | (text-offset (- addr | |
464 | (debug-context-text-base context) | |
465 | (debug-context-base context)))) | |
466 | (binary-search | |
467 | start | |
468 | (+ start (elf-section-size sec)) | |
469 | 8 | |
470 | (lambda (pos continue-before continue-after) | |
471 | (let ((pc (bytevector-u32-native-ref bv pos))) | |
472 | (cond | |
473 | ((< text-offset pc) (continue-before)) | |
474 | ((< pc text-offset) (continue-after)) | |
475 | (else | |
476 | (let ((strtab (elf-section (debug-context-elf context) | |
477 | (elf-section-link sec))) | |
478 | (idx (bytevector-u32-native-ref bv (+ pos 4)))) | |
479 | (string-table-ref bv (+ (elf-section-offset strtab) idx))))))) | |
480 | (lambda () | |
481 | #f)))))) | |
c4c098e3 AW |
482 | |
483 | (define* (find-program-properties addr #:optional | |
484 | (context (find-debug-context addr))) | |
485 | (define (add-name-and-docstring props) | |
486 | (define (maybe-acons k v tail) | |
487 | (if v (acons k v tail) tail)) | |
488 | (let ((name (and=> (find-program-debug-info addr context) | |
489 | program-debug-info-name)) | |
490 | (docstring (find-program-docstring addr context))) | |
491 | (maybe-acons 'name name | |
492 | (maybe-acons 'documentation docstring props)))) | |
493 | (add-name-and-docstring | |
494 | (cond | |
f8fb13ef AW |
495 | ((and context |
496 | (elf-section-by-name (debug-context-elf context) ".guile.procprops")) | |
c4c098e3 AW |
497 | => (lambda (sec) |
498 | ;; struct procprop { | |
499 | ;; uint32_t pc; | |
500 | ;; uint32_t offset; | |
501 | ;; } | |
502 | (define procprop-len 8) | |
503 | (let* ((start (elf-section-offset sec)) | |
c4c098e3 AW |
504 | (bv (elf-bytes (debug-context-elf context))) |
505 | (text-offset (- addr | |
506 | (debug-context-text-base context) | |
507 | (debug-context-base context)))) | |
508 | (define (unpack-scm addr) | |
509 | (pointer->scm (make-pointer addr))) | |
510 | (define (load-non-immediate offset) | |
511 | (unpack-scm (+ (debug-context-base context) offset))) | |
05611075 AW |
512 | (binary-search |
513 | start (+ start (elf-section-size sec)) 8 | |
514 | (lambda (pos continue-before continue-after) | |
515 | (let ((pc (bytevector-u32-native-ref bv pos))) | |
516 | (cond | |
517 | ((< text-offset pc) (continue-before)) | |
518 | ((< pc text-offset) (continue-after)) | |
519 | (else | |
520 | (load-non-immediate | |
521 | (bytevector-u32-native-ref bv (+ pos 4))))))) | |
522 | (lambda () | |
523 | '()))))) | |
c0ada5a7 AW |
524 | (else '())))) |
525 | ||
526 | (define-record-type <source> | |
527 | (make-source pre-pc file line column) | |
528 | source? | |
529 | (pre-pc source-pre-pc) | |
530 | (file source-file) | |
531 | (line source-line) | |
532 | (column source-column)) | |
533 | ||
534 | (define (make-source/dwarf pc file line column) | |
535 | (make-source pc file | |
536 | ;; Convert DWARF-numbered (1-based) lines and | |
537 | ;; columns to Guile conventions (0-based). | |
538 | (and line (1- line)) (and column (1- column)))) | |
539 | ||
540 | ;; FIXME | |
541 | (define (source-post-pc source) | |
542 | (source-pre-pc source)) | |
543 | ||
544 | ;; Lines are zero-indexed inside Guile, but users expect them to be | |
545 | ;; one-indexed. Columns, on the other hand, are zero-indexed to both. Go | |
546 | ;; figure. | |
547 | (define (source-line-for-user source) | |
548 | (1+ (source-line source))) | |
549 | ||
550 | (define* (find-source-for-addr addr #:optional | |
551 | (context (find-debug-context addr)) | |
552 | #:key exact?) | |
f8fb13ef AW |
553 | (and=> |
554 | (and context | |
555 | (false-if-exception | |
556 | (elf->dwarf-context (debug-context-elf context)))) | |
557 | (lambda (dwarf-ctx) | |
558 | (let* ((base (debug-context-base context)) | |
559 | (pc (- addr base))) | |
c0ada5a7 AW |
560 | (or-map (lambda (die) |
561 | (and=> | |
562 | (die-line-prog die) | |
563 | (lambda (prog) | |
564 | (call-with-values | |
565 | (lambda () (line-prog-scan-to-pc prog pc)) | |
566 | (lambda (pc* file line col) | |
567 | (and pc* (or (= pc pc*) (not exact?)) | |
568 | (make-source/dwarf (+ pc* base) | |
569 | file line col))))))) | |
570 | (read-die-roots dwarf-ctx)))))) | |
571 | ||
572 | (define* (find-program-die addr #:optional | |
573 | (context (find-debug-context addr))) | |
f8fb13ef AW |
574 | (and=> (and context |
575 | (false-if-exception | |
576 | (elf->dwarf-context (debug-context-elf context)))) | |
c0ada5a7 AW |
577 | (lambda (dwarf-ctx) |
578 | (find-die-by-pc (read-die-roots dwarf-ctx) | |
579 | (- addr (debug-context-base context)))))) | |
580 | ||
581 | (define* (find-program-sources addr #:optional | |
582 | (context (find-debug-context addr))) | |
f8fb13ef AW |
583 | (cond |
584 | ((find-program-die addr context) | |
585 | => (lambda (die) | |
586 | (let* ((base (debug-context-base context)) | |
587 | (low-pc (die-ref die 'low-pc)) | |
588 | (high-pc (die-high-pc die)) | |
589 | (prog (let line-prog ((die die)) | |
590 | (and die | |
591 | (or (die-line-prog die) | |
592 | (line-prog (ctx-die (die-ctx die)))))))) | |
593 | (cond | |
594 | ((and low-pc high-pc prog) | |
595 | (let lp ((sources '())) | |
596 | (call-with-values (lambda () | |
597 | (if (null? sources) | |
598 | (line-prog-scan-to-pc prog low-pc) | |
599 | (line-prog-advance prog))) | |
600 | (lambda (pc file line col) | |
601 | (if (and pc (< pc high-pc)) | |
963d95f1 AW |
602 | ;; For the first source, it's probable that the |
603 | ;; address of the line program is before the | |
604 | ;; low-pc, since the line program is for the | |
605 | ;; entire compilation unit, and there are no | |
606 | ;; redundant "rows" in the line program. | |
607 | ;; Therefore in that case use the addr of low-pc | |
608 | ;; instead of the one we got back. | |
609 | (let ((addr (+ (if (null? sources) low-pc pc) base))) | |
610 | (lp (cons (make-source/dwarf addr file line col) | |
611 | sources))) | |
f8fb13ef AW |
612 | (reverse sources)))))) |
613 | (else '()))))) | |
614 | (else '()))) | |
0128bb9c AW |
615 | |
616 | (define* (fold-source-locations proc seed context) | |
617 | "Fold @var{proc} over all source locations in @var{context}. | |
618 | @var{proc} will be called with two arguments: the source object and the | |
619 | seed." | |
620 | (cond | |
621 | ((and context | |
622 | (false-if-exception | |
623 | (elf->dwarf-context (debug-context-elf context)))) | |
624 | => | |
625 | (lambda (dwarf-ctx) | |
626 | (let ((base (debug-context-base context))) | |
627 | (fold | |
628 | (lambda (die seed) | |
629 | (cond | |
630 | ((die-line-prog die) | |
631 | => | |
632 | (lambda (prog) | |
633 | (let lp ((seed seed)) | |
634 | (call-with-values | |
635 | (lambda () (line-prog-advance prog)) | |
636 | (lambda (pc* file line col) | |
637 | (if pc* | |
638 | (lp | |
639 | (proc (make-source/dwarf (+ pc* base) file line col) | |
640 | seed)) | |
641 | seed)))))) | |
642 | (else seed))) | |
643 | seed | |
644 | (read-die-roots dwarf-ctx))))) | |
645 | (else seed))) |