libguile/libguile-2.2-gdb.scm

   1 ;;; GDB debugging support for Guile.
   2 ;;;
   3 ;;; Copyright 2014, 2015 Free Software Foundation, Inc.
   4 ;;;
   5 ;;; This program is free software; you can redistribute it and/or modify it
   6 ;;; under the terms of the GNU General Public License as published by
   7 ;;; the Free Software Foundation; either version 3 of the License, or (at
   8 ;;; your option) any later version.
   9 ;;;
  10 ;;; This program is distributed in the hope that it will be useful, but
  11 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;; GNU General Public License for more details.
  14 ;;;
  15 ;;; You should have received a copy of the GNU General Public License
  16 ;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 (define-module (guile-gdb)
  19   #:use-module (system base types)
  20   #:use-module (system vm debug)
  21   #:use-module ((gdb) #:hide (symbol? frame?))
  22   #:use-module ((gdb) #:select ((symbol? . gdb:symbol?) (frame? . gdb:frame?)))
  23   #:use-module (gdb printing)
  24   #:use-module (srfi srfi-9)
  25   #:use-module (srfi srfi-11)
  26   #:use-module (srfi srfi-41)
  27   #:use-module (ice-9 match)
  28   #:use-module (ice-9 binary-ports)
  29   #:export (%gdb-memory-backend
  30             display-vm-frames))
  31
  32 ;;; Commentary:
  33 ;;;
  34 ;;; This file defines GDB extensions to pretty-print 'SCM' objects, and
  35 ;;; to walk Guile's virtual machine stack.
  36 ;;;
  37 ;;; This file is installed under a name that follows the convention that
  38 ;;; allows GDB to auto-load it anytime the user is debugging libguile
  39 ;;; (info "(gdb) objfile-gdbdotext file").
  40 ;;;
  41 ;;; Code:
  42
  43 (define (type-name-from-descriptor descriptor-array type-number)
  44   "Return the name of the type TYPE-NUMBER as seen in DESCRIPTOR-ARRAY, or #f
  45 if the information is not available."
  46   (let ((descriptors (lookup-global-symbol descriptor-array)))
  47     (and descriptors
  48          (let ((code (type-code (symbol-type descriptors))))
  49            (or (= TYPE_CODE_ARRAY code)
  50                (= TYPE_CODE_PTR code)))
  51          (let* ((type-descr (value-subscript (symbol-value descriptors)
  52                                              type-number))
  53                 (name       (value-field type-descr "name")))
  54            (value->string name)))))
  55
  56 (define %gdb-memory-backend
  57   ;; The GDB back-end to access the inferior's memory.
  58   (let ((void* (type-pointer (lookup-type "void"))))
  59     (define (dereference-word address)
  60       ;; Return the word at ADDRESS.
  61       (value->integer
  62        (value-dereference (value-cast (make-value address)
  63                                       (type-pointer void*)))))
  64
  65     (define (open address size)
  66       ;; Return a port to the SIZE bytes starting at ADDRESS.
  67       (if size
  68           (open-memory #:start address #:size size)
  69           (open-memory #:start address)))
  70
  71     (define (type-name kind number)
  72       ;; Return the type name of KIND type NUMBER.
  73       (type-name-from-descriptor (case kind
  74                                    ((smob) "scm_smobs")
  75                                    ((port) "scm_ptobs"))
  76                                  number))
  77
  78     (memory-backend dereference-word open type-name)))
  79
  80 \f
  81 ;;;
  82 ;;; GDB pretty-printer registration.
  83 ;;;
  84
  85 (define scm-value->string
  86   (lambda* (value #:optional (backend %gdb-memory-backend))
  87     "Return a representation of value VALUE as a string."
  88     (object->string (scm->object (value->integer value) backend))))
  89
  90 (define (make-scm-pretty-printer-worker obj)
  91   (define (list->iterator list)
  92     (make-iterator list list
  93                    (let ((n 0))
  94                      (lambda (iter)
  95                        (match (iterator-progress iter)
  96                          (() (end-of-iteration))
  97                          ((elt . list)
  98                           (set-iterator-progress! iter list)
  99                           (let ((name (format #f "[~a]" n)))
 100                             (set! n (1+ n))
 101                             (cons name (object->string elt)))))))))
 102   (cond
 103    ((string? obj)
 104     (make-pretty-printer-worker
 105      "string" ; display hint
 106      (lambda (printer) obj)
 107      #f))
 108    ((and (array? obj)
 109          (match (array-shape obj)
 110            (((0 _)) #t)
 111            (_ #f)))
 112     (make-pretty-printer-worker
 113      "array" ; display hint
 114      (lambda (printer)
 115        (let ((tag (array-type obj)))
 116          (case tag
 117            ((#t) "#<vector>")
 118            ((b) "#<bitvector>")
 119            (else (format #f "#<~avector>" tag)))))
 120      (lambda (printer)
 121        (list->iterator (array->list obj)))))
 122    ((inferior-struct? obj)
 123     (make-pretty-printer-worker
 124      "array" ; display hint
 125      (lambda (printer)
 126        (format #f "#<struct ~a>" (inferior-struct-name obj)))
 127      (lambda (printer)
 128        (list->iterator (inferior-struct-fields obj)))))
 129    (else
 130     (make-pretty-printer-worker
 131      #f                                 ; display hint
 132      (lambda (printer)
 133        (object->string obj))
 134      #f))))
 135
 136 (define %scm-pretty-printer
 137   (make-pretty-printer
 138    "SCM"
 139    (lambda (pp value)
 140      (let ((name (type-name (value-type value))))
 141        (and (and name (string=? name "SCM"))
 142             (make-scm-pretty-printer-worker
 143              (scm->object (value->integer value) %gdb-memory-backend)))))))
 144
 145 (define* (register-pretty-printer #:optional objfile)
 146   (prepend-pretty-printer! objfile %scm-pretty-printer))
 147
 148 (register-pretty-printer)
 149
 150 \f
 151 ;;;
 152 ;;; VM stack walking.
 153 ;;;
 154
 155 (define ip-type (type-pointer (lookup-type "scm_t_uint32")))
 156 (define fp-type (type-pointer (lookup-type "SCM")))
 157 (define sp-type (type-pointer (lookup-type "SCM")))
 158
 159 (define-record-type <vm-frame>
 160   (make-vm-frame ip sp fp saved-ip saved-fp)
 161   vm-frame?
 162   (ip vm-frame-ip)
 163   (sp vm-frame-sp)
 164   (fp vm-frame-fp)
 165   (saved-ip vm-frame-saved-ip)
 166   (saved-fp vm-frame-saved-fp))
 167
 168 ;; See libguile/frames.h.
 169 (define* (vm-frame ip sp fp #:optional (backend %gdb-memory-backend))
 170   "Return the components of the stack frame at FP."
 171   (make-vm-frame ip
 172                  sp
 173                  fp
 174                  (value-dereference (value-cast (value-sub fp 1)
 175                                                 (type-pointer ip-type)))
 176                  (value-dereference (value-cast (value-sub fp 2)
 177                                                 (type-pointer fp-type)))))
 178
 179 (define (vm-engine-frame? frame)
 180   (let ((sym (frame-function frame)))
 181     (and sym
 182          (member (symbol-name sym)
 183                  '("vm_debug_engine" "vm_regular_engine")))))
 184
 185 (define (find-vp)
 186   "Find the scm_vm pointer for the current thread."
 187   (let loop ((frame (newest-frame)))
 188     (and frame
 189          (if (vm-engine-frame? frame)
 190              (frame-read-var frame "vp")
 191              (loop (frame-older frame))))))
 192
 193 (define (newest-vm-frame)
 194   "Return the newest VM frame or #f."
 195   (let ((vp (find-vp)))
 196     (and vp
 197          (vm-frame (value-field vp "ip")
 198                    (value-field vp "sp")
 199                    (value-field vp "fp")))))
 200
 201 (define* (vm-frame-older frame #:optional (backend %gdb-memory-backend))
 202   (let ((ip (vm-frame-saved-ip frame))
 203         (sp (value-sub (vm-frame-fp frame) 3))
 204         (fp (vm-frame-saved-fp frame)))
 205     (and (not (zero? (value->integer fp)))
 206          (vm-frame ip sp fp backend))))
 207
 208 (define (vm-frames)
 209   "Return a SRFI-41 stream of the current VM frame stack."
 210   (stream-unfold identity
 211                  vm-frame?
 212                  vm-frame-older
 213                  (newest-vm-frame)))
 214
 215 (define (vm-frame-locals frame)
 216   (let ((fp (vm-frame-fp frame))
 217         (sp (vm-frame-sp frame)))
 218     (let lp ((slot 0) (ptr fp))
 219       (if (value<=? ptr sp)
 220           (acons (string-append "v" (number->string slot))
 221                  (value-dereference ptr)
 222                  (lp (1+ slot) (value-add ptr 1)))
 223           '()))))
 224
 225 (define (lookup-symbol-or-false name)
 226   (match (lookup-symbol name)
 227     (#f #f)
 228     ((sym _) sym)))
 229
 230 (define (find-mapped-elf-image addr)
 231   (let ((array (lookup-symbol-or-false "mapped_elf_images"))
 232         (count (lookup-symbol-or-false "mapped_elf_images_count")))
 233     (and array count
 234          (let ((array (symbol-value array))
 235                (count (value->integer (symbol-value count))))
 236            (let lp ((start 0) (end count))
 237              (if (< start end)
 238                  (let ((n (+ start (ash (- end start) -1))))
 239                    (if (value<? addr (value-field (value-add array n) "end"))
 240                        (lp start n)
 241                        (lp (1+ n) end)))
 242                  (let ((mei (value-add array start)))
 243                    (and (value<=? (value-field mei "start") addr)
 244                         mei))))))))
 245
 246 (define (vm-frame-program-debug-info frame)
 247   (let ((addr (vm-frame-ip frame)))
 248     (and=> (find-mapped-elf-image addr)
 249            (lambda (mei)
 250              (let* ((start (value->integer (value-field mei "start")))
 251                     (size (- (value->integer (value-field mei "end"))
 252                              start))
 253                     (mem-port (open-memory #:start start #:size size))
 254                     (bv (get-bytevector-all mem-port))
 255                     (ctx (debug-context-from-image bv)))
 256                ;; The image is in this process at "bv", but in the
 257                ;; inferior at mei.start.  Therefore we relocate addr
 258                ;; before we look for the PDI.
 259                (let ((addr (+ (value->integer addr)
 260                               (- (debug-context-base ctx) start))))
 261                  (find-program-debug-info addr ctx)))))))
 262
 263 (define (vm-frame-function-name frame)
 264   (define (default-name)
 265     (format #f "0x~x" (value->integer (vm-frame-ip frame))))
 266   (cond
 267    ((vm-frame-program-debug-info frame)
 268     => (lambda (pdi)
 269          (or (and=> (program-debug-info-name pdi) symbol->string)
 270              (default-name))))
 271    (else
 272     (let ((ip (vm-frame-ip frame)))
 273       (define (ip-in-symbol? name)
 274         (let ((sym (lookup-symbol-or-false name)))
 275           (and sym
 276                (let* ((val (symbol-value sym))
 277                       (size (type-sizeof (value-type val)))
 278                       (char* (type-pointer (arch-char-type (current-arch))))
 279                       (val-as-char* (value-cast val char*)))
 280                  (and (value<=? val-as-char* ip)
 281                       (value<? ip (value-add val-as-char* size)))))))
 282       (cond
 283        ((ip-in-symbol? "vm_boot_continuation_code") "[boot continuation]")
 284        ;; FIXME: For subrs, read the name from slot 0 in the frame.
 285        ((ip-in-symbol? "subr_stub_code") "[subr call]")
 286        ((ip-in-symbol? "vm_builtin_apply_code") "apply")
 287        ((ip-in-symbol? "vm_builtin_values_code") "values")
 288        ((ip-in-symbol? "vm_builtin_abort_to_prompt_code") "abort-to-prompt")
 289        ((ip-in-symbol? "vm_builtin_call_with_values_code") "call-with-values")
 290        ((ip-in-symbol? "vm_builtin_call_with_current_continuation_code")
 291         "call-with-current-continuation")
 292        ((ip-in-symbol? "continuation_stub_code") "[continuation]")
 293        ((ip-in-symbol? "compose_continuation_code") "[delimited continuation]")
 294        ((ip-in-symbol? "foreign_stub_code") "[ffi call]")
 295        (else (default-name)))))))
 296
 297 (define* (dump-vm-frame frame #:optional (port (current-output-port)))
 298   (format port "  name: ~a~%" (vm-frame-function-name frame))
 299   (format port "  ip: 0x~x~%" (value->integer (vm-frame-ip frame)))
 300   (format port "  fp: 0x~x~%" (value->integer (vm-frame-fp frame)))
 301   (for-each (match-lambda
 302              ((name . val)
 303               (let ((obj (scm->object (value->integer val) %gdb-memory-backend)))
 304                 (format port "    ~a: ~a~%" name obj))))
 305             (vm-frame-locals frame)))
 306
 307 (define* (display-vm-frames #:optional (port (current-output-port)))
 308   "Display the VM frames on PORT."
 309   (stream-for-each (lambda (frame)
 310                      (dump-vm-frame frame port))
 311                    (vm-frames)))
 312
 313 \f
 314 ;;;
 315 ;;; Frame filters.
 316 ;;;
 317
 318 (define-syntax compile-time-cond
 319   (lambda (x)
 320     (syntax-case x (else)
 321       ((_ (test body ...) clause ...)
 322        (if (eval (syntax->datum #'test) (current-module))
 323            #'(begin body ...)
 324            #'(compile-time-cond clause ...)))
 325       ((_ (else body ...))
 326        #'(begin body ...)))))
 327
 328 (compile-time-cond
 329  ((false-if-exception (resolve-interface '(gdb frames)))
 330   (use-modules (gdb frames))
 331
 332   (define (snarfy-frame-annotator ann)
 333     (let* ((frame (annotated-frame-frame ann))
 334            (sym (frame-function frame)))
 335       (or
 336        (and sym
 337             (gdb:symbol? sym)
 338             (let ((c-name (symbol-name sym)))
 339               (match (lookup-symbol (string-append "s_" c-name))
 340                 (#f #f)
 341                 ((scheme-name-sym _)
 342                  (and (string-prefix?
 343                        "const char ["
 344                        (type-print-name (symbol-type scheme-name-sym)))
 345                       (let* ((scheme-name-value (symbol-value scheme-name-sym))
 346                              (scheme-name (value->string scheme-name-value))
 347                              (name (format #f "~a [~a]" scheme-name c-name)))
 348                         (reannotate-frame ann #:function-name name)))))))
 349        ann)))
 350
 351   (define* (vm-frame-filter gdb-frames #:optional (vm-frames (vm-frames)))
 352     (define (synthesize-frame gdb-frame vm-frame)
 353       (let* ((ip (value->integer (vm-frame-ip vm-frame))))
 354         (reannotate-frame gdb-frame
 355                           #:function-name (vm-frame-function-name vm-frame)
 356                           #:address ip
 357                           #:filename #f
 358                           #:line #f
 359                           #:arguments '()
 360                           #:locals (vm-frame-locals vm-frame)
 361                           #:children '())))
 362     (define (recur gdb-frame gdb-frames vm-frames)
 363       (stream-cons gdb-frame
 364                    (vm-frame-filter gdb-frames vm-frames)))
 365     (cond
 366      ((or (stream-null? gdb-frames)
 367           (not (lookup-symbol "vm_boot_continuation_code")))
 368       gdb-frames)
 369      (else
 370       (let ((gdb-frame (stream-car gdb-frames))
 371             (gdb-frames (stream-cdr gdb-frames)))
 372         (match (lookup-symbol "vm_boot_continuation_code")
 373           ((boot-sym _)
 374            (let ((boot-ptr (symbol-value boot-sym)))
 375              (cond
 376               ((vm-engine-frame? (annotated-frame-frame gdb-frame))
 377                (let lp ((children (reverse
 378                                    (annotated-frame-children gdb-frame)))
 379                         (vm-frames vm-frames))
 380                  (define (finish reversed-children vm-frames)
 381                    (let ((children (reverse reversed-children)))
 382                      (recur (reannotate-frame gdb-frame #:children children)
 383                             gdb-frames
 384                             vm-frames)))
 385                  (cond
 386                   ((stream-null? vm-frames)
 387                    (finish children vm-frames))
 388                   (else
 389                    (let* ((vm-frame (stream-car vm-frames))
 390                           (vm-frames (stream-cdr vm-frames)))
 391                      (if (value=? (vm-frame-ip vm-frame) boot-ptr)
 392                          ;; Drop the boot frame and finish.
 393                          (finish children vm-frames)
 394                          (lp (cons (synthesize-frame gdb-frame vm-frame)
 395                                    children)
 396                              vm-frames)))))))
 397               (else
 398                (recur gdb-frame gdb-frames vm-frames))))))))))
 399
 400   (add-frame-annotator! "guile-snarf-annotator" snarfy-frame-annotator)
 401   (add-frame-filter! "guile-vm-frame-filter" vm-frame-filter))
 402  (else #f))
 403
 404 ;;; libguile-2.2-gdb.scm ends here