module/system/repl/debug.scm

   1 ;;; Guile VM debugging facilities
   2
   3 ;;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
   4 ;;;
   5 ;;; This library is free software; you can redistribute it and/or
   6 ;;; modify it under the terms of the GNU Lesser General Public
   7 ;;; License as published by the Free Software Foundation; either
   8 ;;; version 3 of the License, or (at your option) any later version.
   9 ;;;
  10 ;;; This library is distributed in the hope that it will be useful,
  11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;; Lesser General Public License for more details.
  14 ;;;
  15 ;;; You should have received a copy of the GNU Lesser General Public
  16 ;;; License along with this library; if not, write to the Free Software
  17 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Code:
  20
  21 (define-module (system repl debug)
  22   #:use-module (system base pmatch)
  23   #:use-module (system base syntax)
  24   #:use-module (system base language)
  25   #:use-module (system vm vm)
  26   #:use-module (system vm frame)
  27   #:use-module (ice-9 rdelim)
  28   #:use-module (ice-9 pretty-print)
  29   #:use-module (ice-9 format)
  30   #:use-module ((system vm inspect) #:select ((inspect . %inspect)))
  31   #:use-module (system vm program)
  32   #:export (<debug>
  33             make-debug debug? debug-frames debug-index
  34             print-locals print-frame print-frames frame->module
  35             stack->vector narrow-stack->vector))
  36
  37 ;; TODO:
  38 ;;
  39 ;; Update this TODO list ;)
  40 ;; partial meta-commands  (,qui -> ,quit)
  41 ;; eval expression in context of frame
  42 ;; set local variable in frame
  43 ;; step until next instruction
  44 ;; step until next function call/return
  45 ;; step until return from frame
  46 ;; step until different source line
  47 ;; step until greater source line
  48 ;; watch expression
  49 ;; break on a function
  50 ;; remove breakpoints
  51 ;; set printing width
  52 ;; display a truncated backtrace
  53 ;; go to a frame by index
  54 ;; (reuse gdb commands perhaps)
  55 ;; disassemble a function
  56 ;; disassemble the current function
  57 ;; inspect any object
  58 ;; hm, trace via reassigning global vars. tricksy.
  59 ;; (state associated with vm ?)
  60
  61 ;;;
  62 ;;; Debugger
  63 ;;;
  64 ;;; The actual interaction loop of the debugger is run by the repl. This module
  65 ;;; simply exports a data structure to hold the debugger state, along with its
  66 ;;; accessors, and provides some helper functions.
  67 ;;;
  68
  69 (define-record <debug> frames index)
  70
  71 \f
  72
  73 (define (reverse-hashq h)
  74   (let ((ret (make-hash-table)))
  75     (hash-for-each
  76      (lambda (k v)
  77        (hashq-set! ret v (cons k (hashq-ref ret v '()))))
  78      h)
  79     ret))
  80
  81 (define* (print-locals frame #:optional (port (current-output-port))
  82                        #:key (width 72) (per-line-prefix "  "))
  83   (let ((bindings (frame-bindings frame)))
  84     (cond
  85      ((null? bindings)
  86       (format port "~aNo local variables.~%" per-line-prefix))
  87      (else
  88       (format port "~aLocal variables:~%" per-line-prefix)
  89       (for-each
  90        (lambda (binding)
  91          (let ((v (let ((x (frame-local-ref frame (binding:index binding))))
  92                     (if (binding:boxed? binding)
  93                         (variable-ref x)
  94                         x))))
  95            (display per-line-prefix port)
  96            (run-hook before-print-hook v)
  97            (format port "~a~:[~; (boxed)~] = ~v:@y\n"
  98                    (binding:name binding) (binding:boxed? binding) width v)))
  99        (frame-bindings frame))))))
 100
 101 (define* (print-frame frame #:optional (port (current-output-port))
 102                       #:key index (width 72) (full? #f) (last-source #f))
 103   (define (source:pretty-file source)
 104     (if source
 105         (or (source:file source) "current input")
 106         "unknown file"))
 107   (let* ((source (frame-source frame))
 108          (file (source:pretty-file source))
 109          (line (and=> source source:line))
 110          (col (and=> source source:column)))
 111     (if (and file (not (equal? file (source:pretty-file last-source))))
 112         (format port "~&In ~a:~&" file))
 113     (format port "~9@a~:[~*~3_~;~3d~] ~v:@y~%"
 114             (if line (format #f "~a:~a" line col) "")
 115             index index width (frame-call-representation frame))
 116     (if full?
 117         (print-locals frame #:width width
 118                       #:per-line-prefix "     "))))
 119
 120 (define* (print-frames frames
 121                        #:optional (port (current-output-port))
 122                        #:key (width 72) (full? #f) (forward? #f) count)
 123   (let* ((len (vector-length frames))
 124          (lower-idx (if (or (not count) (positive? count))
 125                         0
 126                         (max 0 (+ len count))))
 127          (upper-idx (if (and count (negative? count))
 128                         (1- len)
 129                         (1- (if count (min count len) len))))
 130          (inc (if forward? 1 -1)))
 131     (let lp ((i (if forward? lower-idx upper-idx))
 132              (last-source #f))
 133       (if (<= lower-idx i upper-idx)
 134           (let* ((frame (vector-ref frames i)))
 135             (print-frame frame port #:index i #:width width #:full? full?
 136                          #:last-source last-source)
 137             (lp (+ i inc) (frame-source frame)))))))
 138
 139 ;; Ideally here we would have something much more syntactic, in that a set! to a
 140 ;; local var that is not settable would raise an error, and export etc forms
 141 ;; would modify the module in question: but alack, this is what we have now.
 142 ;; Patches welcome!
 143 (define (frame->module frame)
 144   (let ((proc (frame-procedure frame)))
 145     (if (program? proc)
 146         (let* ((mod (or (program-module proc) (current-module)))
 147                (mod* (make-module)))
 148           (module-use! mod* mod)
 149           (for-each
 150            (lambda (binding)
 151              (let* ((x (frame-local-ref frame (binding:index binding)))
 152                     (var (if (binding:boxed? binding) x (make-variable x))))
 153                (format #t
 154                        "~:[Read-only~;Mutable~] local variable ~a = ~70:@y\n"
 155                        (binding:boxed? binding)
 156                        (binding:name binding)
 157                        (if (variable-bound? var) (variable-ref var) var))
 158                (module-add! mod* (binding:name binding) var)))
 159            (frame-bindings frame))
 160           mod*)
 161         (current-module))))
 162
 163
 164 ;; TODO:
 165 ;;
 166 ;; eval expression in context of frame
 167 ;; set local variable in frame
 168 ;; step until next instruction
 169 ;; step until next function call/return
 170 ;; step until return from frame
 171 ;; step until different source line
 172 ;; step until greater source line
 173 ;; watch expression
 174 ;; break on a function
 175 ;; remove breakpoints
 176 ;; set printing width
 177 ;; display a truncated backtrace
 178 ;; go to a frame by index
 179 ;; (reuse gdb commands perhaps)
 180 ;; disassemble a function
 181 ;; disassemble the current function
 182 ;; inspect any object
 183 ;; hm, trace via reassigning global vars. tricksy.
 184 ;; (state associated with vm ?)
 185
 186 (define (stack->vector stack)
 187   (let* ((len (stack-length stack))
 188          (v (make-vector len)))
 189     (if (positive? len)
 190         (let lp ((i 0) (frame (stack-ref stack 0)))
 191           (if (< i len)
 192               (begin
 193                 (vector-set! v i frame)
 194                 (lp (1+ i) (frame-previous frame))))))
 195     v))
 196
 197 (define (narrow-stack->vector stack . args)
 198   (stack->vector (apply make-stack (stack-ref stack 0) args)))
 199
 200 ;; (define (debug)
 201 ;;   (run-debugger
 202 ;;    (narrow-stack->vector
 203 ;;     (make-stack #t)
 204 ;;     ;; Narrow the `make-stack' frame and the `debug' frame
 205 ;;     2
 206 ;;     ;; Narrow the end of the stack to the most recent start-stack.
 207 ;;     (and (pair? (fluid-ref %stacks))
 208 ;;          (cdar (fluid-ref %stacks))))))
 209