X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/12dfe6568c82ba0e55286d1b604044f948dd16f2..refs/heads/wip:/libguile/libguile-2.2-gdb.scm

diff --git a/libguile/libguile-2.2-gdb.scm b/libguile/libguile-2.2-gdb.scm
index 93ba1a3ea..5a9bd254a 100644
--- a/libguile/libguile-2.2-gdb.scm
+++ b/libguile/libguile-2.2-gdb.scm
@@ -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))
 
@@ -81,16 +87,60 @@ if the information is not available."
     "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-pretty-printer-worker
-                                 #f              ; display hint
-                                 (lambda (printer)
-                                   (scm-value->string value %gdb-memory-backend))
-                                 #f))))))
+  (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))
@@ -102,63 +152,267 @@ 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)
+    "[unknown]")
+  (cond
+   ((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."
-  (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)))))
+  (stream-for-each (lambda (frame)
+                     (dump-vm-frame frame port))
+                   (vm-frames)))
 
-;; 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)))
+
+;;;
+;;; 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
+ ((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