blob: 93ba1a3ea9f80d24e67415e352d03fe4fda342c6 (
about) (
plain)
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
|
;;; GDB debugging support for Guile.
;;;
;;; Copyright 2014 Free Software Foundation, Inc.
;;;
;;; This program is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; This program 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 General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(define-module (guile-gdb)
#:use-module (system base types)
#:use-module ((gdb) #:hide (symbol?))
#:use-module (gdb printing)
#:use-module (srfi srfi-11)
#:export (%gdb-memory-backend
display-vm-frames))
;;; Commentary:
;;;
;;; This file defines GDB extensions to pretty-print 'SCM' objects, and
;;; to walk Guile's virtual machine stack.
;;;
;;; This file is installed under a name that follows the convention that
;;; allows GDB to auto-load it anytime the user is debugging libguile
;;; (info "(gdb) objfile-gdbdotext file").
;;;
;;; Code:
(define (type-name-from-descriptor descriptor-array type-number)
"Return the name of the type TYPE-NUMBER as seen in DESCRIPTOR-ARRAY, or #f
if the information is not available."
(let ((descriptors (lookup-global-symbol descriptor-array)))
(and descriptors
(let ((code (type-code (symbol-type descriptors))))
(or (= TYPE_CODE_ARRAY code)
(= TYPE_CODE_PTR code)))
(let* ((type-descr (value-subscript (symbol-value descriptors)
type-number))
(name (value-field type-descr "name")))
(value->string name)))))
(define %gdb-memory-backend
;; The GDB back-end to access the inferior's memory.
(let ((void* (type-pointer (lookup-type "void"))))
(define (dereference-word address)
;; Return the word at ADDRESS.
(value->integer
(value-dereference (value-cast (make-value address)
(type-pointer void*)))))
(define (open address size)
;; Return a port to the SIZE bytes starting at ADDRESS.
(if size
(open-memory #:start address #:size size)
(open-memory #:start address)))
(define (type-name kind number)
;; Return the type name of KIND type NUMBER.
(type-name-from-descriptor (case kind
((smob) "scm_smobs")
((port) "scm_ptobs"))
number))
(memory-backend dereference-word open type-name)))
;;;
;;; GDB pretty-printer registration.
;;;
(define scm-value->string
(lambda* (value #:optional (backend %gdb-memory-backend))
"Return a representation of value VALUE as a string."
(object->string (scm->object (value->integer value) backend))))
(define %scm-pretty-printer
(make-pretty-printer "SCM"
(lambda (pp value)
(let ((name (type-name (value-type value))))
(and (and name (string=? name "SCM"))
(make-pretty-printer-worker
#f ; display hint
(lambda (printer)
(scm-value->string value %gdb-memory-backend))
#f))))))
(define* (register-pretty-printer #:optional objfile)
(prepend-pretty-printer! objfile %scm-pretty-printer))
(register-pretty-printer)
;;;
;;; VM stack walking.
;;;
(define (find-vm-engine-frame)
"Return the bottom-most frame containing a call to the VM engine."
(define (vm-engine-frame? frame)
(let ((sym (frame-function frame)))
(and sym
(member (symbol-name sym)
'("vm_debug_engine" "vm_regular_engine")))))
(let loop ((frame (newest-frame)))
(and frame
(if (vm-engine-frame? frame)
frame
(loop (frame-older frame))))))
(define (vm-stack-pointer)
"Return the current value of the VM stack pointer or #f."
(let ((frame (find-vm-engine-frame)))
(and frame
(frame-read-var frame "sp"))))
(define (vm-frame-pointer)
"Return the current value of the VM frame pointer or #f."
(let ((frame (find-vm-engine-frame)))
(and frame
(frame-read-var frame "fp"))))
(define* (display-vm-frames #:optional (port (current-output-port)))
"Display the VM frames on PORT."
(define (display-objects start end)
;; Display all the objects (arguments and local variables) located
;; between START and END.
(let loop ((number 0)
(address start))
(when (and (> start 0) (<= address end))
(let ((object (dereference-word %gdb-memory-backend address)))
;; TODO: Push onto GDB's value history.
(format port " slot ~a -> ~s~%"
number (scm->object object %gdb-memory-backend)))
(loop (+ 1 number) (+ address %word-size)))))
(let loop ((number 0)
(sp (value->integer (vm-stack-pointer)))
(fp (value->integer (vm-frame-pointer))))
(unless (zero? fp)
(let-values (((ra mvra link proc)
(vm-frame fp %gdb-memory-backend)))
(format port "#~a ~s~%" number (scm->object proc %gdb-memory-backend))
(display-objects fp sp)
(loop (+ 1 number) (- fp (* 5 %word-size)) link)))))
;; See libguile/frames.h.
(define* (vm-frame fp #:optional (backend %gdb-memory-backend))
"Return the components of the stack frame at FP."
(let ((caller (dereference-word backend (- fp %word-size)))
(ra (dereference-word backend (- fp (* 2 %word-size))))
(mvra (dereference-word backend (- fp (* 3 %word-size))))
(link (dereference-word backend (- fp (* 4 %word-size)))))
(values ra mvra link caller)))
;;; libguile-2.2-gdb.scm ends here
|
