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) | |
1f3babaa | 265 | "[unknown]") |
ef52b399 AW |
266 | (cond |
267 | ((vm-frame-program-debug-info frame) | |
268 | => (lambda (pdi) | |
269 | (or (and=> (program-debug-info-name pdi) symbol->string) | |
1f3babaa | 270 | "[anonymous]"))) |
ef52b399 AW |
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 | ||
1f3babaa AW |
297 | (define (vm-frame-source frame) |
298 | (let* ((ip (value->integer (vm-frame-ip frame))) | |
299 | (pdi (vm-frame-program-debug-info frame))) | |
300 | (and pdi | |
301 | (find-source-for-addr (program-debug-info-addr pdi) | |
302 | (program-debug-info-context pdi))))) | |
303 | ||
ef52b399 AW |
304 | (define* (dump-vm-frame frame #:optional (port (current-output-port))) |
305 | (format port " name: ~a~%" (vm-frame-function-name frame)) | |
306 | (format port " ip: 0x~x~%" (value->integer (vm-frame-ip frame))) | |
307 | (format port " fp: 0x~x~%" (value->integer (vm-frame-fp frame))) | |
308 | (for-each (match-lambda | |
309 | ((name . val) | |
310 | (let ((obj (scm->object (value->integer val) %gdb-memory-backend))) | |
311 | (format port " ~a: ~a~%" name obj)))) | |
312 | (vm-frame-locals frame))) | |
359f46a4 LC |
313 | |
314 | (define* (display-vm-frames #:optional (port (current-output-port))) | |
315 | "Display the VM frames on PORT." | |
ef52b399 AW |
316 | (stream-for-each (lambda (frame) |
317 | (dump-vm-frame frame port)) | |
318 | (vm-frames))) | |
359f46a4 | 319 | |
47612fd6 AW |
320 | \f |
321 | ;;; | |
322 | ;;; Frame filters. | |
323 | ;;; | |
324 | ||
325 | (define-syntax compile-time-cond | |
326 | (lambda (x) | |
1f3babaa | 327 | (syntax-case x () |
47612fd6 AW |
328 | ((_ (test body ...) clause ...) |
329 | (if (eval (syntax->datum #'test) (current-module)) | |
330 | #'(begin body ...) | |
331 | #'(compile-time-cond clause ...))) | |
1f3babaa AW |
332 | ((_) |
333 | #'(begin))))) | |
47612fd6 AW |
334 | |
335 | (compile-time-cond | |
1f3babaa AW |
336 | ((false-if-exception (resolve-interface '(gdb frame-filters))) |
337 | (use-modules (gdb frame-filters)) | |
47612fd6 | 338 | |
1f3babaa AW |
339 | (define (snarfy-frame-decorator dec) |
340 | (let* ((frame (decorated-frame-frame dec)) | |
47612fd6 AW |
341 | (sym (frame-function frame))) |
342 | (or | |
343 | (and sym | |
344 | (gdb:symbol? sym) | |
345 | (let ((c-name (symbol-name sym))) | |
346 | (match (lookup-symbol (string-append "s_" c-name)) | |
347 | (#f #f) | |
348 | ((scheme-name-sym _) | |
349 | (and (string-prefix? | |
350 | "const char [" | |
351 | (type-print-name (symbol-type scheme-name-sym))) | |
352 | (let* ((scheme-name-value (symbol-value scheme-name-sym)) | |
353 | (scheme-name (value->string scheme-name-value)) | |
354 | (name (format #f "~a [~a]" scheme-name c-name))) | |
1f3babaa AW |
355 | (redecorate-frame dec #:function-name name))))))) |
356 | dec))) | |
47612fd6 AW |
357 | |
358 | (define* (vm-frame-filter gdb-frames #:optional (vm-frames (vm-frames))) | |
359 | (define (synthesize-frame gdb-frame vm-frame) | |
1f3babaa AW |
360 | (let* ((ip (value->integer (vm-frame-ip vm-frame))) |
361 | (source (vm-frame-source vm-frame))) | |
362 | (redecorate-frame gdb-frame | |
47612fd6 AW |
363 | #:function-name (vm-frame-function-name vm-frame) |
364 | #:address ip | |
1f3babaa AW |
365 | #:filename (and=> source source-file) |
366 | #:line (and=> source source-line-for-user) | |
47612fd6 AW |
367 | #:arguments '() |
368 | #:locals (vm-frame-locals vm-frame) | |
369 | #:children '()))) | |
370 | (define (recur gdb-frame gdb-frames vm-frames) | |
371 | (stream-cons gdb-frame | |
372 | (vm-frame-filter gdb-frames vm-frames))) | |
373 | (cond | |
374 | ((or (stream-null? gdb-frames) | |
375 | (not (lookup-symbol "vm_boot_continuation_code"))) | |
376 | gdb-frames) | |
377 | (else | |
378 | (let ((gdb-frame (stream-car gdb-frames)) | |
379 | (gdb-frames (stream-cdr gdb-frames))) | |
380 | (match (lookup-symbol "vm_boot_continuation_code") | |
381 | ((boot-sym _) | |
382 | (let ((boot-ptr (symbol-value boot-sym))) | |
383 | (cond | |
1f3babaa | 384 | ((vm-engine-frame? (decorated-frame-frame gdb-frame)) |
47612fd6 | 385 | (let lp ((children (reverse |
1f3babaa | 386 | (decorated-frame-children gdb-frame))) |
47612fd6 AW |
387 | (vm-frames vm-frames)) |
388 | (define (finish reversed-children vm-frames) | |
389 | (let ((children (reverse reversed-children))) | |
1f3babaa | 390 | (recur (redecorate-frame gdb-frame #:children children) |
47612fd6 AW |
391 | gdb-frames |
392 | vm-frames))) | |
393 | (cond | |
394 | ((stream-null? vm-frames) | |
395 | (finish children vm-frames)) | |
396 | (else | |
397 | (let* ((vm-frame (stream-car vm-frames)) | |
398 | (vm-frames (stream-cdr vm-frames))) | |
399 | (if (value=? (vm-frame-ip vm-frame) boot-ptr) | |
400 | ;; Drop the boot frame and finish. | |
401 | (finish children vm-frames) | |
402 | (lp (cons (synthesize-frame gdb-frame vm-frame) | |
403 | children) | |
404 | vm-frames))))))) | |
405 | (else | |
406 | (recur gdb-frame gdb-frames vm-frames)))))))))) | |
407 | ||
1f3babaa AW |
408 | (add-frame-filter! |
409 | (make-decorating-frame-filter "guile-snarf-decorator" | |
410 | snarfy-frame-decorator | |
411 | #:objfile (current-objfile))) | |
412 | (add-frame-filter! | |
413 | (make-frame-filter "guile-vm-frame-filter" | |
414 | vm-frame-filter | |
415 | #:objfile (current-objfile)))) | |
416 | (#t #f)) | |
47612fd6 | 417 | |
475772ea | 418 | ;;; libguile-2.2-gdb.scm ends here |