mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-18 09:40:25 +02:00
Code Activity

Add GDB extension to support Guile.

Browse source 
* libguile/libguile-2.0-gdb.scm: New file.
* libguile/Makefile.am (install-data-local): New target.  Based on code
  from GNU libstdc++.
  (EXTRA_DIST): Add 'libguile-2.0-gdb.scm'.
* doc/ref/api-debug.texi (GDB Support): New section.
This commit is contained in:
Ludovic Courtès 2014-02-17 15:40:34 +01:00
parent 5f4b817df9
commit 359f46a41c
3 changed files with 237 additions and 9 deletions
Download patch file Download diff file Expand all files Collapse all files

164
libguile/libguile-2.0-gdb.scm Normal file
View file

@ -0,0 +1,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.0-gdb.scm ends here