module/system/repl/debug.scm

   1 ;;; Guile VM debugging facilities
   2
   3 ;;; Copyright (C) 2001, 2009, 2010, 2011, 2013 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?
  34             debug-frames debug-index debug-error-message
  35             terminal-width
  36             print-registers print-locals print-frame print-frames frame->module
  37             stack->vector narrow-stack->vector
  38             frame->stack-vector))
  39
  40 ;; TODO:
  41 ;;
  42 ;; eval expression in context of frame
  43 ;; set local variable in frame
  44 ;; step until greater source line
  45 ;; watch expression
  46 ;; set printing width
  47 ;; disassemble the current function
  48 ;; inspect any object
  49
  50 ;;;
  51 ;;; Debugger
  52 ;;;
  53 ;;; The actual interaction loop of the debugger is run by the repl. This module
  54 ;;; simply exports a data structure to hold the debugger state, along with its
  55 ;;; accessors, and provides some helper functions.
  56 ;;;
  57
  58 (define-record <debug> frames index error-message)
  59
  60 \f
  61
  62 ;; A fluid, because terminals are usually implicitly associated with
  63 ;; threads.
  64 ;;
  65 (define terminal-width
  66   (let ((set-width (make-fluid)))
  67     (case-lambda
  68       (()
  69        (or (fluid-ref set-width)
  70            (let ((w (false-if-exception (string->number (getenv "COLUMNS")))))
  71              (and (integer? w) (exact? w) (> w 0) w))
  72            72))
  73       ((w)
  74        (if (or (not w) (and (integer? w) (exact? w) (> w 0)))
  75            (fluid-set! set-width w)
  76            (error "Expected a column number (a positive integer)" w))))))
  77
  78
  79 \f
  80
  81 (define (reverse-hashq h)
  82   (let ((ret (make-hash-table)))
  83     (hash-for-each
  84      (lambda (k v)
  85        (hashq-set! ret v (cons k (hashq-ref ret v '()))))
  86      h)
  87     ret))
  88
  89 (define* (print-registers frame #:optional (port (current-output-port))
  90                           #:key (per-line-prefix "  "))
  91   (define (print fmt val)
  92     (display per-line-prefix port)
  93     (run-hook before-print-hook val)
  94     (format port fmt val))
  95
  96   (format port "~aRegisters:~%" per-line-prefix)
  97   (print "ip = #x~x" (frame-instruction-pointer frame))
  98   (when (program? (frame-procedure frame))
  99     (let ((code (program-code (frame-procedure frame))))
 100       (format port " (#x~x~@d)" code
 101               (- (frame-instruction-pointer frame) code))))
 102   (newline port)
 103   (print "sp = #x~x\n" (frame-stack-pointer frame))
 104   (print "fp = #x~x\n" (frame-address frame)))
 105
 106 (define* (print-locals frame #:optional (port (current-output-port))
 107                        #:key (width (terminal-width)) (per-line-prefix "  "))
 108   (let ((bindings (frame-bindings frame)))
 109     (cond
 110      ((null? bindings)
 111       (format port "~aNo local variables.~%" per-line-prefix))
 112      (else
 113       (format port "~aLocal variables:~%" per-line-prefix)
 114       (for-each
 115        (lambda (binding)
 116          (let ((v (let ((x (frame-local-ref frame (binding:index binding))))
 117                     (if (binding:boxed? binding)
 118                         (variable-ref x)
 119                         x))))
 120            (display per-line-prefix port)
 121            (run-hook before-print-hook v)
 122            (format port "~a~:[~; (boxed)~] = ~v:@y\n"
 123                    (binding:name binding) (binding:boxed? binding) width v)))
 124        (frame-bindings frame))))))
 125
 126 (define* (print-frame frame #:optional (port (current-output-port))
 127                       #:key index (width (terminal-width)) (full? #f)
 128                       (last-source #f) next-source?)
 129   (define (source:pretty-file source)
 130     (if source
 131         (or (source:file source) "current input")
 132         "unknown file"))
 133   (let* ((source (frame-source frame))
 134          (file (source:pretty-file source))
 135          (line (and=> source source:line-for-user))
 136          (col (and=> source source:column)))
 137     (if (and file (not (equal? file (source:pretty-file last-source))))
 138         (format port "~&In ~a:~&" file))
 139     (format port "~9@a~:[~*~3_~;~3d~] ~v:@y~%"
 140             (if line (format #f "~a:~a" line col) "")
 141             index index width (frame-call-representation frame))
 142     (if full?
 143         (print-locals frame #:width width
 144                       #:per-line-prefix "     "))))
 145
 146 (define* (print-frames frames
 147                        #:optional (port (current-output-port))
 148                        #:key (width (terminal-width)) (full? #f)
 149                        (forward? #f) count)
 150   (let* ((len (vector-length frames))
 151          (lower-idx (if (or (not count) (positive? count))
 152                         0
 153                         (max 0 (+ len count))))
 154          (upper-idx (if (and count (negative? count))
 155                         (1- len)
 156                         (1- (if count (min count len) len))))
 157          (inc (if forward? 1 -1)))
 158     (let lp ((i (if forward? lower-idx upper-idx))
 159              (last-source #f))
 160       (if (<= lower-idx i upper-idx)
 161           (let* ((frame (vector-ref frames i)))
 162             (print-frame frame port #:index i #:width width #:full? full?
 163                          #:last-source last-source)
 164             (lp (+ i inc)
 165                 (frame-source frame)))))))
 166
 167 ;; Ideally here we would have something much more syntactic, in that a set! to a
 168 ;; local var that is not settable would raise an error, and export etc forms
 169 ;; would modify the module in question: but alack, this is what we have now.
 170 ;; Patches welcome!
 171 (define (frame->module frame)
 172   (let ((proc (frame-procedure frame)))
 173     (if #f
 174         ;; FIXME!
 175         (let* ((mod (or (program-module proc) (current-module)))
 176                (mod* (make-module)))
 177           (module-use! mod* mod)
 178           (for-each
 179            (lambda (binding)
 180              (let* ((x (frame-local-ref frame (binding:index binding)))
 181                     (var (if (binding:boxed? binding) x (make-variable x))))
 182                (format #t
 183                        "~:[Read-only~;Mutable~] local variable ~a = ~70:@y\n"
 184                        (binding:boxed? binding)
 185                        (binding:name binding)
 186                        (if (variable-bound? var) (variable-ref var) var))
 187                (module-add! mod* (binding:name binding) var)))
 188            (frame-bindings frame))
 189           mod*)
 190         (current-module))))
 191
 192
 193 (define (stack->vector stack)
 194   (let* ((len (stack-length stack))
 195          (v (make-vector len)))
 196     (if (positive? len)
 197         (let lp ((i 0) (frame (stack-ref stack 0)))
 198           (if (< i len)
 199               (begin
 200                 (vector-set! v i frame)
 201                 (lp (1+ i) (frame-previous frame))))))
 202     v))
 203
 204 (define (narrow-stack->vector stack . args)
 205   (let ((narrowed (apply make-stack (stack-ref stack 0) args)))
 206     (if narrowed
 207         (stack->vector narrowed)
 208         #()))) ; ? Can be the case for a tail-call to `throw' tho
 209
 210 (define (frame->stack-vector frame)
 211   (let ((tag (and (pair? (fluid-ref %stacks))
 212                   (cdar (fluid-ref %stacks)))))
 213     (narrow-stack->vector
 214      (make-stack frame)
 215      ;; Take the stack from the given frame, cutting 0
 216      ;; frames.
 217      0
 218      ;; Narrow the end of the stack to the most recent
 219      ;; start-stack.
 220      tag
 221      ;; And one more frame, because %start-stack
 222      ;; invoking the start-stack thunk has its own frame
 223      ;; too.
 224      0 (and tag 1))))
 225
 226 ;; (define (debug)
 227 ;;   (run-debugger
 228 ;;    (narrow-stack->vector
 229 ;;     (make-stack #t)
 230 ;;     ;; Narrow the `make-stack' frame and the `debug' frame
 231 ;;     2
 232 ;;     ;; Narrow the end of the stack to the most recent start-stack.
 233 ;;     (and (pair? (fluid-ref %stacks))
 234 ;;          (cdar (fluid-ref %stacks))))))
 235