Reported by brandelune on #guile.
* libguile/libguile-2.2-gdb.scm: Rename to...
* libguile/libguile-3.0-gdb.scm: ... this.
* libguile/Makefile.am (install-data-hook): Replace hard-coded "2.2"
with @GUILE_EFFECTIVE_VERSION@.
## Process this file with Automake to create Makefile.in
##
-## Copyright (C) 1998-2004, 2006-2014, 2016-2019
+## Copyright (C) 1998-2004, 2006-2014, 2016-2020
## Free Software Foundation, Inc.
##
## This file is part of GUILE.
-e 's,[@]pkglibdir[@],$(pkglibdir),g' \
-e 's,[@]GUILE_EFFECTIVE_VERSION[@],$(GUILE_EFFECTIVE_VERSION),g'
-install-data-hook: libguile-2.2-gdb.scm
+install-data-hook: libguile-@GUILE_EFFECTIVE_VERSION@-gdb.scm
@$(MKDIR_P) $(DESTDIR)$(libdir)
-## We want to install libguile-2.2-gdb.scm as SOMETHING-gdb.scm.
+## We want to install libguile-X.Y-gdb.scm as SOMETHING-gdb.scm.
## SOMETHING is the full name of the final library. We want to ignore
## symlinks, the .la file, and any previous -gdb.py file. This is
## inherently fragile, but there does not seem to be a better option,
cpp-E.syms cpp-E.c cpp-SIG.syms cpp-SIG.c \
c-tokenize.lex \
scmconfig.h.top libgettext.h unidata_to_charset.pl libguile.map \
- vm-operations.h libguile-2.2-gdb.scm \
+ vm-operations.h libguile-@GUILE_EFFECTIVE_VERSION@-gdb.scm \
$(lightening_c_files) $(lightening_extra_files)
# $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \
# guile-procedures.txt guile.texi
+++ /dev/null
-;;; GDB debugging support for Guile.
-;;;
-;;; Copyright 2014, 2015, 2017 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)
-
- ;; Note: (system vm debug) is 2.2-specific, but GDB might be built
- ;; with Guile 2.0.
- #:autoload (system vm debug) (debug-context-from-image
- debug-context-base
- find-program-debug-info)
-
- #: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))
-
-;;; 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:
-
-;; At run time, make sure we load (system base types) from the Guile
-;; being debugged rather than from the Guile GDB is linked against.
-(set! %load-path
- (cons "@pkgdatadir@/@GUILE_EFFECTIVE_VERSION@" %load-path))
-(set! %load-compiled-path
- (cons "@pkglibdir@/@GUILE_EFFECTIVE_VERSION@/site-ccache" %load-compiled-path))
-(reload-module (resolve-module '(system base types)))
-
-
-(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)))
-
-\f
-;;;
-;;; 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 (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 (value->integer value) %gdb-memory-backend)))))))
-
-(define* (register-pretty-printer #:optional objfile)
- (prepend-pretty-printer! objfile %scm-pretty-printer))
-
-(register-pretty-printer)
-
-\f
-;;;
-;;; VM stack walking.
-;;;
-
-(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 uint-type (type-pointer (lookup-type "scm_t_uintptr")))
-
-(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
-
- ;; fp[0] is the return address.
- (value-dereference (value-cast fp (type-pointer ip-type)))
-
- ;; fp[1] is the offset to the previous frame pointer.
- (value-add fp
- (value->integer
- (value-dereference
- (value-cast (value-add fp 1)
- (type-pointer uint-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-read-var frame "vp")
- (loop (frame-older frame))))))
-
-(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-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 ip)))
- (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)
- "[unknown]")
- (cond
- ((false-if-exception (vm-frame-program-debug-info frame))
- => (lambda (pdi)
- (or (and=> (program-debug-info-name pdi) symbol->string)
- "[anonymous]")))
- (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 (vm-frame-source frame)
- (let* ((ip (value->integer (vm-frame-ip frame)))
- (pdi (vm-frame-program-debug-info frame)))
- (and pdi
- (find-source-for-addr (program-debug-info-addr pdi)
- (program-debug-info-context pdi)))))
-
-(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."
- (stream-for-each (lambda (frame)
- (dump-vm-frame frame port))
- (vm-frames)))
-
-(register-command!
- (make-command "guile-backtrace"
- #:command-class COMMAND_STACK
- #:doc "Display a backtrace of Guile's VM stack for the \
-current thread"
- #:invoke (lambda (self args from-tty)
- (display-vm-frames))))
-
-\f
-;;;
-;;; Frame filters.
-;;;
-
-(define-syntax compile-time-cond
- (lambda (x)
- (syntax-case x ()
- ((_ (test body ...) clause ...)
- (if (eval (syntax->datum #'test) (current-module))
- #'(begin body ...)
- #'(compile-time-cond clause ...)))
- ((_)
- #'(begin)))))
-
-(compile-time-cond
- ;; What follows depends on (gdb frame-filters), which unfortunately has
- ;; not yet been merged in GDB:
- ;; <https://sourceware.org/ml/gdb-patches/2015-02/msg00362.html>.
- ((false-if-exception (resolve-interface '(gdb frame-filters)))
- (use-modules (gdb frame-filters))
-
- (define (snarfy-frame-decorator dec)
- (let* ((frame (decorated-frame-frame dec))
- (sym (frame-function frame)))
- (or
- (and sym
- (gdb:symbol? sym)
- (let ((c-name (symbol-name sym)))
- (match (lookup-symbol (string-append "s_" c-name))
- (#f #f)
- ((scheme-name-sym _)
- (and (string-prefix?
- "const char ["
- (type-print-name (symbol-type scheme-name-sym)))
- (let* ((scheme-name-value (symbol-value scheme-name-sym))
- (scheme-name (value->string scheme-name-value))
- (name (format #f "~a [~a]" scheme-name c-name)))
- (redecorate-frame dec #:function-name name)))))))
- dec)))
-
- (define* (vm-frame-filter gdb-frames #:optional (vm-frames (vm-frames)))
- (define (synthesize-frame gdb-frame vm-frame)
- (let* ((ip (value->integer (vm-frame-ip vm-frame)))
- (source (vm-frame-source vm-frame)))
- (redecorate-frame gdb-frame
- #:function-name (vm-frame-function-name vm-frame)
- #:address ip
- #:filename (and=> source source-file)
- #:line (and=> source source-line-for-user)
- #:arguments '()
- #:locals (vm-frame-locals vm-frame)
- #:children '())))
- (define (recur gdb-frame gdb-frames vm-frames)
- (stream-cons gdb-frame
- (vm-frame-filter gdb-frames vm-frames)))
- (cond
- ((or (stream-null? gdb-frames)
- (not (lookup-symbol "vm_boot_continuation_code")))
- gdb-frames)
- (else
- (let ((gdb-frame (stream-car gdb-frames))
- (gdb-frames (stream-cdr gdb-frames)))
- (match (lookup-symbol "vm_boot_continuation_code")
- ((boot-sym _)
- (let ((boot-ptr (symbol-value boot-sym)))
- (cond
- ((vm-engine-frame? (decorated-frame-frame gdb-frame))
- (let lp ((children (reverse
- (decorated-frame-children gdb-frame)))
- (vm-frames vm-frames))
- (define (finish reversed-children vm-frames)
- (let ((children (reverse reversed-children)))
- (recur (redecorate-frame gdb-frame #:children children)
- gdb-frames
- vm-frames)))
- (cond
- ((stream-null? vm-frames)
- (finish children vm-frames))
- (else
- (let* ((vm-frame (stream-car vm-frames))
- (vm-frames (stream-cdr vm-frames)))
- (if (value=? (vm-frame-ip vm-frame) boot-ptr)
- ;; Drop the boot frame and finish.
- (finish children vm-frames)
- (lp (cons (synthesize-frame gdb-frame vm-frame)
- children)
- vm-frames)))))))
- (else
- (recur gdb-frame gdb-frames vm-frames))))))))))
-
- (add-frame-filter!
- (make-decorating-frame-filter "guile-snarf-decorator"
- snarfy-frame-decorator
- #:objfile (current-objfile)))
- (add-frame-filter!
- (make-frame-filter "guile-vm-frame-filter"
- vm-frame-filter
- #:objfile (current-objfile))))
- (#t #f))
-
-;;; libguile-2.2-gdb.scm ends here
--- /dev/null
+;;; GDB debugging support for Guile.
+;;;
+;;; Copyright 2014, 2015, 2017 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)
+
+ ;; Note: (system vm debug) is 2.2-specific, but GDB might be built
+ ;; with Guile 2.0.
+ #:autoload (system vm debug) (debug-context-from-image
+ debug-context-base
+ find-program-debug-info)
+
+ #: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))
+
+;;; 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:
+
+;; At run time, make sure we load (system base types) from the Guile
+;; being debugged rather than from the Guile GDB is linked against.
+(set! %load-path
+ (cons "@pkgdatadir@/@GUILE_EFFECTIVE_VERSION@" %load-path))
+(set! %load-compiled-path
+ (cons "@pkglibdir@/@GUILE_EFFECTIVE_VERSION@/site-ccache" %load-compiled-path))
+(reload-module (resolve-module '(system base types)))
+
+
+(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)))
+
+\f
+;;;
+;;; 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 (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 (value->integer value) %gdb-memory-backend)))))))
+
+(define* (register-pretty-printer #:optional objfile)
+ (prepend-pretty-printer! objfile %scm-pretty-printer))
+
+(register-pretty-printer)
+
+\f
+;;;
+;;; VM stack walking.
+;;;
+
+(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 uint-type (type-pointer (lookup-type "scm_t_uintptr")))
+
+(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
+
+ ;; fp[0] is the return address.
+ (value-dereference (value-cast fp (type-pointer ip-type)))
+
+ ;; fp[1] is the offset to the previous frame pointer.
+ (value-add fp
+ (value->integer
+ (value-dereference
+ (value-cast (value-add fp 1)
+ (type-pointer uint-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-read-var frame "vp")
+ (loop (frame-older frame))))))
+
+(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-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 ip)))
+ (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)
+ "[unknown]")
+ (cond
+ ((false-if-exception (vm-frame-program-debug-info frame))
+ => (lambda (pdi)
+ (or (and=> (program-debug-info-name pdi) symbol->string)
+ "[anonymous]")))
+ (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 (vm-frame-source frame)
+ (let* ((ip (value->integer (vm-frame-ip frame)))
+ (pdi (vm-frame-program-debug-info frame)))
+ (and pdi
+ (find-source-for-addr (program-debug-info-addr pdi)
+ (program-debug-info-context pdi)))))
+
+(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."
+ (stream-for-each (lambda (frame)
+ (dump-vm-frame frame port))
+ (vm-frames)))
+
+(register-command!
+ (make-command "guile-backtrace"
+ #:command-class COMMAND_STACK
+ #:doc "Display a backtrace of Guile's VM stack for the \
+current thread"
+ #:invoke (lambda (self args from-tty)
+ (display-vm-frames))))
+
+\f
+;;;
+;;; Frame filters.
+;;;
+
+(define-syntax compile-time-cond
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (test body ...) clause ...)
+ (if (eval (syntax->datum #'test) (current-module))
+ #'(begin body ...)
+ #'(compile-time-cond clause ...)))
+ ((_)
+ #'(begin)))))
+
+(compile-time-cond
+ ;; What follows depends on (gdb frame-filters), which unfortunately has
+ ;; not yet been merged in GDB:
+ ;; <https://sourceware.org/ml/gdb-patches/2015-02/msg00362.html>.
+ ((false-if-exception (resolve-interface '(gdb frame-filters)))
+ (use-modules (gdb frame-filters))
+
+ (define (snarfy-frame-decorator dec)
+ (let* ((frame (decorated-frame-frame dec))
+ (sym (frame-function frame)))
+ (or
+ (and sym
+ (gdb:symbol? sym)
+ (let ((c-name (symbol-name sym)))
+ (match (lookup-symbol (string-append "s_" c-name))
+ (#f #f)
+ ((scheme-name-sym _)
+ (and (string-prefix?
+ "const char ["
+ (type-print-name (symbol-type scheme-name-sym)))
+ (let* ((scheme-name-value (symbol-value scheme-name-sym))
+ (scheme-name (value->string scheme-name-value))
+ (name (format #f "~a [~a]" scheme-name c-name)))
+ (redecorate-frame dec #:function-name name)))))))
+ dec)))
+
+ (define* (vm-frame-filter gdb-frames #:optional (vm-frames (vm-frames)))
+ (define (synthesize-frame gdb-frame vm-frame)
+ (let* ((ip (value->integer (vm-frame-ip vm-frame)))
+ (source (vm-frame-source vm-frame)))
+ (redecorate-frame gdb-frame
+ #:function-name (vm-frame-function-name vm-frame)
+ #:address ip
+ #:filename (and=> source source-file)
+ #:line (and=> source source-line-for-user)
+ #:arguments '()
+ #:locals (vm-frame-locals vm-frame)
+ #:children '())))
+ (define (recur gdb-frame gdb-frames vm-frames)
+ (stream-cons gdb-frame
+ (vm-frame-filter gdb-frames vm-frames)))
+ (cond
+ ((or (stream-null? gdb-frames)
+ (not (lookup-symbol "vm_boot_continuation_code")))
+ gdb-frames)
+ (else
+ (let ((gdb-frame (stream-car gdb-frames))
+ (gdb-frames (stream-cdr gdb-frames)))
+ (match (lookup-symbol "vm_boot_continuation_code")
+ ((boot-sym _)
+ (let ((boot-ptr (symbol-value boot-sym)))
+ (cond
+ ((vm-engine-frame? (decorated-frame-frame gdb-frame))
+ (let lp ((children (reverse
+ (decorated-frame-children gdb-frame)))
+ (vm-frames vm-frames))
+ (define (finish reversed-children vm-frames)
+ (let ((children (reverse reversed-children)))
+ (recur (redecorate-frame gdb-frame #:children children)
+ gdb-frames
+ vm-frames)))
+ (cond
+ ((stream-null? vm-frames)
+ (finish children vm-frames))
+ (else
+ (let* ((vm-frame (stream-car vm-frames))
+ (vm-frames (stream-cdr vm-frames)))
+ (if (value=? (vm-frame-ip vm-frame) boot-ptr)
+ ;; Drop the boot frame and finish.
+ (finish children vm-frames)
+ (lp (cons (synthesize-frame gdb-frame vm-frame)
+ children)
+ vm-frames)))))))
+ (else
+ (recur gdb-frame gdb-frames vm-frames))))))))))
+
+ (add-frame-filter!
+ (make-decorating-frame-filter "guile-snarf-decorator"
+ snarfy-frame-decorator
+ #:objfile (current-objfile)))
+ (add-frame-filter!
+ (make-frame-filter "guile-vm-frame-filter"
+ vm-frame-filter
+ #:objfile (current-objfile))))
+ (#t #f))
+
+;;; libguile-2.2-gdb.scm ends here
projects / platform / upstream / guile.git / commitdiff