mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 14:00:21 +02:00
De-bitrot libguile-2.2-gdb.scm
* libguile/libguile-2.2-gdb.scm: Update to work with Guile 2.2 stacks. Represent the VM stack as a SRFI-41 stream, which will work better with the frame filter interface. Add support for getting the vm frame's function name, if possible.
This commit is contained in:
Andy Wingo
parent
577eab817c
commit
ef52b3992c
1 changed files with 155 additions and 50 deletions
|
|
@ -1,6 +1,6 @@
|
|||
;;; GDB debugging support for Guile.
|
||||
;;;
|
||||
;;; Copyright 2014 Free Software Foundation, Inc.
|
||||
;;; 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
|
||||
|
|
@ -17,9 +17,15 @@
|
|||
|
||||
(define-module (guile-gdb)
|
||||
#:use-module (system base types)
|
||||
#:use-module ((gdb) #:hide (symbol?))
|
||||
#:use-module (system vm debug)
|
||||
#:use-module ((gdb) #:hide (symbol? frame?))
|
||||
#:use-module ((gdb) #:select ((symbol? . gdb:symbol?) (frame? . gdb:frame?)))
|
||||
#:use-module (gdb printing)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-11)
|
||||
#:use-module (srfi srfi-41)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 binary-ports)
|
||||
#:export (%gdb-memory-backend
|
||||
display-vm-frames))
|
||||
|
||||
|
|
@ -102,63 +108,162 @@ if the information is not available."
|
|||
;;; 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")))))
|
||||
(define ip-type (type-pointer (lookup-type "scm_t_uint32")))
|
||||
(define fp-type (type-pointer (lookup-type "SCM")))
|
||||
(define sp-type (type-pointer (lookup-type "SCM")))
|
||||
|
||||
(define-record-type <vm-frame>
|
||||
(make-vm-frame ip sp fp saved-ip saved-fp)
|
||||
vm-frame?
|
||||
(ip vm-frame-ip)
|
||||
(sp vm-frame-sp)
|
||||
(fp vm-frame-fp)
|
||||
(saved-ip vm-frame-saved-ip)
|
||||
(saved-fp vm-frame-saved-fp))
|
||||
|
||||
;; See libguile/frames.h.
|
||||
(define* (vm-frame ip sp fp #:optional (backend %gdb-memory-backend))
|
||||
"Return the components of the stack frame at FP."
|
||||
(make-vm-frame ip
|
||||
sp
|
||||
fp
|
||||
(value-dereference (value-cast (value-sub fp 1)
|
||||
(type-pointer ip-type)))
|
||||
(value-dereference (value-cast (value-sub fp 2)
|
||||
(type-pointer fp-type)))))
|
||||
|
||||
(define (vm-engine-frame? frame)
|
||||
(let ((sym (frame-function frame)))
|
||||
(and sym
|
||||
(member (symbol-name sym)
|
||||
'("vm_debug_engine" "vm_regular_engine")))))
|
||||
|
||||
(define (find-vp)
|
||||
"Find the scm_vm pointer for the current thread."
|
||||
(let loop ((frame (newest-frame)))
|
||||
(and frame
|
||||
(if (vm-engine-frame? frame)
|
||||
frame
|
||||
(frame-read-var frame "vp")
|
||||
(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 (newest-vm-frame)
|
||||
"Return the newest VM frame or #f."
|
||||
(let ((vp (find-vp)))
|
||||
(and vp
|
||||
(vm-frame (value-field vp "ip")
|
||||
(value-field vp "sp")
|
||||
(value-field vp "fp")))))
|
||||
|
||||
(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* (vm-frame-older frame #:optional (backend %gdb-memory-backend))
|
||||
(let ((ip (vm-frame-saved-ip frame))
|
||||
(sp (value-sub (vm-frame-fp frame) 3))
|
||||
(fp (vm-frame-saved-fp frame)))
|
||||
(and (not (zero? (value->integer fp)))
|
||||
(vm-frame ip sp fp backend))))
|
||||
|
||||
(define (vm-frames)
|
||||
"Return a SRFI-41 stream of the current VM frame stack."
|
||||
(stream-unfold identity
|
||||
vm-frame?
|
||||
vm-frame-older
|
||||
(newest-vm-frame)))
|
||||
|
||||
(define (vm-frame-locals frame)
|
||||
(let ((fp (vm-frame-fp frame))
|
||||
(sp (vm-frame-sp frame)))
|
||||
(let lp ((slot 0) (ptr fp))
|
||||
(if (value<=? ptr sp)
|
||||
(acons (string-append "v" (number->string slot))
|
||||
(value-dereference ptr)
|
||||
(lp (1+ slot) (value-add ptr 1)))
|
||||
'()))))
|
||||
|
||||
(define (lookup-symbol-or-false name)
|
||||
(match (lookup-symbol name)
|
||||
(#f #f)
|
||||
((sym _) sym)))
|
||||
|
||||
(define (find-mapped-elf-image addr)
|
||||
(let ((array (lookup-symbol-or-false "mapped_elf_images"))
|
||||
(count (lookup-symbol-or-false "mapped_elf_images_count")))
|
||||
(and array count
|
||||
(let ((array (symbol-value array))
|
||||
(count (value->integer (symbol-value count))))
|
||||
(let lp ((start 0) (end count))
|
||||
(if (< start end)
|
||||
(let ((n (+ start (ash (- end start) -1))))
|
||||
(if (value<? addr (value-field (value-add array n) "end"))
|
||||
(lp start n)
|
||||
(lp (1+ n) end)))
|
||||
(let ((mei (value-add array start)))
|
||||
(and (value<=? (value-field mei "start") addr)
|
||||
mei))))))))
|
||||
|
||||
(define (vm-frame-program-debug-info frame)
|
||||
(let ((addr (vm-frame-ip frame)))
|
||||
(and=> (find-mapped-elf-image addr)
|
||||
(lambda (mei)
|
||||
(let* ((start (value->integer (value-field mei "start")))
|
||||
(size (- (value->integer (value-field mei "end"))
|
||||
start))
|
||||
(mem-port (open-memory #:start start #:size size))
|
||||
(bv (get-bytevector-all mem-port))
|
||||
(ctx (debug-context-from-image bv)))
|
||||
;; The image is in this process at "bv", but in the
|
||||
;; inferior at mei.start. Therefore we relocate addr
|
||||
;; before we look for the PDI.
|
||||
(let ((addr (+ (value->integer addr)
|
||||
(- (debug-context-base ctx) start))))
|
||||
(find-program-debug-info addr ctx)))))))
|
||||
|
||||
(define (vm-frame-function-name frame)
|
||||
(define (default-name)
|
||||
(format #f "0x~x" (value->integer (vm-frame-ip frame))))
|
||||
(cond
|
||||
((vm-frame-program-debug-info frame)
|
||||
=> (lambda (pdi)
|
||||
(or (and=> (program-debug-info-name pdi) symbol->string)
|
||||
(default-name))))
|
||||
(else
|
||||
(let ((ip (vm-frame-ip frame)))
|
||||
(define (ip-in-symbol? name)
|
||||
(let ((sym (lookup-symbol-or-false name)))
|
||||
(and sym
|
||||
(let* ((val (symbol-value sym))
|
||||
(size (type-sizeof (value-type val)))
|
||||
(char* (type-pointer (arch-char-type (current-arch))))
|
||||
(val-as-char* (value-cast val char*)))
|
||||
(and (value<=? val-as-char* ip)
|
||||
(value<? ip (value-add val-as-char* size)))))))
|
||||
(cond
|
||||
((ip-in-symbol? "vm_boot_continuation_code") "[boot continuation]")
|
||||
;; FIXME: For subrs, read the name from slot 0 in the frame.
|
||||
((ip-in-symbol? "subr_stub_code") "[subr call]")
|
||||
((ip-in-symbol? "vm_builtin_apply_code") "apply")
|
||||
((ip-in-symbol? "vm_builtin_values_code") "values")
|
||||
((ip-in-symbol? "vm_builtin_abort_to_prompt_code") "abort-to-prompt")
|
||||
((ip-in-symbol? "vm_builtin_call_with_values_code") "call-with-values")
|
||||
((ip-in-symbol? "vm_builtin_call_with_current_continuation_code")
|
||||
"call-with-current-continuation")
|
||||
((ip-in-symbol? "continuation_stub_code") "[continuation]")
|
||||
((ip-in-symbol? "compose_continuation_code") "[delimited continuation]")
|
||||
((ip-in-symbol? "foreign_stub_code") "[ffi call]")
|
||||
(else (default-name)))))))
|
||||
|
||||
(define* (dump-vm-frame frame #:optional (port (current-output-port)))
|
||||
(format port " name: ~a~%" (vm-frame-function-name frame))
|
||||
(format port " ip: 0x~x~%" (value->integer (vm-frame-ip frame)))
|
||||
(format port " fp: 0x~x~%" (value->integer (vm-frame-fp frame)))
|
||||
(for-each (match-lambda
|
||||
((name . val)
|
||||
(let ((obj (scm->object (value->integer val) %gdb-memory-backend)))
|
||||
(format port " ~a: ~a~%" name obj))))
|
||||
(vm-frame-locals frame)))
|
||||
|
||||
(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)))
|
||||
(stream-for-each (lambda (frame)
|
||||
(dump-vm-frame frame port))
|
||||
(vm-frames)))
|
||||
|
||||
;;; libguile-2.2-gdb.scm ends here
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue