[bpt/guile.git] / libguile / libguile-2.2-gdb.scm

;;; GDB debugging support for Guile.
;;;
;;; 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
;;; 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)
  #: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))

;;; 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:

(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 %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))))))

(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-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-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 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)
    (format #f "0x~x" (value->integer (vm-frame-ip frame))))
  (cond
   ((vm-frame-program-debug-info frame)
    => (lambda (pdi)
         (or (and=> (program-debug-info-name pdi) symbol->string)
             (default-name))))
   (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* (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)))

;;; libguile-2.2-gdb.scm ends here
Commit	Line	Data
359f46a4 LC	1	;;; GDB debugging support for Guile.
359f46a4 LC	2	;;;
ef52b399	3	;;; Copyright 2014, 2015 Free Software Foundation, Inc.
359f46a4 LC	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)
ef52b399 AW	20	#:use-module (system vm debug)
	21	#:use-module ((gdb) #:hide (symbol? frame?))
	22	#:use-module ((gdb) #:select ((symbol? . gdb:symbol?) (frame? . gdb:frame?)))
359f46a4	23	#:use-module (gdb printing)
ef52b399	24	#:use-module (srfi srfi-9)
359f46a4	25	#:use-module (srfi srfi-11)
ef52b399 AW	26	#:use-module (srfi srfi-41)
	27	#:use-module (ice-9 match)
	28	#:use-module (ice-9 binary-ports)
359f46a4 LC	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 %scm-pretty-printer
	91	(make-pretty-printer "SCM"
	92	(lambda (pp value)
93	(let ((name (type-name (value-type value))))
94	(and (and name (string=? name "SCM"))
95	(make-pretty-printer-worker
96	#f ; display hint
97	(lambda (printer)
98	(scm-value->string value %gdb-memory-backend))
99	#f))))))
100
101	(define* (register-pretty-printer #:optional objfile)
102	(prepend-pretty-printer! objfile %scm-pretty-printer))
103
104	(register-pretty-printer)
105
106	\f
107	;;;
108	;;; VM stack walking.
109	;;;
110
ef52b399 AW	111	(define ip-type (type-pointer (lookup-type "scm_t_uint32")))
	112	(define fp-type (type-pointer (lookup-type "SCM")))
	113	(define sp-type (type-pointer (lookup-type "SCM")))
359f46a4	114
ef52b399 AW	115	(define-record-type <vm-frame>
	116	(make-vm-frame ip sp fp saved-ip saved-fp)
	117	vm-frame?
	118	(ip vm-frame-ip)
	119	(sp vm-frame-sp)
	120	(fp vm-frame-fp)
	121	(saved-ip vm-frame-saved-ip)
	122	(saved-fp vm-frame-saved-fp))
	123
	124	;; See libguile/frames.h.
	125	(define* (vm-frame ip sp fp #:optional (backend %gdb-memory-backend))
	126	"Return the components of the stack frame at FP."
	127	(make-vm-frame ip
	128	sp
	129	fp
	130	(value-dereference (value-cast (value-sub fp 1)
	131	(type-pointer ip-type)))
	132	(value-dereference (value-cast (value-sub fp 2)
	133	(type-pointer fp-type)))))
	134
	135	(define (vm-engine-frame? frame)
	136	(let ((sym (frame-function frame)))
	137	(and sym
	138	(member (symbol-name sym)
	139	'("vm_debug_engine" "vm_regular_engine")))))
	140
	141	(define (find-vp)
	142	"Find the scm_vm pointer for the current thread."
359f46a4 LC	143	(let loop ((frame (newest-frame)))
	144	(and frame
	145	(if (vm-engine-frame? frame)
ef52b399	146	(frame-read-var frame "vp")
359f46a4 LC	147	(loop (frame-older frame))))))
359f46a4 LC	148
ef52b399 AW	149	(define (newest-vm-frame)
	150	"Return the newest VM frame or #f."
	151	(let ((vp (find-vp)))
	152	(and vp
	153	(vm-frame (value-field vp "ip")
	154	(value-field vp "sp")
	155	(value-field vp "fp")))))
359f46a4	156
ef52b399 AW	157	(define* (vm-frame-older frame #:optional (backend %gdb-memory-backend))
	158	(let ((ip (vm-frame-saved-ip frame))
	159	(sp (value-sub (vm-frame-fp frame) 3))
	160	(fp (vm-frame-saved-fp frame)))
	161	(and (not (zero? (value->integer fp)))
	162	(vm-frame ip sp fp backend))))
	163
	164	(define (vm-frames)
	165	"Return a SRFI-41 stream of the current VM frame stack."
	166	(stream-unfold identity
	167	vm-frame?
	168	vm-frame-older
	169	(newest-vm-frame)))
	170
	171	(define (vm-frame-locals frame)
	172	(let ((fp (vm-frame-fp frame))
	173	(sp (vm-frame-sp frame)))
	174	(let lp ((slot 0) (ptr fp))
	175	(if (value<=? ptr sp)
	176	(acons (string-append "v" (number->string slot))
	177	(value-dereference ptr)
	178	(lp (1+ slot) (value-add ptr 1)))
	179	'()))))
	180
	181	(define (lookup-symbol-or-false name)
	182	(match (lookup-symbol name)
	183	(#f #f)
	184	((sym _) sym)))
	185
	186	(define (find-mapped-elf-image addr)
	187	(let ((array (lookup-symbol-or-false "mapped_elf_images"))
	188	(count (lookup-symbol-or-false "mapped_elf_images_count")))
	189	(and array count
	190	(let ((array (symbol-value array))
	191	(count (value->integer (symbol-value count))))
	192	(let lp ((start 0) (end count))
	193	(if (< start end)
	194	(let ((n (+ start (ash (- end start) -1))))
	195	(if (value<? addr (value-field (value-add array n) "end"))
	196	(lp start n)
	197	(lp (1+ n) end)))
	198	(let ((mei (value-add array start)))
	199	(and (value<=? (value-field mei "start") addr)
	200	mei))))))))
	201
	202	(define (vm-frame-program-debug-info frame)
	203	(let ((addr (vm-frame-ip frame)))
	204	(and=> (find-mapped-elf-image addr)
	205	(lambda (mei)
	206	(let* ((start (value->integer (value-field mei "start")))
	207	(size (- (value->integer (value-field mei "end"))
	208	start))
	209	(mem-port (open-memory #:start start #:size size))
	210	(bv (get-bytevector-all mem-port))
	211	(ctx (debug-context-from-image bv)))
	212	;; The image is in this process at "bv", but in the
	213	;; inferior at mei.start. Therefore we relocate addr
	214	;; before we look for the PDI.
	215	(let ((addr (+ (value->integer addr)
	216	(- (debug-context-base ctx) start))))
	217	(find-program-debug-info addr ctx)))))))
	218
	219	(define (vm-frame-function-name frame)
	220	(define (default-name)
221	(format #f "0x~x" (value->integer (vm-frame-ip frame))))
222	(cond
223	((vm-frame-program-debug-info frame)
224	=> (lambda (pdi)
225	(or (and=> (program-debug-info-name pdi) symbol->string)
226	(default-name))))
227	(else
228	(let ((ip (vm-frame-ip frame)))
229	(define (ip-in-symbol? name)
230	(let ((sym (lookup-symbol-or-false name)))
231	(and sym
232	(let* ((val (symbol-value sym))
233	(size (type-sizeof (value-type val)))
234	(char* (type-pointer (arch-char-type (current-arch))))
235	(val-as-char* (value-cast val char*)))
236	(and (value<=? val-as-char* ip)
237	(value<? ip (value-add val-as-char* size)))))))
238	(cond
239	((ip-in-symbol? "vm_boot_continuation_code") "[boot continuation]")
240	;; FIXME: For subrs, read the name from slot 0 in the frame.
241	((ip-in-symbol? "subr_stub_code") "[subr call]")
242	((ip-in-symbol? "vm_builtin_apply_code") "apply")
243	((ip-in-symbol? "vm_builtin_values_code") "values")
244	((ip-in-symbol? "vm_builtin_abort_to_prompt_code") "abort-to-prompt")
245	((ip-in-symbol? "vm_builtin_call_with_values_code") "call-with-values")
246	((ip-in-symbol? "vm_builtin_call_with_current_continuation_code")
247	"call-with-current-continuation")
248	((ip-in-symbol? "continuation_stub_code") "[continuation]")
249	((ip-in-symbol? "compose_continuation_code") "[delimited continuation]")
250	((ip-in-symbol? "foreign_stub_code") "[ffi call]")
251	(else (default-name)))))))
252
253	(define* (dump-vm-frame frame #:optional (port (current-output-port)))
254	(format port " name: ~a~%" (vm-frame-function-name frame))
255	(format port " ip: 0x~x~%" (value->integer (vm-frame-ip frame)))
256	(format port " fp: 0x~x~%" (value->integer (vm-frame-fp frame)))
257	(for-each (match-lambda
258	((name . val)
259	(let ((obj (scm->object (value->integer val) %gdb-memory-backend)))
260	(format port " ~a: ~a~%" name obj))))
261	(vm-frame-locals frame)))
359f46a4 LC	262
	263	(define* (display-vm-frames #:optional (port (current-output-port)))
	264	"Display the VM frames on PORT."
ef52b399 AW	265	(stream-for-each (lambda (frame)
	266	(dump-vm-frame frame port))
	267	(vm-frames)))
359f46a4	268
475772ea	269	;;; libguile-2.2-gdb.scm ends here