module/system/vm/inspect.scm

   1 ;;; Guile VM debugging facilities
   2
   3 ;;; Copyright (C) 2001, 2009, 2010, 2011 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 vm inspect)
  22   #:use-module (system base pmatch)
  23   #:use-module (system base syntax)
  24   #:use-module (system vm vm)
  25   #:use-module (system vm frame)
  26   #:use-module ((language assembly disassemble)
  27                 #:select ((disassemble . %disassemble)))
  28   #:use-module (ice-9 rdelim)
  29   #:use-module (ice-9 pretty-print)
  30   #:use-module (ice-9 format)
  31   #:use-module (system vm program)
  32   #:export (inspect))
  33
  34 \f
  35 (define (reverse-hashq h)
  36   (let ((ret (make-hash-table)))
  37     (hash-for-each
  38      (lambda (k v)
  39        (hashq-set! ret v (cons k (hashq-ref ret v '()))))
  40      h)
  41     ret))
  42
  43 (define (catch-bad-arguments thunk bad-args-thunk)
  44   (catch 'wrong-number-of-args
  45     (lambda ()
  46       (catch 'keyword-argument-error
  47         thunk
  48         (lambda (k . args)
  49           (bad-args-thunk))))
  50     (lambda (k . args)
  51       (bad-args-thunk))))
  52
  53 (define (read-args prompt)
  54   (define (read* reader)
  55     (repl-reader prompt reader))
  56   (define (next)
  57     (read* read-char))
  58   (define (cmd chr)
  59     (cond
  60      ((eof-object? chr) (list chr))
  61      ((char=? chr #\newline) (cmd (next)))
  62      ((char-whitespace? chr) (cmd (next)))
  63      (else
  64       (unread-char chr)
  65       (let ((tok (read* read)))
  66         (args (list tok) (next))))))
  67   (define (args out chr)
  68     (cond
  69      ((eof-object? chr) (reverse out))
  70      ((char=? chr #\newline) (reverse out))
  71      ((char-whitespace? chr) (args out (next)))
  72      (else
  73       (unread-char chr)
  74       (let ((tok (read* read)))
  75         (args (cons tok out) (next))))))
  76   (cmd (next)))
  77
  78
  79 ;;;
  80 ;;; Inspector
  81 ;;;
  82
  83 (define (inspect x)
  84   (define-syntax-rule (define-command ((mod cname alias ...) . args)
  85                         body ...)
  86     (define cname
  87       (let ((c (lambda* args body ...)))
  88         (set-procedure-property! c 'name 'cname)
  89         (module-define! mod 'cname c)
  90         (module-add! mod 'alias (module-local-variable mod 'cname))
  91         ...
  92         c)))
  93
  94   (let ((commands (make-module)))
  95     (define (prompt)
  96       (format #f "~20@y inspect> " x))
  97
  98     (define-command ((commands quit q continue cont c))
  99       "Quit the inspector."
 100       (throw 'quit))
 101
 102     (define-command ((commands print p))
 103       "Print the current object using `pretty-print'."
 104       (pretty-print x))
 105
 106     (define-command ((commands write w))
 107       "Print the current object using `write'."
 108       (write x))
 109
 110     (define-command ((commands display d))
 111       "Print the current object using `display'."
 112       (display x))
 113
 114     (define-command ((commands disassemble x))
 115       "Disassemble the current object, which should be objcode or a procedure."
 116       (catch #t
 117         (lambda ()
 118           (%disassemble x))
 119         (lambda args
 120           (format #t "Error disassembling object: ~a\n" args))))
 121
 122     (define-command ((commands help h ?) #:optional cmd)
 123       "Show this help message."
 124       (let ((rhash (reverse-hashq (module-obarray commands))))
 125         (define (help-cmd cmd)
 126           (let* ((v (module-local-variable commands cmd))
 127                  (p (variable-ref v))
 128                  (canonical-name (procedure-name p)))
 129             ;; la la la
 130             (format #t "~a~{ ~:@(~a~)~}~?~%~a~&~%"
 131                     canonical-name (program-lambda-list p)
 132                     "~#[~:;~40t(aliases: ~@{~a~^, ~})~]"
 133                     (delq canonical-name (hashq-ref rhash v))
 134                     (procedure-documentation p))))
 135         (cond
 136          (cmd
 137           (cond
 138            ((and (symbol? cmd) (module-local-variable commands cmd))
 139             (help-cmd cmd))
 140            (else
 141             (format #t "Invalid command ~s.~%" cmd)
 142             (format #t "Try `help' for a list of commands~%"))))
 143          (else
 144           (let ((names (sort
 145                         (hash-map->list
 146                          (lambda (k v)
 147                            (procedure-name (variable-ref k)))
 148                          rhash)
 149                         (lambda (x y)
 150                           (string<? (symbol->string x)
 151                                     (symbol->string y))))))
 152             (format #t "Available commands:~%~%")
 153             (for-each help-cmd names))))))
 154
 155     (define (handle cmd . args)
 156       (cond
 157        ((and (symbol? cmd)
 158              (module-local-variable commands cmd))
 159         => (lambda (var)
 160              (let ((proc (variable-ref var)))
 161                (catch-bad-arguments
 162                 (lambda ()
 163                   (apply (variable-ref var) args))
 164                 (lambda ()
 165                   (format (current-error-port)
 166                           "Invalid arguments to ~a. Try `help ~a'.~%"
 167                           (procedure-name proc) (procedure-name proc)))))))
 168        ; ((and (integer? cmd) (exact? cmd))
 169        ;  (nth cmd))
 170        ((eof-object? cmd)
 171         (newline)
 172         (throw 'quit))
 173        (else
 174         (format (current-error-port)
 175                 "~&Unknown command: ~a. Try `help'.~%" cmd)
 176         *unspecified*)))
 177
 178     (catch 'quit
 179       (lambda ()
 180         (let loop ()
 181           (apply
 182            handle
 183            (save-module-excursion
 184             (lambda ()
 185               (set-current-module commands)
 186               (read-args prompt))))
 187           (loop)))
 188       (lambda (k . args)
 189         (apply values args)))))