summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2015-02-17 11:02:52 +0100
committerAndy Wingo <wingo@pobox.com>2015-02-17 11:02:52 +0100
commit47612fd68ae93815c08a92b504f9334b224c557e (patch)
tree3a379addc5699314d78d379652949ac5527ae014
parentef52b3992c95be4a891dc147990145e3656b0e62 (diff)
downloadguile-47612fd68ae93815c08a92b504f9334b224c557e.tar.gz
GDB support: add frame annotators and filters
These features depend on a patch to GDB that has not been merged yet. If GDB doesn't support the annotator/filter interface, the code have no effect. * libguile/libguile-2.2-gdb.scm (compile-time-cond): New helper. (snarfy-frame-annotator): Simple annotator that gives subr names for snarfed gsubrs. (vm-frame-filter): New filter that interleaves Scheme frames with C frames on the stack when the user asks for a backtrace.
-rw-r--r--libguile/libguile-2.2-gdb.scm91
1 files changed, 91 insertions, 0 deletions
diff --git a/libguile/libguile-2.2-gdb.scm b/libguile/libguile-2.2-gdb.scm
index 3a8af0d9b..6c8d8a361 100644
--- a/libguile/libguile-2.2-gdb.scm
+++ b/libguile/libguile-2.2-gdb.scm
@@ -266,4 +266,95 @@ if the information is not available."
(dump-vm-frame frame port))
(vm-frames)))
+
+;;;
+;;; Frame filters.
+;;;
+
+(define-syntax compile-time-cond
+ (lambda (x)
+ (syntax-case x (else)
+ ((_ (test body ...) clause ...)
+ (if (eval (syntax->datum #'test) (current-module))
+ #'(begin body ...)
+ #'(compile-time-cond clause ...)))
+ ((_ (else body ...))
+ #'(begin body ...)))))
+
+(compile-time-cond
+ ((false-if-exception (resolve-interface '(gdb frames)))
+ (use-modules (gdb frames))
+
+ (define (snarfy-frame-annotator ann)
+ (let* ((frame (annotated-frame-frame ann))
+ (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)))
+ (reannotate-frame ann #:function-name name)))))))
+ ann)))
+
+ (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))))
+ (reannotate-frame gdb-frame
+ #:function-name (vm-frame-function-name vm-frame)
+ #:address ip
+ #:filename #f
+ #:line #f
+ #: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? (annotated-frame-frame gdb-frame))
+ (let lp ((children (reverse
+ (annotated-frame-children gdb-frame)))
+ (vm-frames vm-frames))
+ (define (finish reversed-children vm-frames)
+ (let ((children (reverse reversed-children)))
+ (recur (reannotate-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-annotator! "guile-snarf-annotator" snarfy-frame-annotator)
+ (add-frame-filter! "guile-vm-frame-filter" vm-frame-filter))
+ (else #f))
+
;;; libguile-2.2-gdb.scm ends here