1 ;;; GDB debugging support for Guile.
3 ;;; Copyright 2014, 2015 Free Software Foundation, Inc.
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.
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.
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/>.
18 (define-module (guile-gdb)
19 #:use-module (system base types)
20 #:use-module (system vm debug)
21 #:use-module ((gdb) #:hide (symbol? frame?))
22 #:use-module ((gdb) #:select ((symbol? . gdb:symbol?) (frame? . gdb:frame?)))
23 #:use-module (gdb printing)
24 #:use-module (srfi srfi-9)
25 #:use-module (srfi srfi-11)
26 #:use-module (srfi srfi-41)
27 #:use-module (ice-9 match)
28 #:use-module (ice-9 binary-ports)
29 #:export (%gdb-memory-backend
34 ;;; This file defines GDB extensions to pretty-print 'SCM' objects, and
35 ;;; to walk Guile's virtual machine stack.
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").
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)))
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)
53 (name (value-field type-descr "name")))
54 (value->string name)))))
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.
62 (value-dereference (value-cast (make-value address)
63 (type-pointer void*)))))
65 (define (open address size)
66 ;; Return a port to the SIZE bytes starting at ADDRESS.
68 (open-memory #:start address #:size size)
69 (open-memory #:start address)))
71 (define (type-name kind number)
72 ;; Return the type name of KIND type NUMBER.
73 (type-name-from-descriptor (case kind
78 (memory-backend dereference-word open type-name)))
82 ;;; GDB pretty-printer registration.
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))))
90 (define (make-scm-pretty-printer-worker obj)
91 (define (list->iterator list)
92 (make-iterator list list
95 (match (iterator-progress iter)
96 (() (end-of-iteration))
98 (set-iterator-progress! iter list)
99 (let ((name (format #f "[~a]" n)))
101 (cons name (object->string elt)))))))))
104 (make-pretty-printer-worker
105 "string" ; display hint
106 (lambda (printer) obj)
109 (match (array-shape obj)
112 (make-pretty-printer-worker
113 "array" ; display hint
115 (let ((tag (array-type obj)))
119 (else (format #f "#<~avector>" tag)))))
121 (list->iterator (array->list obj)))))
122 ((inferior-struct? obj)
123 (make-pretty-printer-worker
124 "array" ; display hint
126 (format #f "#<struct ~a>" (inferior-struct-name obj)))
128 (list->iterator (inferior-struct-fields obj)))))
130 (make-pretty-printer-worker
133 (object->string obj))
136 (define %scm-pretty-printer
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)))))))
145 (define* (register-pretty-printer #:optional objfile)
146 (prepend-pretty-printer! objfile %scm-pretty-printer))
148 (register-pretty-printer)
152 ;;; VM stack walking.
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")))
159 (define-record-type <vm-frame>
160 (make-vm-frame ip sp fp saved-ip saved-fp)
165 (saved-ip vm-frame-saved-ip)
166 (saved-fp vm-frame-saved-fp))
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."
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)))))
179 (define (vm-engine-frame? frame)
180 (let ((sym (frame-function frame)))
182 (member (symbol-name sym)
183 '("vm_debug_engine" "vm_regular_engine")))))
186 "Find the scm_vm pointer for the current thread."
187 (let loop ((frame (newest-frame)))
189 (if (vm-engine-frame? frame)
190 (frame-read-var frame "vp")
191 (loop (frame-older frame))))))
193 (define (newest-vm-frame)
194 "Return the newest VM frame or #f."
195 (let ((vp (find-vp)))
197 (vm-frame (value-field vp "ip")
198 (value-field vp "sp")
199 (value-field vp "fp")))))
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))))
209 "Return a SRFI-41 stream of the current VM frame stack."
210 (stream-unfold identity
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)))
225 (define (lookup-symbol-or-false name)
226 (match (lookup-symbol name)
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")))
234 (let ((array (symbol-value array))
235 (count (value->integer (symbol-value count))))
236 (let lp ((start 0) (end count))
238 (let ((n (+ start (ash (- end start) -1))))
239 (if (value<? addr (value-field (value-add array n) "end"))
242 (let ((mei (value-add array start)))
243 (and (value<=? (value-field mei "start") addr)
246 (define (vm-frame-program-debug-info frame)
247 (let ((addr (vm-frame-ip frame)))
248 (and=> (find-mapped-elf-image addr)
250 (let* ((start (value->integer (value-field mei "start")))
251 (size (- (value->integer (value-field mei "end"))
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)))))))
263 (define (vm-frame-function-name frame)
264 (define (default-name)
265 (format #f "0x~x" (value->integer (vm-frame-ip frame))))
267 ((vm-frame-program-debug-info frame)
269 (or (and=> (program-debug-info-name pdi) symbol->string)
272 (let ((ip (vm-frame-ip frame)))
273 (define (ip-in-symbol? name)
274 (let ((sym (lookup-symbol-or-false name)))
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)))))))
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)))))))
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
303 (let ((obj (scm->object (value->integer val) %gdb-memory-backend)))
304 (format port " ~a: ~a~%" name obj))))
305 (vm-frame-locals frame)))
307 (define* (display-vm-frames #:optional (port (current-output-port)))
308 "Display the VM frames on PORT."
309 (stream-for-each (lambda (frame)
310 (dump-vm-frame frame port))
318 (define-syntax compile-time-cond
320 (syntax-case x (else)
321 ((_ (test body ...) clause ...)
322 (if (eval (syntax->datum #'test) (current-module))
324 #'(compile-time-cond clause ...)))
326 #'(begin body ...)))))
329 ((false-if-exception (resolve-interface '(gdb frames)))
330 (use-modules (gdb frames))
332 (define (snarfy-frame-annotator ann)
333 (let* ((frame (annotated-frame-frame ann))
334 (sym (frame-function frame)))
338 (let ((c-name (symbol-name sym)))
339 (match (lookup-symbol (string-append "s_" c-name))
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)))))))
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)
360 #:locals (vm-frame-locals vm-frame)
362 (define (recur gdb-frame gdb-frames vm-frames)
363 (stream-cons gdb-frame
364 (vm-frame-filter gdb-frames vm-frames)))
366 ((or (stream-null? gdb-frames)
367 (not (lookup-symbol "vm_boot_continuation_code")))
370 (let ((gdb-frame (stream-car gdb-frames))
371 (gdb-frames (stream-cdr gdb-frames)))
372 (match (lookup-symbol "vm_boot_continuation_code")
374 (let ((boot-ptr (symbol-value boot-sym)))
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)
386 ((stream-null? vm-frames)
387 (finish children vm-frames))
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)
398 (recur gdb-frame gdb-frames vm-frames))))))))))
400 (add-frame-annotator! "guile-snarf-annotator" snarfy-frame-annotator)
401 (add-frame-filter! "guile-vm-frame-filter" vm-frame-filter))
404 ;;; libguile-2.2-gdb.scm ends here