mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
6bfd298c56
* libguile/libguile-2.0-gdb.scm (scm-value->integer): New procedure. (%scm-pretty-printer): Use it instead of 'value->integer'.
216 lines
7.6 KiB
Scheme
216 lines
7.6 KiB
Scheme
;;; GDB debugging support for Guile.
|
||
;;;
|
||
;;; Copyright 2014, 2015 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)
|
||
#:use-module (ice-9 match)
|
||
#: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 (scm-value->integer value)
|
||
"Return the integer value of VALUE, which is assumed to be a GDB value
|
||
corresponding to an 'SCM' object."
|
||
(let ((type (type-strip-typedefs (value-type value))))
|
||
(cond ((= (type-code type) TYPE_CODE_UNION)
|
||
;; SCM_DEBUG_TYPING_STRICTNESS = 2
|
||
(value->integer (value-field (value-field value "n")
|
||
"n")))
|
||
(else
|
||
;; SCM_DEBUG_TYPING_STRICTNESS = 1
|
||
(value->integer value)))))
|
||
|
||
(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 (make-scm-pretty-printer-worker obj)
|
||
(define (list->iterator list)
|
||
(make-iterator list list
|
||
(let ((n 0))
|
||
(lambda (iter)
|
||
(match (iterator-progress iter)
|
||
(() (end-of-iteration))
|
||
((elt . list)
|
||
(set-iterator-progress! iter list)
|
||
(let ((name (format #f "[~a]" n)))
|
||
(set! n (1+ n))
|
||
(cons name (object->string elt)))))))))
|
||
(cond
|
||
((string? obj)
|
||
(make-pretty-printer-worker
|
||
"string" ; display hint
|
||
(lambda (printer) obj)
|
||
#f))
|
||
((and (array? obj)
|
||
(match (array-shape obj)
|
||
(((0 _)) #t)
|
||
(_ #f)))
|
||
(make-pretty-printer-worker
|
||
"array" ; display hint
|
||
(lambda (printer)
|
||
(let ((tag (array-type obj)))
|
||
(case tag
|
||
((#t) "#<vector>")
|
||
((b) "#<bitvector>")
|
||
(else (format #f "#<~avector>" tag)))))
|
||
(lambda (printer)
|
||
(list->iterator (array->list obj)))))
|
||
((inferior-struct? obj)
|
||
(make-pretty-printer-worker
|
||
"array" ; display hint
|
||
(lambda (printer)
|
||
(format #f "#<struct ~a>" (inferior-struct-name obj)))
|
||
(lambda (printer)
|
||
(list->iterator (inferior-struct-fields obj)))))
|
||
(else
|
||
(make-pretty-printer-worker
|
||
#f ; display hint
|
||
(lambda (printer)
|
||
(object->string obj))
|
||
#f))))
|
||
|
||
(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-scm-pretty-printer-worker
|
||
(scm->object (scm-value->integer value) %gdb-memory-backend)))))))
|
||
|
||
(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
|