Commit | Line | Data |
---|---|---|
359f46a4 LC |
1 | ;;; GDB debugging support for Guile. |
2 | ;;; | |
ef52b399 | 3 | ;;; Copyright 2014, 2015 Free Software Foundation, Inc. |
359f46a4 LC |
4 | ;;; |
5 | ;;; This program is free software; you can redistribute it and/or modify it | |
6 | ;;; under the terms of the GNU General Public License as published by | |
7 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
8 | ;;; your option) any later version. | |
9 | ;;; | |
10 | ;;; This program is distributed in the hope that it will be useful, but | |
11 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
13 | ;;; GNU General Public License for more details. | |
14 | ;;; | |
15 | ;;; You should have received a copy of the GNU General Public License | |
16 | ;;; along with this program. If not, see <http://www.gnu.org/licenses/>. | |
17 | ||
18 | (define-module (guile-gdb) | |
19 | #:use-module (system base types) | |
ef52b399 AW |
20 | #:use-module (system vm debug) |
21 | #:use-module ((gdb) #:hide (symbol? frame?)) | |
22 | #:use-module ((gdb) #:select ((symbol? . gdb:symbol?) (frame? . gdb:frame?))) | |
359f46a4 | 23 | #:use-module (gdb printing) |
ef52b399 | 24 | #:use-module (srfi srfi-9) |
359f46a4 | 25 | #:use-module (srfi srfi-11) |
ef52b399 AW |
26 | #:use-module (srfi srfi-41) |
27 | #:use-module (ice-9 match) | |
28 | #:use-module (ice-9 binary-ports) | |
359f46a4 LC |
29 | #:export (%gdb-memory-backend |
30 | display-vm-frames)) | |
31 | ||
32 | ;;; Commentary: | |
33 | ;;; | |
34 | ;;; This file defines GDB extensions to pretty-print 'SCM' objects, and | |
35 | ;;; to walk Guile's virtual machine stack. | |
36 | ;;; | |
37 | ;;; This file is installed under a name that follows the convention that | |
38 | ;;; allows GDB to auto-load it anytime the user is debugging libguile | |
39 | ;;; (info "(gdb) objfile-gdbdotext file"). | |
40 | ;;; | |
41 | ;;; Code: | |
42 | ||
43 | (define (type-name-from-descriptor descriptor-array type-number) | |
44 | "Return the name of the type TYPE-NUMBER as seen in DESCRIPTOR-ARRAY, or #f | |
45 | if the information is not available." | |
46 | (let ((descriptors (lookup-global-symbol descriptor-array))) | |
47 | (and descriptors | |
48 | (let ((code (type-code (symbol-type descriptors)))) | |
49 | (or (= TYPE_CODE_ARRAY code) | |
50 | (= TYPE_CODE_PTR code))) | |
51 | (let* ((type-descr (value-subscript (symbol-value descriptors) | |
52 | type-number)) | |
53 | (name (value-field type-descr "name"))) | |
54 | (value->string name))))) | |
55 | ||
56 | (define %gdb-memory-backend | |
57 | ;; The GDB back-end to access the inferior's memory. | |
58 | (let ((void* (type-pointer (lookup-type "void")))) | |
59 | (define (dereference-word address) | |
60 | ;; Return the word at ADDRESS. | |
61 | (value->integer | |
62 | (value-dereference (value-cast (make-value address) | |
63 | (type-pointer void*))))) | |
64 | ||
65 | (define (open address size) | |
66 | ;; Return a port to the SIZE bytes starting at ADDRESS. | |
67 | (if size | |
68 | (open-memory #:start address #:size size) | |
69 | (open-memory #:start address))) | |
70 | ||
71 | (define (type-name kind number) | |
72 | ;; Return the type name of KIND type NUMBER. | |
73 | (type-name-from-descriptor (case kind | |
74 | ((smob) "scm_smobs") | |
75 | ((port) "scm_ptobs")) | |
76 | number)) | |
77 | ||
78 | (memory-backend dereference-word open type-name))) | |
79 | ||
80 | \f | |
81 | ;;; | |
82 | ;;; GDB pretty-printer registration. | |
83 | ;;; | |
84 | ||
85 | (define scm-value->string | |
86 | (lambda* (value #:optional (backend %gdb-memory-backend)) | |
87 | "Return a representation of value VALUE as a string." | |
88 | (object->string (scm->object (value->integer value) backend)))) | |
89 | ||
c4c21de4 AW |
90 | (define (make-scm-pretty-printer-worker obj) |
91 | (define (list->iterator list) | |
92 | (make-iterator list list | |
93 | (let ((n 0)) | |
94 | (lambda (iter) | |
95 | (match (iterator-progress iter) | |
96 | (() (end-of-iteration)) | |
97 | ((elt . list) | |
98 | (set-iterator-progress! iter list) | |
99 | (let ((name (format #f "[~a]" n))) | |
100 | (set! n (1+ n)) | |
101 | (cons name (object->string elt))))))))) | |
102 | (cond | |
103 | ((string? obj) | |
104 | (make-pretty-printer-worker | |
105 | "string" ; display hint | |
106 | (lambda (printer) obj) | |
107 | #f)) | |
108 | ((and (array? obj) | |
109 | (match (array-shape obj) | |
110 | (((0 _)) #t) | |
111 | (_ #f))) | |
112 | (make-pretty-printer-worker | |
113 | "array" ; display hint | |
114 | (lambda (printer) | |
115 | (let ((tag (array-type obj))) | |
116 | (case tag | |
117 | ((#t) "#<vector>") | |
118 | ((b) "#<bitvector>") | |
119 | (else (format #f "#<~avector>" tag))))) | |
120 | (lambda (printer) | |
121 | (list->iterator (array->list obj))))) | |
122 | ((inferior-struct? obj) | |
123 | (make-pretty-printer-worker | |
124 | "array" ; display hint | |
125 | (lambda (printer) | |
126 | (format #f "#<struct ~a>" (inferior-struct-name obj))) | |
127 | (lambda (printer) | |
128 | (list->iterator (inferior-struct-fields obj))))) | |
129 | (else | |
130 | (make-pretty-printer-worker | |
131 | #f ; display hint | |
132 | (lambda (printer) | |
133 | (object->string obj)) | |
134 | #f)))) | |
135 | ||
359f46a4 | 136 | (define %scm-pretty-printer |
c4c21de4 AW |
137 | (make-pretty-printer |
138 | "SCM" | |
139 | (lambda (pp value) | |
140 | (let ((name (type-name (value-type value)))) | |
141 | (and (and name (string=? name "SCM")) | |
142 | (make-scm-pretty-printer-worker | |
143 | (scm->object (value->integer value) %gdb-memory-backend))))))) | |
359f46a4 LC |
144 | |
145 | (define* (register-pretty-printer #:optional objfile) | |
146 | (prepend-pretty-printer! objfile %scm-pretty-printer)) | |
147 | ||
148 | (register-pretty-printer) | |
149 | ||
150 | \f | |
151 | ;;; | |
152 | ;;; VM stack walking. | |
153 | ;;; | |
154 | ||
ef52b399 AW |
155 | (define ip-type (type-pointer (lookup-type "scm_t_uint32"))) |
156 | (define fp-type (type-pointer (lookup-type "SCM"))) | |
157 | (define sp-type (type-pointer (lookup-type "SCM"))) | |
359f46a4 | 158 | |
ef52b399 AW |
159 | (define-record-type <vm-frame> |
160 | (make-vm-frame ip sp fp saved-ip saved-fp) | |
161 | vm-frame? | |
162 | (ip vm-frame-ip) | |
163 | (sp vm-frame-sp) | |
164 | (fp vm-frame-fp) | |
165 | (saved-ip vm-frame-saved-ip) | |
166 | (saved-fp vm-frame-saved-fp)) | |
167 | ||
168 | ;; See libguile/frames.h. | |
169 | (define* (vm-frame ip sp fp #:optional (backend %gdb-memory-backend)) | |
170 | "Return the components of the stack frame at FP." | |
171 | (make-vm-frame ip | |
172 | sp | |
173 | fp | |
174 | (value-dereference (value-cast (value-sub fp 1) | |
175 | (type-pointer ip-type))) | |
176 | (value-dereference (value-cast (value-sub fp 2) | |
177 | (type-pointer fp-type))))) | |
178 | ||
179 | (define (vm-engine-frame? frame) | |
180 | (let ((sym (frame-function frame))) | |
181 | (and sym | |
182 | (member (symbol-name sym) | |
183 | '("vm_debug_engine" "vm_regular_engine"))))) | |
184 | ||
185 | (define (find-vp) | |
186 | "Find the scm_vm pointer for the current thread." | |
359f46a4 LC |
187 | (let loop ((frame (newest-frame))) |
188 | (and frame | |
189 | (if (vm-engine-frame? frame) | |
ef52b399 | 190 | (frame-read-var frame "vp") |
359f46a4 LC |
191 | (loop (frame-older frame)))))) |
192 | ||
ef52b399 AW |
193 | (define (newest-vm-frame) |
194 | "Return the newest VM frame or #f." | |
195 | (let ((vp (find-vp))) | |
196 | (and vp | |
197 | (vm-frame (value-field vp "ip") | |
198 | (value-field vp "sp") | |
199 | (value-field vp "fp"))))) | |
359f46a4 | 200 | |
ef52b399 AW |
201 | (define* (vm-frame-older frame #:optional (backend %gdb-memory-backend)) |
202 | (let ((ip (vm-frame-saved-ip frame)) | |
203 | (sp (value-sub (vm-frame-fp frame) 3)) | |
204 | (fp (vm-frame-saved-fp frame))) | |
205 | (and (not (zero? (value->integer fp))) | |
206 | (vm-frame ip sp fp backend)))) | |
207 | ||
208 | (define (vm-frames) | |
209 | "Return a SRFI-41 stream of the current VM frame stack." | |
210 | (stream-unfold identity | |
211 | vm-frame? | |
212 | vm-frame-older | |
213 | (newest-vm-frame))) | |
214 | ||
215 | (define (vm-frame-locals frame) | |
216 | (let ((fp (vm-frame-fp frame)) | |
217 | (sp (vm-frame-sp frame))) | |
218 | (let lp ((slot 0) (ptr fp)) | |
219 | (if (value<=? ptr sp) | |
220 | (acons (string-append "v" (number->string slot)) | |
221 | (value-dereference ptr) | |
222 | (lp (1+ slot) (value-add ptr 1))) | |
223 | '())))) | |
224 | ||
225 | (define (lookup-symbol-or-false name) | |
226 | (match (lookup-symbol name) | |
227 | (#f #f) | |
228 | ((sym _) sym))) | |
229 | ||
230 | (define (find-mapped-elf-image addr) | |
231 | (let ((array (lookup-symbol-or-false "mapped_elf_images")) | |
232 | (count (lookup-symbol-or-false "mapped_elf_images_count"))) | |
233 | (and array count | |
234 | (let ((array (symbol-value array)) | |
235 | (count (value->integer (symbol-value count)))) | |
236 | (let lp ((start 0) (end count)) | |
237 | (if (< start end) | |
238 | (let ((n (+ start (ash (- end start) -1)))) | |
239 | (if (value<? addr (value-field (value-add array n) "end")) | |
240 | (lp start n) | |
241 | (lp (1+ n) end))) | |
242 | (let ((mei (value-add array start))) | |
243 | (and (value<=? (value-field mei "start") addr) | |
244 | mei)))))))) | |
245 | ||
246 | (define (vm-frame-program-debug-info frame) | |
247 | (let ((addr (vm-frame-ip frame))) | |
248 | (and=> (find-mapped-elf-image addr) | |
249 | (lambda (mei) | |
250 | (let* ((start (value->integer (value-field mei "start"))) | |
251 | (size (- (value->integer (value-field mei "end")) | |
252 | start)) | |
253 | (mem-port (open-memory #:start start #:size size)) | |
254 | (bv (get-bytevector-all mem-port)) | |
255 | (ctx (debug-context-from-image bv))) | |
256 | ;; The image is in this process at "bv", but in the | |
257 | ;; inferior at mei.start. Therefore we relocate addr | |
258 | ;; before we look for the PDI. | |
259 | (let ((addr (+ (value->integer addr) | |
260 | (- (debug-context-base ctx) start)))) | |
261 | (find-program-debug-info addr ctx))))))) | |
262 | ||
263 | (define (vm-frame-function-name frame) | |
264 | (define (default-name) | |
265 | (format #f "0x~x" (value->integer (vm-frame-ip frame)))) | |
266 | (cond | |
267 | ((vm-frame-program-debug-info frame) | |
268 | => (lambda (pdi) | |
269 | (or (and=> (program-debug-info-name pdi) symbol->string) | |
270 | (default-name)))) | |
271 | (else | |
272 | (let ((ip (vm-frame-ip frame))) | |
273 | (define (ip-in-symbol? name) | |
274 | (let ((sym (lookup-symbol-or-false name))) | |
275 | (and sym | |
276 | (let* ((val (symbol-value sym)) | |
277 | (size (type-sizeof (value-type val))) | |
278 | (char* (type-pointer (arch-char-type (current-arch)))) | |
279 | (val-as-char* (value-cast val char*))) | |
280 | (and (value<=? val-as-char* ip) | |
281 | (value<? ip (value-add val-as-char* size))))))) | |
282 | (cond | |
283 | ((ip-in-symbol? "vm_boot_continuation_code") "[boot continuation]") | |
284 | ;; FIXME: For subrs, read the name from slot 0 in the frame. | |
285 | ((ip-in-symbol? "subr_stub_code") "[subr call]") | |
286 | ((ip-in-symbol? "vm_builtin_apply_code") "apply") | |
287 | ((ip-in-symbol? "vm_builtin_values_code") "values") | |
288 | ((ip-in-symbol? "vm_builtin_abort_to_prompt_code") "abort-to-prompt") | |
289 | ((ip-in-symbol? "vm_builtin_call_with_values_code") "call-with-values") | |
290 | ((ip-in-symbol? "vm_builtin_call_with_current_continuation_code") | |
291 | "call-with-current-continuation") | |
292 | ((ip-in-symbol? "continuation_stub_code") "[continuation]") | |
293 | ((ip-in-symbol? "compose_continuation_code") "[delimited continuation]") | |
294 | ((ip-in-symbol? "foreign_stub_code") "[ffi call]") | |
295 | (else (default-name))))))) | |
296 | ||
297 | (define* (dump-vm-frame frame #:optional (port (current-output-port))) | |
298 | (format port " name: ~a~%" (vm-frame-function-name frame)) | |
299 | (format port " ip: 0x~x~%" (value->integer (vm-frame-ip frame))) | |
300 | (format port " fp: 0x~x~%" (value->integer (vm-frame-fp frame))) | |
301 | (for-each (match-lambda | |
302 | ((name . val) | |
303 | (let ((obj (scm->object (value->integer val) %gdb-memory-backend))) | |
304 | (format port " ~a: ~a~%" name obj)))) | |
305 | (vm-frame-locals frame))) | |
359f46a4 LC |
306 | |
307 | (define* (display-vm-frames #:optional (port (current-output-port))) | |
308 | "Display the VM frames on PORT." | |
ef52b399 AW |
309 | (stream-for-each (lambda (frame) |
310 | (dump-vm-frame frame port)) | |
311 | (vm-frames))) | |
359f46a4 | 312 | |
47612fd6 AW |
313 | \f |
314 | ;;; | |
315 | ;;; Frame filters. | |
316 | ;;; | |
317 | ||
318 | (define-syntax compile-time-cond | |
319 | (lambda (x) | |
320 | (syntax-case x (else) | |
321 | ((_ (test body ...) clause ...) | |
322 | (if (eval (syntax->datum #'test) (current-module)) | |
323 | #'(begin body ...) | |
324 | #'(compile-time-cond clause ...))) | |
325 | ((_ (else body ...)) | |
326 | #'(begin body ...))))) | |
327 | ||
328 | (compile-time-cond | |
329 | ((false-if-exception (resolve-interface '(gdb frames))) | |
330 | (use-modules (gdb frames)) | |
331 | ||
332 | (define (snarfy-frame-annotator ann) | |
333 | (let* ((frame (annotated-frame-frame ann)) | |
334 | (sym (frame-function frame))) | |
335 | (or | |
336 | (and sym | |
337 | (gdb:symbol? sym) | |
338 | (let ((c-name (symbol-name sym))) | |
339 | (match (lookup-symbol (string-append "s_" c-name)) | |
340 | (#f #f) | |
341 | ((scheme-name-sym _) | |
342 | (and (string-prefix? | |
343 | "const char [" | |
344 | (type-print-name (symbol-type scheme-name-sym))) | |
345 | (let* ((scheme-name-value (symbol-value scheme-name-sym)) | |
346 | (scheme-name (value->string scheme-name-value)) | |
347 | (name (format #f "~a [~a]" scheme-name c-name))) | |
348 | (reannotate-frame ann #:function-name name))))))) | |
349 | ann))) | |
350 | ||
351 | (define* (vm-frame-filter gdb-frames #:optional (vm-frames (vm-frames))) | |
352 | (define (synthesize-frame gdb-frame vm-frame) | |
353 | (let* ((ip (value->integer (vm-frame-ip vm-frame)))) | |
354 | (reannotate-frame gdb-frame | |
355 | #:function-name (vm-frame-function-name vm-frame) | |
356 | #:address ip | |
357 | #:filename #f | |
358 | #:line #f | |
359 | #:arguments '() | |
360 | #:locals (vm-frame-locals vm-frame) | |
361 | #:children '()))) | |
362 | (define (recur gdb-frame gdb-frames vm-frames) | |
363 | (stream-cons gdb-frame | |
364 | (vm-frame-filter gdb-frames vm-frames))) | |
365 | (cond | |
366 | ((or (stream-null? gdb-frames) | |
367 | (not (lookup-symbol "vm_boot_continuation_code"))) | |
368 | gdb-frames) | |
369 | (else | |
370 | (let ((gdb-frame (stream-car gdb-frames)) | |
371 | (gdb-frames (stream-cdr gdb-frames))) | |
372 | (match (lookup-symbol "vm_boot_continuation_code") | |
373 | ((boot-sym _) | |
374 | (let ((boot-ptr (symbol-value boot-sym))) | |
375 | (cond | |
376 | ((vm-engine-frame? (annotated-frame-frame gdb-frame)) | |
377 | (let lp ((children (reverse | |
378 | (annotated-frame-children gdb-frame))) | |
379 | (vm-frames vm-frames)) | |
380 | (define (finish reversed-children vm-frames) | |
381 | (let ((children (reverse reversed-children))) | |
382 | (recur (reannotate-frame gdb-frame #:children children) | |
383 | gdb-frames | |
384 | vm-frames))) | |
385 | (cond | |
386 | ((stream-null? vm-frames) | |
387 | (finish children vm-frames)) | |
388 | (else | |
389 | (let* ((vm-frame (stream-car vm-frames)) | |
390 | (vm-frames (stream-cdr vm-frames))) | |
391 | (if (value=? (vm-frame-ip vm-frame) boot-ptr) | |
392 | ;; Drop the boot frame and finish. | |
393 | (finish children vm-frames) | |
394 | (lp (cons (synthesize-frame gdb-frame vm-frame) | |
395 | children) | |
396 | vm-frames))))))) | |
397 | (else | |
398 | (recur gdb-frame gdb-frames vm-frames)))))))))) | |
399 | ||
400 | (add-frame-annotator! "guile-snarf-annotator" snarfy-frame-annotator) | |
401 | (add-frame-filter! "guile-vm-frame-filter" vm-frame-filter)) | |
402 | (else #f)) | |
403 | ||
475772ea | 404 | ;;; libguile-2.2-gdb.scm ends here |