1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
|
;;; Guile runtime debug information
;;; Copyright (C) 2013 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; Guile's RTL compiler and linker serialize debugging information into
;;; separate sections of the ELF image. This module reads those
;;; sections.
;;;
;;; Code:
(define-module (system vm debug)
#:use-module (system vm elf)
#:use-module (system vm objcode)
#:use-module (system foreign)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:use-module (srfi srfi-9)
#:export (debug-context-image
debug-context-base
program-debug-info-name
program-debug-info-context
program-debug-info-image
program-debug-info-offset
program-debug-info-addr
program-debug-info-u32-offset
program-debug-info-u32-offset-end
arity?
arity-low-pc
arity-high-pc
arity-nreq
arity-nopt
arity-has-rest?
arity-allow-other-keys?
arity-has-keyword-args?
arity-is-case-lambda?
find-debug-context
find-program-debug-info
arity-arguments-alist
find-program-arities
program-minimum-arity))
;;; A compiled procedure comes from a specific loaded ELF image. A
;;; debug context identifies that image.
;;;
(define-record-type <debug-context>
(make-debug-context elf base text-base)
debug-context?
(elf debug-context-elf)
;; Address at which this image is loaded in memory, in bytes.
(base debug-context-base)
;; Offset of the text section relative to the image start, in bytes.
(text-base debug-context-text-base))
(define (debug-context-image context)
"Return the bytevector aliasing the mapped ELF image corresponding to
@var{context}."
(elf-bytes (debug-context-elf context)))
;;; A program debug info (PDI) is a handle on debugging meta-data for a
;;; particular program.
;;;
(define-record-type <program-debug-info>
(make-program-debug-info context name offset size)
program-debug-info?
(context program-debug-info-context)
(name program-debug-info-name)
;; Offset of the procedure in the text section, in bytes.
(offset program-debug-info-offset)
(size program-debug-info-size))
(define (program-debug-info-addr pdi)
"Return the address in memory of the entry of the program represented
by the debugging info @var{pdi}."
(+ (program-debug-info-offset pdi)
(debug-context-text-base (program-debug-info-context pdi))
(debug-context-base (program-debug-info-context pdi))))
(define (program-debug-info-image pdi)
"Return the ELF image containing @var{pdi}, as a bytevector."
(debug-context-image (program-debug-info-context pdi)))
(define (program-debug-info-u32-offset pdi)
"Return the start address of the program represented by @var{pdi}, as
an offset from the beginning of the ELF image in 32-bit units."
(/ (+ (program-debug-info-offset pdi)
(debug-context-text-base (program-debug-info-context pdi)))
4))
(define (program-debug-info-u32-offset-end pdi)
"Return the end address of the program represented by @var{pdi}, as an
offset from the beginning of the ELF image in 32-bit units."
(/ (+ (program-debug-info-size pdi)
(program-debug-info-offset pdi)
(debug-context-text-base (program-debug-info-context pdi)))
4))
(define (find-debug-context addr)
"Find and return the debugging context corresponding to the ELF image
containing the address @var{addr}. @var{addr} is an integer."
(let* ((bv (find-mapped-elf-image addr))
(elf (parse-elf bv))
(base (pointer-address (bytevector->pointer (elf-bytes elf))))
(text-base (elf-section-offset
(or (elf-section-by-name elf ".rtl-text")
(error "ELF object has no text section")))))
(make-debug-context elf base text-base)))
(define (find-elf-symbol elf text-offset)
"Search the symbol table of @var{elf} for the ELF symbol containing
@var{text-offset}. @var{text-offset} is a byte offset in the text
section of the ELF image. Returns an ELF symbol, or @code{#f}."
(and=>
(elf-section-by-name elf ".symtab")
(lambda (symtab)
(let ((len (elf-symbol-table-len symtab))
(strtab (elf-section elf (elf-section-link symtab))))
;; The symbols should be sorted, but maybe somehow that fails
;; (for example if multiple objects are relinked together). So,
;; a modicum of tolerance.
(define (bisect)
;; FIXME: Implement.
#f)
(define (linear-search)
(let lp ((n 0))
(and (< n len)
(let ((sym (elf-symbol-table-ref elf symtab n strtab)))
(if (and (<= (elf-symbol-value sym) text-offset)
(< text-offset (+ (elf-symbol-value sym)
(elf-symbol-size sym))))
sym
(lp (1+ n)))))))
(or (bisect) (linear-search))))))
(define* (find-program-debug-info addr #:optional
(context (find-debug-context addr)))
"Find and return the @code{<program-debug-info>} containing
@var{addr}, or @code{#f}."
(cond
((find-elf-symbol (debug-context-elf context)
(- addr
(debug-context-base context)
(debug-context-text-base context)))
=> (lambda (sym)
(make-program-debug-info context
(and=> (elf-symbol-name sym)
;; The name might be #f if
;; the string table was
;; stripped somehow.
(lambda (x)
(and (string? x)
(not (string-null? x))
(string->symbol x))))
(elf-symbol-value sym)
(elf-symbol-size sym))))
(else #f)))
(define-record-type <arity>
(make-arity context base header-offset)
arity?
(context arity-context)
(base arity-base)
(header-offset arity-header-offset))
(define arities-prefix-len 4)
(define arity-header-len (* 6 4))
;;; struct arity_header {
;;; uint32_t low_pc;
;;; uint32_t high_pc;
;;; uint32_t offset;
;;; uint32_t flags;
;;; uint32_t nreq;
;;; uint32_t nopt;
;;; }
(define (arity-low-pc* bv header-pos)
(bytevector-u32-native-ref bv (+ header-pos (* 0 4))))
(define (arity-high-pc* bv header-pos)
(bytevector-u32-native-ref bv (+ header-pos (* 1 4))))
(define (arity-offset* bv header-pos)
(bytevector-u32-native-ref bv (+ header-pos (* 2 4))))
(define (arity-flags* bv header-pos)
(bytevector-u32-native-ref bv (+ header-pos (* 3 4))))
(define (arity-nreq* bv header-pos)
(bytevector-u32-native-ref bv (+ header-pos (* 4 4))))
(define (arity-nopt* bv header-pos)
(bytevector-u32-native-ref bv (+ header-pos (* 5 4))))
;;; #x1: has-rest?
;;; #x2: allow-other-keys?
;;; #x4: has-keyword-args?
;;; #x8: is-case-lambda?
(define (has-rest? flags) (not (zero? (logand flags (ash 1 0)))))
(define (allow-other-keys? flags) (not (zero? (logand flags (ash 1 1)))))
(define (has-keyword-args? flags) (not (zero? (logand flags (ash 1 2)))))
(define (is-case-lambda? flags) (not (zero? (logand flags (ash 1 3)))))
(define (arity-nreq arity)
(arity-nreq* (elf-bytes (debug-context-elf (arity-context arity)))
(arity-header-offset arity)))
(define (arity-nopt arity)
(arity-nopt* (elf-bytes (debug-context-elf (arity-context arity)))
(arity-header-offset arity)))
(define (arity-flags arity)
(arity-flags* (elf-bytes (debug-context-elf (arity-context arity)))
(arity-header-offset arity)))
(define (arity-has-rest? arity) (has-rest? (arity-flags arity)))
(define (arity-allow-other-keys? arity) (allow-other-keys? (arity-flags arity)))
(define (arity-has-keyword-args? arity) (has-keyword-args? (arity-flags arity)))
(define (arity-is-case-lambda? arity) (is-case-lambda? (arity-flags arity)))
(define (arity-load-symbol arity)
(let ((elf (debug-context-elf (arity-context arity))))
(cond
((elf-section-by-name elf ".guile.arities")
=>
(lambda (sec)
(let* ((strtab (elf-section elf (elf-section-link sec)))
(bv (elf-bytes elf))
(strtab-offset (elf-section-offset strtab)))
(lambda (n)
(string->symbol (string-table-ref bv (+ strtab-offset n)))))))
(else (error "couldn't find arities section")))))
(define (arity-arguments-alist arity)
(let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
(%load-symbol (arity-load-symbol arity))
(header (arity-header-offset arity))
(link-offset (arity-offset* bv header))
(link (+ (arity-base arity) link-offset))
(flags (arity-flags* bv header))
(nreq (arity-nreq* bv header))
(nopt (arity-nopt* bv header)))
(define (load-symbol idx)
(%load-symbol (bytevector-u32-native-ref bv (+ link (* idx 4)))))
(define (load-symbols skip n)
(let lp ((n n) (out '()))
(if (zero? n)
out
(lp (1- n)
(cons (load-symbol (+ skip (1- n))) out)))))
(define (unpack-scm n)
(pointer->scm (make-pointer n)))
(define (load-non-immediate idx)
(let ((offset (bytevector-u32-native-ref bv (+ link (* idx 4)))))
(unpack-scm (+ (debug-context-base (arity-context arity)) offset))))
(and (not (is-case-lambda? flags))
`((required . ,(load-symbols 0 nreq))
(optional . ,(load-symbols nreq nopt))
(rest . ,(and (has-rest? flags) (load-symbol (+ nreq nopt))))
(keyword . ,(if (has-keyword-args? flags)
(load-non-immediate
(+ nreq nopt (if (has-rest? flags) 1 0)))
'()))
(allow-other-keys? . ,(allow-other-keys? flags))))))
(define (find-first-arity context base addr)
(let* ((bv (elf-bytes (debug-context-elf context)))
(text-offset (- addr
(debug-context-text-base context)
(debug-context-base context)))
(headers-start (+ base arities-prefix-len))
(headers-end (+ base (bytevector-u32-native-ref bv base))))
;; FIXME: This is linear search. Change to binary search.
(let lp ((pos headers-start))
(cond
((>= pos headers-end) #f)
((< text-offset (arity-low-pc* bv pos))
(lp (+ pos arity-header-len)))
((< (arity-high-pc* bv pos) text-offset)
#f)
(else
(make-arity context base pos))))))
(define (read-sub-arities context base outer-header-offset)
(let* ((bv (elf-bytes (debug-context-elf context)))
(headers-end (+ base (bytevector-u32-native-ref bv base)))
(low-pc (arity-low-pc* bv outer-header-offset))
(high-pc (arity-high-pc* bv outer-header-offset)))
(let lp ((pos (+ outer-header-offset arity-header-len)) (out '()))
(if (and (< pos headers-end) (<= (arity-high-pc* bv pos) high-pc))
(lp (+ pos arity-header-len)
(cons (make-arity context base pos) out))
(reverse out)))))
(define* (find-program-arities addr #:optional
(context (find-debug-context addr)))
(and=>
(elf-section-by-name (debug-context-elf context) ".guile.arities")
(lambda (sec)
(let* ((base (elf-section-offset sec))
(first (find-first-arity context base addr)))
;; FIXME: Handle case-lambda arities.
(cond
((not first) '())
((arity-is-case-lambda? first)
(read-sub-arities context base (arity-header-offset first)))
(else (list first)))))))
(define* (program-minimum-arity addr #:optional
(context (find-debug-context addr)))
(and=>
(elf-section-by-name (debug-context-elf context) ".guile.arities")
(lambda (sec)
(let* ((base (elf-section-offset sec))
(first (find-first-arity context base addr)))
(if (arity-is-case-lambda? first)
(list 0 0 #t) ;; FIXME: be more precise.
(list (arity-nreq first)
(arity-nopt first)
(arity-has-rest? first)))))))
|