libguile/libguile-2.2-gdb.scm

   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