From: Ludovic Courtès Date: Tue, 21 Jan 2020 16:51:37 +0000 (+0100) Subject: build: Actually install libguile-3.0-gdb.scm. X-Git-Tag: v3.0.1~37 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=491cc23f93f622e067e120f875424ed76d73cf8f;p=platform%2Fupstream%2Fguile.git build: Actually install libguile-3.0-gdb.scm. 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@. --- diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 43411c5a7..d4cfec7a3 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -1,6 +1,6 @@ ## 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. @@ -491,9 +491,9 @@ INSTANTIATE = \ -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, @@ -731,7 +731,7 @@ EXTRA_DIST = ChangeLog-scm ChangeLog-threads \ 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 diff --git a/libguile/libguile-2.2-gdb.scm b/libguile/libguile-2.2-gdb.scm deleted file mode 100644 index e0b573a20..000000000 --- a/libguile/libguile-2.2-gdb.scm +++ /dev/null @@ -1,451 +0,0 @@ -;;; 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 . - -(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))) - - -;;; -;;; 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) "#") - ((b) "#") - (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 "#" (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) - - -;;; -;;; 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 - (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 (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) - (valueinteger (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)))) - - -;;; -;;; 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: - ;; . - ((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 diff --git a/libguile/libguile-3.0-gdb.scm b/libguile/libguile-3.0-gdb.scm new file mode 100644 index 000000000..e0b573a20 --- /dev/null +++ b/libguile/libguile-3.0-gdb.scm @@ -0,0 +1,451 @@ +;;; 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 . + +(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))) + + +;;; +;;; 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) "#") + ((b) "#") + (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 "#" (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) + + +;;; +;;; 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 + (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 (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) + (valueinteger (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)))) + + +;;; +;;; 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: + ;; . + ((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