Commit | Line | Data |
---|---|---|
359f46a4 LC |
1 | ;;; GDB debugging support for Guile. |
2 | ;;; | |
3 | ;;; Copyright 2014 Free Software Foundation, Inc. | |
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) | |
20 | #:use-module ((gdb) #:hide (symbol?)) | |
21 | #:use-module (gdb printing) | |
22 | #:use-module (srfi srfi-11) | |
23 | #:export (%gdb-memory-backend | |
24 | display-vm-frames)) | |
25 | ||
26 | ;;; Commentary: | |
27 | ;;; | |
28 | ;;; This file defines GDB extensions to pretty-print 'SCM' objects, and | |
29 | ;;; to walk Guile's virtual machine stack. | |
30 | ;;; | |
31 | ;;; This file is installed under a name that follows the convention that | |
32 | ;;; allows GDB to auto-load it anytime the user is debugging libguile | |
33 | ;;; (info "(gdb) objfile-gdbdotext file"). | |
34 | ;;; | |
35 | ;;; Code: | |
36 | ||
37 | (define (type-name-from-descriptor descriptor-array type-number) | |
38 | "Return the name of the type TYPE-NUMBER as seen in DESCRIPTOR-ARRAY, or #f | |
39 | if the information is not available." | |
40 | (let ((descriptors (lookup-global-symbol descriptor-array))) | |
41 | (and descriptors | |
42 | (let ((code (type-code (symbol-type descriptors)))) | |
43 | (or (= TYPE_CODE_ARRAY code) | |
44 | (= TYPE_CODE_PTR code))) | |
45 | (let* ((type-descr (value-subscript (symbol-value descriptors) | |
46 | type-number)) | |
47 | (name (value-field type-descr "name"))) | |
48 | (value->string name))))) | |
49 | ||
50 | (define %gdb-memory-backend | |
51 | ;; The GDB back-end to access the inferior's memory. | |
52 | (let ((void* (type-pointer (lookup-type "void")))) | |
53 | (define (dereference-word address) | |
54 | ;; Return the word at ADDRESS. | |
55 | (value->integer | |
56 | (value-dereference (value-cast (make-value address) | |
57 | (type-pointer void*))))) | |
58 | ||
59 | (define (open address size) | |
60 | ;; Return a port to the SIZE bytes starting at ADDRESS. | |
61 | (if size | |
62 | (open-memory #:start address #:size size) | |
63 | (open-memory #:start address))) | |
64 | ||
65 | (define (type-name kind number) | |
66 | ;; Return the type name of KIND type NUMBER. | |
67 | (type-name-from-descriptor (case kind | |
68 | ((smob) "scm_smobs") | |
69 | ((port) "scm_ptobs")) | |
70 | number)) | |
71 | ||
72 | (memory-backend dereference-word open type-name))) | |
73 | ||
74 | \f | |
75 | ;;; | |
76 | ;;; GDB pretty-printer registration. | |
77 | ;;; | |
78 | ||
79 | (define scm-value->string | |
80 | (lambda* (value #:optional (backend %gdb-memory-backend)) | |
81 | "Return a representation of value VALUE as a string." | |
82 | (object->string (scm->object (value->integer value) backend)))) | |
83 | ||
84 | (define %scm-pretty-printer | |
85 | (make-pretty-printer "SCM" | |
86 | (lambda (pp value) | |
87 | (let ((name (type-name (value-type value)))) | |
88 | (and (and name (string=? name "SCM")) | |
89 | (make-pretty-printer-worker | |
90 | #f ; display hint | |
91 | (lambda (printer) | |
92 | (scm-value->string value %gdb-memory-backend)) | |
93 | #f)))))) | |
94 | ||
95 | (define* (register-pretty-printer #:optional objfile) | |
96 | (prepend-pretty-printer! objfile %scm-pretty-printer)) | |
97 | ||
98 | (register-pretty-printer) | |
99 | ||
100 | \f | |
101 | ;;; | |
102 | ;;; VM stack walking. | |
103 | ;;; | |
104 | ||
105 | (define (find-vm-engine-frame) | |
106 | "Return the bottom-most frame containing a call to the VM engine." | |
107 | (define (vm-engine-frame? frame) | |
108 | (let ((sym (frame-function frame))) | |
109 | (and sym | |
110 | (member (symbol-name sym) | |
111 | '("vm_debug_engine" "vm_regular_engine"))))) | |
112 | ||
113 | (let loop ((frame (newest-frame))) | |
114 | (and frame | |
115 | (if (vm-engine-frame? frame) | |
116 | frame | |
117 | (loop (frame-older frame)))))) | |
118 | ||
119 | (define (vm-stack-pointer) | |
120 | "Return the current value of the VM stack pointer or #f." | |
121 | (let ((frame (find-vm-engine-frame))) | |
122 | (and frame | |
123 | (frame-read-var frame "sp")))) | |
124 | ||
125 | (define (vm-frame-pointer) | |
126 | "Return the current value of the VM frame pointer or #f." | |
127 | (let ((frame (find-vm-engine-frame))) | |
128 | (and frame | |
129 | (frame-read-var frame "fp")))) | |
130 | ||
131 | (define* (display-vm-frames #:optional (port (current-output-port))) | |
132 | "Display the VM frames on PORT." | |
133 | (define (display-objects start end) | |
134 | ;; Display all the objects (arguments and local variables) located | |
135 | ;; between START and END. | |
136 | (let loop ((number 0) | |
137 | (address start)) | |
138 | (when (and (> start 0) (<= address end)) | |
139 | (let ((object (dereference-word %gdb-memory-backend address))) | |
140 | ;; TODO: Push onto GDB's value history. | |
141 | (format port " slot ~a -> ~s~%" | |
142 | number (scm->object object %gdb-memory-backend))) | |
143 | (loop (+ 1 number) (+ address %word-size))))) | |
144 | ||
145 | (let loop ((number 0) | |
146 | (sp (value->integer (vm-stack-pointer))) | |
147 | (fp (value->integer (vm-frame-pointer)))) | |
148 | (unless (zero? fp) | |
149 | (let-values (((ra mvra link proc) | |
150 | (vm-frame fp %gdb-memory-backend))) | |
151 | (format port "#~a ~s~%" number (scm->object proc %gdb-memory-backend)) | |
152 | (display-objects fp sp) | |
153 | (loop (+ 1 number) (- fp (* 5 %word-size)) link))))) | |
154 | ||
155 | ;; See libguile/frames.h. | |
156 | (define* (vm-frame fp #:optional (backend %gdb-memory-backend)) | |
157 | "Return the components of the stack frame at FP." | |
158 | (let ((caller (dereference-word backend (- fp %word-size))) | |
159 | (ra (dereference-word backend (- fp (* 2 %word-size)))) | |
160 | (mvra (dereference-word backend (- fp (* 3 %word-size)))) | |
161 | (link (dereference-word backend (- fp (* 4 %word-size))))) | |
162 | (values ra mvra link caller))) | |
163 | ||
475772ea | 164 | ;;; libguile-2.2-gdb.scm ends here |