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) | |
c3651bd5 | 34 | #:use-module ((srfi srfi-1) #:select (fold split-at)) |
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 | |
c3651bd5 | 55 | arity-nlocals |
f88e574d AW |
56 | arity-has-rest? |
57 | arity-allow-other-keys? | |
58 | arity-has-keyword-args? | |
bec786c1 | 59 | arity-keyword-args |
f88e574d | 60 | arity-is-case-lambda? |
f9425c80 | 61 | arity-definitions |
bc5bcf66 | 62 | arity-code |
f88e574d | 63 | |
610295ec | 64 | debug-context-from-image |
0128bb9c | 65 | fold-all-debug-contexts |
610295ec | 66 | for-each-elf-symbol |
cb86cbd7 | 67 | find-debug-context |
f88e574d AW |
68 | find-program-debug-info |
69 | arity-arguments-alist | |
eb2bc00f | 70 | find-program-arities |
bec786c1 | 71 | find-program-arity |
34cf09cc | 72 | find-program-minimum-arity |
bf8328ec | 73 | |
c4c098e3 AW |
74 | find-program-docstring |
75 | ||
c0ada5a7 AW |
76 | find-program-properties |
77 | ||
78 | source? | |
79 | source-pre-pc | |
80 | source-post-pc | |
81 | source-file | |
82 | source-line | |
83 | source-line-for-user | |
84 | source-column | |
85 | find-source-for-addr | |
0128bb9c AW |
86 | find-program-sources |
87 | fold-source-locations)) | |
cb86cbd7 AW |
88 | |
89 | ;;; A compiled procedure comes from a specific loaded ELF image. A | |
90 | ;;; debug context identifies that image. | |
91 | ;;; | |
92 | (define-record-type <debug-context> | |
93 | (make-debug-context elf base text-base) | |
94 | debug-context? | |
95 | (elf debug-context-elf) | |
96 | ;; Address at which this image is loaded in memory, in bytes. | |
97 | (base debug-context-base) | |
98 | ;; Offset of the text section relative to the image start, in bytes. | |
99 | (text-base debug-context-text-base)) | |
100 | ||
101 | (define (debug-context-image context) | |
102 | "Return the bytevector aliasing the mapped ELF image corresponding to | |
103 | @var{context}." | |
104 | (elf-bytes (debug-context-elf context))) | |
105 | ||
581a4eb8 AW |
106 | (define (debug-context-length context) |
107 | "Return the size of the mapped ELF image corresponding to | |
108 | @var{context}, in bytes." | |
109 | (bytevector-length (debug-context-image context))) | |
110 | ||
610295ec AW |
111 | (define (for-each-elf-symbol context proc) |
112 | "Call @var{proc} on each symbol in the symbol table of @var{context}." | |
113 | (let ((elf (debug-context-elf context))) | |
114 | (cond | |
115 | ((elf-section-by-name elf ".symtab") | |
116 | => (lambda (symtab) | |
117 | (let ((len (elf-symbol-table-len symtab)) | |
118 | (strtab (elf-section elf (elf-section-link symtab)))) | |
119 | (let lp ((n 0)) | |
120 | (when (< n len) | |
121 | (proc (elf-symbol-table-ref elf symtab n strtab)) | |
122 | (lp (1+ n)))))))))) | |
123 | ||
cb86cbd7 AW |
124 | ;;; A program debug info (PDI) is a handle on debugging meta-data for a |
125 | ;;; particular program. | |
126 | ;;; | |
127 | (define-record-type <program-debug-info> | |
128 | (make-program-debug-info context name offset size) | |
129 | program-debug-info? | |
130 | (context program-debug-info-context) | |
131 | (name program-debug-info-name) | |
132 | ;; Offset of the procedure in the text section, in bytes. | |
133 | (offset program-debug-info-offset) | |
134 | (size program-debug-info-size)) | |
135 | ||
136 | (define (program-debug-info-addr pdi) | |
137 | "Return the address in memory of the entry of the program represented | |
138 | by the debugging info @var{pdi}." | |
139 | (+ (program-debug-info-offset pdi) | |
140 | (debug-context-text-base (program-debug-info-context pdi)) | |
141 | (debug-context-base (program-debug-info-context pdi)))) | |
142 | ||
143 | (define (program-debug-info-image pdi) | |
144 | "Return the ELF image containing @var{pdi}, as a bytevector." | |
145 | (debug-context-image (program-debug-info-context pdi))) | |
146 | ||
147 | (define (program-debug-info-u32-offset pdi) | |
148 | "Return the start address of the program represented by @var{pdi}, as | |
149 | an offset from the beginning of the ELF image in 32-bit units." | |
150 | (/ (+ (program-debug-info-offset pdi) | |
151 | (debug-context-text-base (program-debug-info-context pdi))) | |
152 | 4)) | |
153 | ||
154 | (define (program-debug-info-u32-offset-end pdi) | |
155 | "Return the end address of the program represented by @var{pdi}, as an | |
156 | offset from the beginning of the ELF image in 32-bit units." | |
157 | (/ (+ (program-debug-info-size pdi) | |
158 | (program-debug-info-offset pdi) | |
159 | (debug-context-text-base (program-debug-info-context pdi))) | |
160 | 4)) | |
161 | ||
610295ec AW |
162 | (define (debug-context-from-image bv) |
163 | "Build a debugging context corresponding to a given ELF image." | |
164 | (let* ((elf (parse-elf bv)) | |
cb86cbd7 AW |
165 | (base (pointer-address (bytevector->pointer (elf-bytes elf)))) |
166 | (text-base (elf-section-offset | |
167 | (or (elf-section-by-name elf ".rtl-text") | |
168 | (error "ELF object has no text section"))))) | |
169 | (make-debug-context elf base text-base))) | |
170 | ||
0128bb9c AW |
171 | (define (fold-all-debug-contexts proc seed) |
172 | "Fold @var{proc} over debug contexts corresponding to all images that | |
173 | are mapped at the time this procedure is called. Any images mapped | |
174 | during the fold are omitted." | |
175 | (fold (lambda (image seed) | |
176 | (proc (debug-context-from-image image) seed)) | |
177 | seed | |
178 | (all-mapped-elf-images))) | |
179 | ||
610295ec AW |
180 | (define (find-debug-context addr) |
181 | "Find and return the debugging context corresponding to the ELF image | |
f8fb13ef | 182 | containing the address @var{addr}. @var{addr} is an integer. If no ELF |
691697de AW |
183 | image is found, return @code{#f}. It's possible for an bytecode program |
184 | not to have an ELF image if the program was defined in as a stub in C." | |
f8fb13ef AW |
185 | (and=> (find-mapped-elf-image addr) |
186 | debug-context-from-image)) | |
610295ec | 187 | |
695e6b75 AW |
188 | (define-inlinable (binary-search start end inc try failure) |
189 | (let lp ((start start) (end end)) | |
190 | (if (eqv? start end) | |
191 | (failure) | |
192 | (let ((mid (+ start (* inc (floor/ (- end start) (* 2 inc)))))) | |
193 | (try mid | |
194 | (lambda () | |
195 | (lp start mid)) | |
196 | (lambda () | |
197 | (lp (+ mid inc) end))))))) | |
198 | ||
cb86cbd7 AW |
199 | (define (find-elf-symbol elf text-offset) |
200 | "Search the symbol table of @var{elf} for the ELF symbol containing | |
201 | @var{text-offset}. @var{text-offset} is a byte offset in the text | |
202 | section of the ELF image. Returns an ELF symbol, or @code{#f}." | |
203 | (and=> | |
204 | (elf-section-by-name elf ".symtab") | |
205 | (lambda (symtab) | |
695e6b75 AW |
206 | (let ((strtab (elf-section elf (elf-section-link symtab)))) |
207 | (binary-search | |
208 | 0 (elf-symbol-table-len symtab) 1 | |
209 | (lambda (n continue-before continue-after) | |
210 | (let* ((sym (elf-symbol-table-ref elf symtab n strtab)) | |
211 | (val (elf-symbol-value sym)) | |
212 | (size (elf-symbol-size sym))) | |
213 | (cond | |
214 | ((< text-offset val) (continue-before)) | |
215 | ((<= (+ val size) text-offset) (continue-after)) | |
216 | (else sym)))) | |
217 | (lambda () | |
218 | #f)))))) | |
cb86cbd7 AW |
219 | |
220 | (define* (find-program-debug-info addr #:optional | |
221 | (context (find-debug-context addr))) | |
222 | "Find and return the @code{<program-debug-info>} containing | |
223 | @var{addr}, or @code{#f}." | |
224 | (cond | |
f8fb13ef AW |
225 | ((and context |
226 | (find-elf-symbol (debug-context-elf context) | |
227 | (- addr | |
228 | (debug-context-base context) | |
229 | (debug-context-text-base context)))) | |
cb86cbd7 AW |
230 | => (lambda (sym) |
231 | (make-program-debug-info context | |
232 | (and=> (elf-symbol-name sym) | |
233 | ;; The name might be #f if | |
234 | ;; the string table was | |
235 | ;; stripped somehow. | |
236 | (lambda (x) | |
237 | (and (string? x) | |
238 | (not (string-null? x)) | |
239 | (string->symbol x)))) | |
240 | (elf-symbol-value sym) | |
241 | (elf-symbol-size sym)))) | |
242 | (else #f))) | |
f88e574d AW |
243 | |
244 | (define-record-type <arity> | |
245 | (make-arity context base header-offset) | |
246 | arity? | |
247 | (context arity-context) | |
248 | (base arity-base) | |
249 | (header-offset arity-header-offset)) | |
250 | ||
251 | (define arities-prefix-len 4) | |
c3651bd5 | 252 | (define arity-header-len (* 7 4)) |
f88e574d AW |
253 | |
254 | ;;; struct arity_header { | |
255 | ;;; uint32_t low_pc; | |
256 | ;;; uint32_t high_pc; | |
257 | ;;; uint32_t offset; | |
258 | ;;; uint32_t flags; | |
259 | ;;; uint32_t nreq; | |
260 | ;;; uint32_t nopt; | |
c3651bd5 | 261 | ;;; uint32_t nlocals; |
f88e574d AW |
262 | ;;; } |
263 | ||
264 | (define (arity-low-pc* bv header-pos) | |
265 | (bytevector-u32-native-ref bv (+ header-pos (* 0 4)))) | |
266 | (define (arity-high-pc* bv header-pos) | |
267 | (bytevector-u32-native-ref bv (+ header-pos (* 1 4)))) | |
268 | (define (arity-offset* bv header-pos) | |
269 | (bytevector-u32-native-ref bv (+ header-pos (* 2 4)))) | |
270 | (define (arity-flags* bv header-pos) | |
271 | (bytevector-u32-native-ref bv (+ header-pos (* 3 4)))) | |
272 | (define (arity-nreq* bv header-pos) | |
273 | (bytevector-u32-native-ref bv (+ header-pos (* 4 4)))) | |
274 | (define (arity-nopt* bv header-pos) | |
275 | (bytevector-u32-native-ref bv (+ header-pos (* 5 4)))) | |
c3651bd5 AW |
276 | (define (arity-nlocals* bv header-pos) |
277 | (bytevector-u32-native-ref bv (+ header-pos (* 6 4)))) | |
f88e574d AW |
278 | |
279 | ;;; #x1: has-rest? | |
280 | ;;; #x2: allow-other-keys? | |
281 | ;;; #x4: has-keyword-args? | |
282 | ;;; #x8: is-case-lambda? | |
d8595af5 | 283 | ;;; #x10: is-in-case-lambda? |
f88e574d AW |
284 | |
285 | (define (has-rest? flags) (not (zero? (logand flags (ash 1 0))))) | |
286 | (define (allow-other-keys? flags) (not (zero? (logand flags (ash 1 1))))) | |
287 | (define (has-keyword-args? flags) (not (zero? (logand flags (ash 1 2))))) | |
288 | (define (is-case-lambda? flags) (not (zero? (logand flags (ash 1 3))))) | |
d8595af5 | 289 | (define (is-in-case-lambda? flags) (not (zero? (logand flags (ash 1 4))))) |
f88e574d | 290 | |
9dff1df9 | 291 | (define (arity-low-pc arity) |
0e3a59f7 AW |
292 | (let ((ctx (arity-context arity))) |
293 | (+ (debug-context-base ctx) | |
294 | (debug-context-text-base ctx) | |
295 | (arity-low-pc* (elf-bytes (debug-context-elf ctx)) | |
296 | (arity-header-offset arity))))) | |
9dff1df9 AW |
297 | |
298 | (define (arity-high-pc arity) | |
0e3a59f7 AW |
299 | (let ((ctx (arity-context arity))) |
300 | (+ (debug-context-base ctx) | |
301 | (debug-context-text-base ctx) | |
302 | (arity-high-pc* (elf-bytes (debug-context-elf ctx)) | |
303 | (arity-header-offset arity))))) | |
9dff1df9 | 304 | |
f88e574d AW |
305 | (define (arity-nreq arity) |
306 | (arity-nreq* (elf-bytes (debug-context-elf (arity-context arity))) | |
307 | (arity-header-offset arity))) | |
308 | ||
309 | (define (arity-nopt arity) | |
310 | (arity-nopt* (elf-bytes (debug-context-elf (arity-context arity))) | |
311 | (arity-header-offset arity))) | |
312 | ||
c3651bd5 AW |
313 | (define (arity-nlocals arity) |
314 | (arity-nlocals* (elf-bytes (debug-context-elf (arity-context arity))) | |
315 | (arity-header-offset arity))) | |
316 | ||
f88e574d AW |
317 | (define (arity-flags arity) |
318 | (arity-flags* (elf-bytes (debug-context-elf (arity-context arity))) | |
319 | (arity-header-offset arity))) | |
320 | ||
321 | (define (arity-has-rest? arity) (has-rest? (arity-flags arity))) | |
322 | (define (arity-allow-other-keys? arity) (allow-other-keys? (arity-flags arity))) | |
323 | (define (arity-has-keyword-args? arity) (has-keyword-args? (arity-flags arity))) | |
324 | (define (arity-is-case-lambda? arity) (is-case-lambda? (arity-flags arity))) | |
d8595af5 | 325 | (define (arity-is-in-case-lambda? arity) (is-in-case-lambda? (arity-flags arity))) |
f88e574d | 326 | |
c3651bd5 AW |
327 | (define (arity-keyword-args arity) |
328 | (define (unpack-scm n) | |
329 | (pointer->scm (make-pointer n))) | |
330 | (if (arity-has-keyword-args? arity) | |
331 | (let* ((bv (elf-bytes (debug-context-elf (arity-context arity)))) | |
332 | (header (arity-header-offset arity)) | |
333 | (link-offset (arity-offset* bv header)) | |
334 | (link (+ (arity-base arity) link-offset)) | |
335 | (offset (bytevector-u32-native-ref bv link))) | |
336 | (unpack-scm (+ (debug-context-base (arity-context arity)) offset))) | |
337 | '())) | |
338 | ||
f88e574d AW |
339 | (define (arity-load-symbol arity) |
340 | (let ((elf (debug-context-elf (arity-context arity)))) | |
341 | (cond | |
342 | ((elf-section-by-name elf ".guile.arities") | |
343 | => | |
344 | (lambda (sec) | |
345 | (let* ((strtab (elf-section elf (elf-section-link sec))) | |
346 | (bv (elf-bytes elf)) | |
347 | (strtab-offset (elf-section-offset strtab))) | |
348 | (lambda (n) | |
349 | (string->symbol (string-table-ref bv (+ strtab-offset n))))))) | |
350 | (else (error "couldn't find arities section"))))) | |
351 | ||
f9425c80 AW |
352 | (define* (arity-definitions arity) |
353 | (let* ((bv (elf-bytes (debug-context-elf (arity-context arity)))) | |
354 | (load-symbol (arity-load-symbol arity)) | |
355 | (header (arity-header-offset arity)) | |
356 | (nlocals (arity-nlocals* bv header)) | |
357 | (flags (arity-flags* bv header)) | |
358 | (link-offset (arity-offset* bv header)) | |
359 | (link (+ (arity-base arity) | |
360 | link-offset | |
361 | (if (has-keyword-args? flags) 4 0)))) | |
362 | (define (read-uleb128 bv pos) | |
363 | ;; Unrolled by one. | |
364 | (let ((b (bytevector-u8-ref bv pos))) | |
365 | (if (zero? (logand b #x80)) | |
366 | (values b | |
367 | (1+ pos)) | |
368 | (let lp ((n (logxor #x80 b)) (pos (1+ pos)) (shift 7)) | |
369 | (let ((b (bytevector-u8-ref bv pos))) | |
370 | (if (zero? (logand b #x80)) | |
371 | (values (logior (ash b shift) n) | |
372 | (1+ pos)) | |
373 | (lp (logior (ash (logxor #x80 b) shift) n) | |
374 | (1+ pos) | |
375 | (+ shift 7)))))))) | |
376 | (define (load-definitions pos names) | |
377 | (let lp ((pos pos) (names names)) | |
378 | (match names | |
379 | (() '()) | |
380 | ((name . names) | |
381 | (call-with-values (lambda () (read-uleb128 bv pos)) | |
382 | (lambda (def-offset pos) | |
383 | (call-with-values (lambda () (read-uleb128 bv pos)) | |
384 | (lambda (slot pos) | |
385 | (cons (vector name def-offset slot) | |
386 | (lp pos names)))))))))) | |
387 | (define (load-symbols pos) | |
388 | (let lp ((pos pos) (n nlocals) (out '())) | |
389 | (if (zero? n) | |
390 | (load-definitions pos (reverse out)) | |
391 | (call-with-values (lambda () (read-uleb128 bv pos)) | |
392 | (lambda (strtab-offset pos) | |
393 | strtab-offset | |
394 | (lp pos | |
395 | (1- n) | |
396 | (cons (if (zero? strtab-offset) | |
397 | #f | |
398 | (load-symbol strtab-offset)) | |
399 | out))))))) | |
400 | (when (is-case-lambda? flags) | |
401 | (error "invalid request for definitions of case-lambda wrapper arity")) | |
402 | (load-symbols link))) | |
403 | ||
bc5bcf66 AW |
404 | (define (arity-code arity) |
405 | (let* ((ctx (arity-context arity)) | |
406 | (bv (elf-bytes (debug-context-elf ctx))) | |
407 | (header (arity-header-offset arity)) | |
408 | (base-addr (+ (debug-context-base ctx) (debug-context-text-base ctx))) | |
409 | (low-pc (+ base-addr (arity-low-pc* bv header))) | |
410 | (high-pc (+ base-addr (arity-high-pc* bv header)))) | |
411 | ;; FIXME: We should be able to use a sub-bytevector operation here; | |
412 | ;; it would be safer. | |
413 | (pointer->bytevector (make-pointer low-pc) (- high-pc low-pc)))) | |
414 | ||
c3651bd5 | 415 | (define* (arity-locals arity #:optional nlocals) |
f88e574d | 416 | (let* ((bv (elf-bytes (debug-context-elf (arity-context arity)))) |
c3651bd5 | 417 | (load-symbol (arity-load-symbol arity)) |
f88e574d | 418 | (header (arity-header-offset arity)) |
c3651bd5 AW |
419 | (nlocals (if nlocals |
420 | (if (<= 0 nlocals (arity-nlocals* bv header)) | |
421 | nlocals | |
422 | (error "request for too many locals")) | |
423 | (arity-nlocals* bv header))) | |
f88e574d | 424 | (flags (arity-flags* bv header)) |
cade4c8f AW |
425 | (link-offset (arity-offset* bv header)) |
426 | (link (+ (arity-base arity) | |
427 | link-offset | |
428 | (if (has-keyword-args? flags) 4 0)))) | |
c3651bd5 AW |
429 | (define (read-uleb128 bv pos) |
430 | ;; Unrolled by one. | |
431 | (let ((b (bytevector-u8-ref bv pos))) | |
432 | (if (zero? (logand b #x80)) | |
433 | (values b | |
434 | (1+ pos)) | |
435 | (let lp ((n (logxor #x80 b)) (pos (1+ pos)) (shift 7)) | |
436 | (let ((b (bytevector-u8-ref bv pos))) | |
437 | (if (zero? (logand b #x80)) | |
438 | (values (logior (ash b shift) n) | |
439 | (1+ pos)) | |
440 | (lp (logior (ash (logxor #x80 b) shift) n) | |
441 | (1+ pos) | |
442 | (+ shift 7)))))))) | |
443 | (define (load-symbols pos n) | |
444 | (let lp ((pos pos) (n n) (out '())) | |
f88e574d | 445 | (if (zero? n) |
c3651bd5 AW |
446 | (reverse out) |
447 | (call-with-values (lambda () (read-uleb128 bv pos)) | |
448 | (lambda (strtab-offset pos) | |
449 | strtab-offset | |
450 | (lp pos | |
451 | (1- n) | |
452 | (cons (if (zero? strtab-offset) | |
453 | #f | |
454 | (load-symbol strtab-offset)) | |
455 | out))))))) | |
456 | (when (is-case-lambda? flags) | |
457 | (error "invalid request for locals of case-lambda wrapper arity")) | |
458 | (load-symbols link nlocals))) | |
459 | ||
460 | (define (arity-arguments-alist arity) | |
461 | (let* ((bv (elf-bytes (debug-context-elf (arity-context arity)))) | |
462 | (header (arity-header-offset arity)) | |
463 | (flags (arity-flags* bv header)) | |
464 | (nreq (arity-nreq* bv header)) | |
465 | (nopt (arity-nopt* bv header)) | |
466 | (nargs (+ nreq nopt (if (has-rest? flags) 1 0)))) | |
467 | (when (is-case-lambda? flags) | |
468 | (error "invalid request for locals of case-lambda wrapper arity")) | |
469 | (let ((args (arity-locals arity nargs))) | |
470 | (call-with-values (lambda () (split-at args nreq)) | |
471 | (lambda (req args) | |
472 | (call-with-values (lambda () (split-at args nopt)) | |
473 | (lambda (opt args) | |
474 | `((required . ,req) | |
475 | (optional . ,opt) | |
476 | (keyword . ,(arity-keyword-args arity)) | |
477 | (allow-other-keys? . ,(allow-other-keys? flags)) | |
478 | (rest . ,(and (has-rest? flags) (car args))))))))))) | |
f88e574d AW |
479 | |
480 | (define (find-first-arity context base addr) | |
481 | (let* ((bv (elf-bytes (debug-context-elf context))) | |
482 | (text-offset (- addr | |
483 | (debug-context-text-base context) | |
d8595af5 AW |
484 | (debug-context-base context)))) |
485 | (binary-search | |
486 | (+ base arities-prefix-len) | |
487 | (+ base (bytevector-u32-native-ref bv base)) | |
488 | arity-header-len | |
489 | (lambda (pos continue-before continue-after) | |
490 | (let lp ((pos pos)) | |
491 | (cond | |
492 | ((is-in-case-lambda? (arity-flags* bv pos)) | |
493 | (lp (- pos arity-header-len))) | |
494 | ((< text-offset (arity-low-pc* bv pos)) | |
495 | (continue-before)) | |
496 | ((<= (arity-high-pc* bv pos) text-offset) | |
497 | (continue-after)) | |
498 | (else | |
499 | (make-arity context base pos))))) | |
500 | (lambda () | |
501 | #f)))) | |
f88e574d AW |
502 | |
503 | (define (read-sub-arities context base outer-header-offset) | |
504 | (let* ((bv (elf-bytes (debug-context-elf context))) | |
505 | (headers-end (+ base (bytevector-u32-native-ref bv base))) | |
506 | (low-pc (arity-low-pc* bv outer-header-offset)) | |
507 | (high-pc (arity-high-pc* bv outer-header-offset))) | |
508 | (let lp ((pos (+ outer-header-offset arity-header-len)) (out '())) | |
509 | (if (and (< pos headers-end) (<= (arity-high-pc* bv pos) high-pc)) | |
510 | (lp (+ pos arity-header-len) | |
511 | (cons (make-arity context base pos) out)) | |
512 | (reverse out))))) | |
513 | ||
514 | (define* (find-program-arities addr #:optional | |
515 | (context (find-debug-context addr))) | |
516 | (and=> | |
f8fb13ef AW |
517 | (and context |
518 | (elf-section-by-name (debug-context-elf context) ".guile.arities")) | |
f88e574d AW |
519 | (lambda (sec) |
520 | (let* ((base (elf-section-offset sec)) | |
521 | (first (find-first-arity context base addr))) | |
f88e574d AW |
522 | (cond |
523 | ((not first) '()) | |
524 | ((arity-is-case-lambda? first) | |
525 | (read-sub-arities context base (arity-header-offset first))) | |
526 | (else (list first))))))) | |
527 | ||
bec786c1 AW |
528 | (define* (find-program-arity addr #:optional |
529 | (context (find-debug-context addr))) | |
530 | (let lp ((arities (or (find-program-arities addr context) '()))) | |
531 | (match arities | |
532 | (() #f) | |
533 | ((arity . arities) | |
534 | (if (and (<= (arity-low-pc arity) addr) | |
535 | (< addr (arity-high-pc arity))) | |
536 | arity | |
537 | (lp arities)))))) | |
538 | ||
34cf09cc AW |
539 | (define* (find-program-minimum-arity addr #:optional |
540 | (context (find-debug-context addr))) | |
f88e574d | 541 | (and=> |
f8fb13ef AW |
542 | (and context |
543 | (elf-section-by-name (debug-context-elf context) ".guile.arities")) | |
f88e574d AW |
544 | (lambda (sec) |
545 | (let* ((base (elf-section-offset sec)) | |
546 | (first (find-first-arity context base addr))) | |
547 | (if (arity-is-case-lambda? first) | |
87342295 AW |
548 | (let ((arities (read-sub-arities context base |
549 | (arity-header-offset first)))) | |
550 | (and (pair? arities) | |
551 | (list (apply min (map arity-nreq arities)) | |
552 | 0 | |
553 | (or-map (lambda (arity) | |
554 | (or (positive? (arity-nopt arity)) | |
555 | (arity-has-rest? arity) | |
556 | (arity-has-keyword-args? arity) | |
557 | (arity-allow-other-keys? arity))) | |
558 | arities)))) | |
f88e574d AW |
559 | (list (arity-nreq first) |
560 | (arity-nopt first) | |
561 | (arity-has-rest? first))))))) | |
bf8328ec AW |
562 | |
563 | (define* (find-program-docstring addr #:optional | |
564 | (context (find-debug-context addr))) | |
565 | (and=> | |
f8fb13ef AW |
566 | (and context |
567 | (elf-section-by-name (debug-context-elf context) ".guile.docstrs")) | |
bf8328ec AW |
568 | (lambda (sec) |
569 | ;; struct docstr { | |
570 | ;; uint32_t pc; | |
571 | ;; uint32_t str; | |
572 | ;; } | |
d81658a7 AW |
573 | (let ((start (elf-section-offset sec)) |
574 | (bv (elf-bytes (debug-context-elf context))) | |
575 | (text-offset (- addr | |
576 | (debug-context-text-base context) | |
577 | (debug-context-base context)))) | |
578 | (binary-search | |
579 | start | |
580 | (+ start (elf-section-size sec)) | |
581 | 8 | |
582 | (lambda (pos continue-before continue-after) | |
583 | (let ((pc (bytevector-u32-native-ref bv pos))) | |
584 | (cond | |
585 | ((< text-offset pc) (continue-before)) | |
586 | ((< pc text-offset) (continue-after)) | |
587 | (else | |
588 | (let ((strtab (elf-section (debug-context-elf context) | |
589 | (elf-section-link sec))) | |
590 | (idx (bytevector-u32-native-ref bv (+ pos 4)))) | |
591 | (string-table-ref bv (+ (elf-section-offset strtab) idx))))))) | |
592 | (lambda () | |
593 | #f)))))) | |
c4c098e3 AW |
594 | |
595 | (define* (find-program-properties addr #:optional | |
596 | (context (find-debug-context addr))) | |
597 | (define (add-name-and-docstring props) | |
598 | (define (maybe-acons k v tail) | |
599 | (if v (acons k v tail) tail)) | |
600 | (let ((name (and=> (find-program-debug-info addr context) | |
601 | program-debug-info-name)) | |
602 | (docstring (find-program-docstring addr context))) | |
603 | (maybe-acons 'name name | |
604 | (maybe-acons 'documentation docstring props)))) | |
605 | (add-name-and-docstring | |
606 | (cond | |
f8fb13ef AW |
607 | ((and context |
608 | (elf-section-by-name (debug-context-elf context) ".guile.procprops")) | |
c4c098e3 AW |
609 | => (lambda (sec) |
610 | ;; struct procprop { | |
611 | ;; uint32_t pc; | |
612 | ;; uint32_t offset; | |
613 | ;; } | |
614 | (define procprop-len 8) | |
615 | (let* ((start (elf-section-offset sec)) | |
c4c098e3 AW |
616 | (bv (elf-bytes (debug-context-elf context))) |
617 | (text-offset (- addr | |
618 | (debug-context-text-base context) | |
619 | (debug-context-base context)))) | |
620 | (define (unpack-scm addr) | |
621 | (pointer->scm (make-pointer addr))) | |
622 | (define (load-non-immediate offset) | |
623 | (unpack-scm (+ (debug-context-base context) offset))) | |
05611075 AW |
624 | (binary-search |
625 | start (+ start (elf-section-size sec)) 8 | |
626 | (lambda (pos continue-before continue-after) | |
627 | (let ((pc (bytevector-u32-native-ref bv pos))) | |
628 | (cond | |
629 | ((< text-offset pc) (continue-before)) | |
630 | ((< pc text-offset) (continue-after)) | |
631 | (else | |
632 | (load-non-immediate | |
633 | (bytevector-u32-native-ref bv (+ pos 4))))))) | |
634 | (lambda () | |
635 | '()))))) | |
c0ada5a7 AW |
636 | (else '())))) |
637 | ||
638 | (define-record-type <source> | |
639 | (make-source pre-pc file line column) | |
640 | source? | |
641 | (pre-pc source-pre-pc) | |
642 | (file source-file) | |
643 | (line source-line) | |
644 | (column source-column)) | |
645 | ||
646 | (define (make-source/dwarf pc file line column) | |
647 | (make-source pc file | |
648 | ;; Convert DWARF-numbered (1-based) lines and | |
649 | ;; columns to Guile conventions (0-based). | |
650 | (and line (1- line)) (and column (1- column)))) | |
651 | ||
652 | ;; FIXME | |
653 | (define (source-post-pc source) | |
654 | (source-pre-pc source)) | |
655 | ||
656 | ;; Lines are zero-indexed inside Guile, but users expect them to be | |
657 | ;; one-indexed. Columns, on the other hand, are zero-indexed to both. Go | |
658 | ;; figure. | |
659 | (define (source-line-for-user source) | |
660 | (1+ (source-line source))) | |
661 | ||
662 | (define* (find-source-for-addr addr #:optional | |
663 | (context (find-debug-context addr)) | |
664 | #:key exact?) | |
f8fb13ef AW |
665 | (and=> |
666 | (and context | |
667 | (false-if-exception | |
668 | (elf->dwarf-context (debug-context-elf context)))) | |
669 | (lambda (dwarf-ctx) | |
670 | (let* ((base (debug-context-base context)) | |
671 | (pc (- addr base))) | |
c0ada5a7 AW |
672 | (or-map (lambda (die) |
673 | (and=> | |
674 | (die-line-prog die) | |
675 | (lambda (prog) | |
676 | (call-with-values | |
677 | (lambda () (line-prog-scan-to-pc prog pc)) | |
678 | (lambda (pc* file line col) | |
679 | (and pc* (or (= pc pc*) (not exact?)) | |
680 | (make-source/dwarf (+ pc* base) | |
681 | file line col))))))) | |
682 | (read-die-roots dwarf-ctx)))))) | |
683 | ||
684 | (define* (find-program-die addr #:optional | |
685 | (context (find-debug-context addr))) | |
f8fb13ef AW |
686 | (and=> (and context |
687 | (false-if-exception | |
688 | (elf->dwarf-context (debug-context-elf context)))) | |
c0ada5a7 AW |
689 | (lambda (dwarf-ctx) |
690 | (find-die-by-pc (read-die-roots dwarf-ctx) | |
691 | (- addr (debug-context-base context)))))) | |
692 | ||
693 | (define* (find-program-sources addr #:optional | |
694 | (context (find-debug-context addr))) | |
f8fb13ef AW |
695 | (cond |
696 | ((find-program-die addr context) | |
697 | => (lambda (die) | |
698 | (let* ((base (debug-context-base context)) | |
699 | (low-pc (die-ref die 'low-pc)) | |
700 | (high-pc (die-high-pc die)) | |
701 | (prog (let line-prog ((die die)) | |
702 | (and die | |
703 | (or (die-line-prog die) | |
704 | (line-prog (ctx-die (die-ctx die)))))))) | |
705 | (cond | |
706 | ((and low-pc high-pc prog) | |
707 | (let lp ((sources '())) | |
708 | (call-with-values (lambda () | |
709 | (if (null? sources) | |
710 | (line-prog-scan-to-pc prog low-pc) | |
711 | (line-prog-advance prog))) | |
712 | (lambda (pc file line col) | |
713 | (if (and pc (< pc high-pc)) | |
963d95f1 AW |
714 | ;; For the first source, it's probable that the |
715 | ;; address of the line program is before the | |
716 | ;; low-pc, since the line program is for the | |
717 | ;; entire compilation unit, and there are no | |
718 | ;; redundant "rows" in the line program. | |
719 | ;; Therefore in that case use the addr of low-pc | |
720 | ;; instead of the one we got back. | |
721 | (let ((addr (+ (if (null? sources) low-pc pc) base))) | |
722 | (lp (cons (make-source/dwarf addr file line col) | |
723 | sources))) | |
f8fb13ef AW |
724 | (reverse sources)))))) |
725 | (else '()))))) | |
726 | (else '()))) | |
0128bb9c AW |
727 | |
728 | (define* (fold-source-locations proc seed context) | |
729 | "Fold @var{proc} over all source locations in @var{context}. | |
730 | @var{proc} will be called with two arguments: the source object and the | |
731 | seed." | |
732 | (cond | |
733 | ((and context | |
734 | (false-if-exception | |
735 | (elf->dwarf-context (debug-context-elf context)))) | |
736 | => | |
737 | (lambda (dwarf-ctx) | |
738 | (let ((base (debug-context-base context))) | |
739 | (fold | |
740 | (lambda (die seed) | |
741 | (cond | |
742 | ((die-line-prog die) | |
743 | => | |
744 | (lambda (prog) | |
745 | (let lp ((seed seed)) | |
746 | (call-with-values | |
747 | (lambda () (line-prog-advance prog)) | |
748 | (lambda (pc* file line col) | |
749 | (if pc* | |
750 | (lp | |
751 | (proc (make-source/dwarf (+ pc* base) file line col) | |
752 | seed)) | |
753 | seed)))))) | |
754 | (else seed))) | |
755 | seed | |
756 | (read-die-roots dwarf-ctx))))) | |
757 | (else seed))) |