| 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 | |
| 164 | ;;; libguile-2.2-gdb.scm ends here |