????
Your IP : 3.148.252.90
;;; Guile VM debugging facilities
;;; Copyright (C) 2001, 2009, 2010, 2011, 2013, 2014, 2015 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library 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
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
(define-module (system repl debug)
#:use-module (system base pmatch)
#:use-module (system base syntax)
#:use-module (system base language)
#:use-module (system vm vm)
#:use-module (system vm frame)
#:use-module (system vm debug)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 pretty-print)
#:use-module ((system vm inspect) #:select ((inspect . %inspect)))
#:use-module (system vm program)
#:export (<debug>
make-debug debug?
debug-frames debug-index debug-error-message
terminal-width
print-registers print-locals print-frame print-frames
stack->vector narrow-stack->vector
frame->stack-vector))
;; TODO:
;;
;; eval expression in context of frame
;; set local variable in frame
;; step until greater source line
;; watch expression
;; set printing width
;; disassemble the current function
;; inspect any object
;;;
;;; Debugger
;;;
;;; The actual interaction loop of the debugger is run by the repl. This module
;;; simply exports a data structure to hold the debugger state, along with its
;;; accessors, and provides some helper functions.
;;;
(define-record <debug> frames index error-message)
;; A fluid, because terminals are usually implicitly associated with
;; threads.
;;
(define terminal-width
(let ((set-width (make-fluid)))
(case-lambda
(()
(or (fluid-ref set-width)
(let ((w (false-if-exception (string->number (getenv "COLUMNS")))))
(and (integer? w) (exact? w) (> w 0) w))
72))
((w)
(if (or (not w) (and (integer? w) (exact? w) (> w 0)))
(fluid-set! set-width w)
(error "Expected a column number (a positive integer)" w))))))
(define (reverse-hashq h)
(let ((ret (make-hash-table)))
(hash-for-each
(lambda (k v)
(hashq-set! ret v (cons k (hashq-ref ret v '()))))
h)
ret))
(define* (print-registers frame #:optional (port (current-output-port))
#:key (per-line-prefix " "))
(define (print fmt val)
(display per-line-prefix port)
(run-hook before-print-hook val)
(format port fmt val))
(format port "~aRegisters:~%" per-line-prefix)
(let ((ip (frame-instruction-pointer frame)))
(print "ip = #x~x" ip)
(let ((info (find-program-debug-info ip)))
(when info
(let ((addr (program-debug-info-addr info)))
(format port " (#x~x + ~d * 4)" addr (/ (- ip addr) 4)))))
(newline port))
(print "sp = ~a\n" (frame-stack-pointer frame))
(print "fp = ~a\n" (frame-address frame)))
(define* (print-locals frame #:optional (port (current-output-port))
#:key (width (terminal-width)) (per-line-prefix " "))
(let ((bindings (frame-bindings frame)))
(cond
((null? bindings)
(format port "~aNo local variables.~%" per-line-prefix))
(else
(format port "~aLocal variables:~%" per-line-prefix)
(for-each
(lambda (binding)
(let ((v (binding-ref binding)))
(display per-line-prefix port)
(run-hook before-print-hook v)
(format port "~a = ~v:@y\n" (binding-name binding) width v)))
(frame-bindings frame))))))
(define* (print-frame frame #:optional (port (current-output-port))
#:key index (width (terminal-width)) (full? #f)
(last-source #f) next-source?)
(define (source:pretty-file source)
(if source
(or (source:file source) "current input")
"unknown file"))
(let* ((source (frame-source frame))
(file (source:pretty-file source))
(line (and=> source source:line-for-user))
(col (and=> source source:column)))
(if (and file (not (equal? file (source:pretty-file last-source))))
(format port "~&In ~a:~&" file))
(format port "~9@a~:[~*~3_~;~3d~] ~v:@y~%"
(if line (format #f "~a:~a" line col) "")
index index width
(frame-call-representation frame #:top-frame? (zero? index)))
(if full?
(print-locals frame #:width width
#:per-line-prefix " "))))
(define* (print-frames frames
#:optional (port (current-output-port))
#:key (width (terminal-width)) (full? #f)
(forward? #f) count)
(let* ((len (vector-length frames))
(lower-idx (if (or (not count) (positive? count))
0
(max 0 (+ len count))))
(upper-idx (if (and count (negative? count))
(1- len)
(1- (if count (min count len) len))))
(inc (if forward? 1 -1)))
(let lp ((i (if forward? lower-idx upper-idx))
(last-source #f))
(if (<= lower-idx i upper-idx)
(let* ((frame (vector-ref frames i)))
(print-frame frame port #:index i #:width width #:full? full?
#:last-source last-source)
(lp (+ i inc)
(frame-source frame)))))))
(define (stack->vector stack)
(let* ((len (stack-length stack))
(v (make-vector len)))
(if (positive? len)
(let lp ((i 0) (frame (stack-ref stack 0)))
(if (< i len)
(begin
(vector-set! v i frame)
(lp (1+ i) (frame-previous frame))))))
v))
(define (narrow-stack->vector stack . args)
(let ((narrowed (apply make-stack (stack-ref stack 0) args)))
(if narrowed
(stack->vector narrowed)
#()))) ; ? Can be the case for a tail-call to `throw' tho
(define (frame->stack-vector frame)
(let ((stack (make-stack frame)))
(match (fluid-ref %stacks)
((stack-tag . prompt-tag)
(narrow-stack->vector
stack
;; Take the stack from the given frame, cutting 0 frames.
0
;; Narrow the end of the stack to the most recent start-stack.
prompt-tag
;; And one more frame, because %start-stack invoking the
;; start-stack thunk has its own frame too.
0 (and prompt-tag 1)))
(_
;; Otherwise take the whole stack.
(stack->vector stack)))))
;; (define (debug)
;; (run-debugger
;; (narrow-stack->vector
;; (make-stack #t)
;; ;; Narrow the `make-stack' frame and the `debug' frame
;; 2
;; ;; Narrow the end of the stack to the most recent start-stack.
;; (and (pair? (fluid-ref %stacks))
;; (cdr (fluid-ref %stacks))))))