Re: Interactive Debugging

[Matt Wette <matt.wette@gmail.com>]

Below is something I played with years ago.  I'm not sure kill-opt is up to date.   Try with


   > (load "jtd.scm")
   > (foo)
   [1]> ,loc





;; potluck/jtd - jump to debugger, detour to debugger

;;(define-module (potluck jtd) #:export (kill-opt trap-here foo))

(use-modules (system repl repl))
(use-modules (system repl debug))
(use-modules (system repl common))
(use-modules (system repl command))
(use-modules (system vm frame))
(use-modules (system vm vm))
(use-modules (ice-9 control))
(use-modules (ice-9 rdelim))
(use-modules (ice-9 pretty-print))

;; kill optimization
(define (kill-opt)
   (set! (@@ (language tree-il optimize) tree-il-default-optimization-options)
         (lambda () '()))
   (set! (@@ (language cps optimize) cps-default-optimization-options)
         (lambda () '())))

;; notes
;; 1) needs new set of commands:
;;    C-d loops and enters again, i.e., continues => disable
;;    debug needs ,continue -- aka ,c  -- HAS it,  see ",quit"
;;    need ,quit -- aka ,q
;; 2) for non-interactive use probably need to call guile with "--debug"
;; 3) need to determine if repl is running (pair? (fluid-ref *repl-stack*))
;;    and start one if not
;; 4) maybe set hook on next instrucrtion (trap-here-2)
;; 5) see debug-trap-handler in system/repl/error-handling.scm to see how
;;    a debug session is spontaneously started.  See also near line 124.
;; 6) another strategy might be to have a procedure and set a trap in there
;; 7) use prompts (delineated continuations)
;; 8) trap handlers take one argument: a frame
;; 9) possible frame goodies:
;;    (frame-lookup-binging frame var)
;;    (frame-next-source frame) ;; NO MORE :(
;;    (frame-source frame)

;; given frame
;; (frame-procedure frame) => procedure
;; (procedure-source procedure) => source ???
;; (source-properties <obj>) => '((filename . "foo.scm") (line . 2) ...)

;; Here is what the debugger step command does:
;; (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
;;                               #:into? #t #:instruction? #f)
;; (throw 'quit)))

;;(simple-format #t "~S\n" (provided? 'debug-extensions))
;;(simple-format #t "repl:~S\n" (fluid-ref *repl-stack*))
;;(define repl-next-resumer (@@ (system repl command) repl-next-resumer))

;;(simple-format #t "vm-engine: ~S\n" (vm-engine))

;; get a few lines from file
(define (get-lines filename lineno)
   (let ((port (open-input-file filename)))
     (let iter ((prev #f) (curr #f) (offs lineno))
       (case offs
        ((1) (iter (cons " " (read-line port)) curr (1- offs)))
        ((0) (iter prev (cons "*" (read-line port)) (1- offs)))
        ((-1) (list prev curr (cons " " (read-line port))))
        (else (read-line port) (iter prev curr (1- offs)))))))

(define (show-src-loc locn)
   (let* ((line (assq-ref locn 'line))
	 (column (assq-ref locn 'column))
	 (filename (assq-ref locn 'filename)))
     (for-each
      (lambda (pair)
        (if pair
	   (simple-format #t "~A ~A\n" (car pair) (cdr pair))))
      (get-lines filename line))))

(define here-repl #f)

;; @deffn make-debug frames index err-msg for-trap?
;; Generate a data structure used for the repl.
;; @table @var
;; @item frames
;; TBD
;; @item index
;; I think this is the current frame from the deepest
;; @item err-msg
;; TBD
;; @item for-trap?
;; TBD
;; @end table

;; make-stack : in manual, generates a list of frames
;; stack->vector : convert list to vector

;; in commands, cur is (vector-ref (debug-frames debug) (debug-index debug))
;;  or the current frame

;; The first thing we do is kill off optimization
(kill-opt)

(define give-warning
   (let ((warned? #f))
     (lambda ()
       (unless warned?
	(simple-format (current-error-port) "trap requires --debug\n")
	(set! warned? #t)))))
       
(define-syntax-rule (jump-to-debugger)
   (if (eqv? 'regular (vm-engine))
       (give-warning)
       (start-repl
        #:debug (make-debug (stack->vector (make-stack #t)) 0 "trap!" #t))))

(define-syntax-rule (trap-here-0)
   (start-repl
    #:debug (make-debug (stack->vector (make-stack #t)) 0 "trap!" #t)))

#;(define-syntax-rule (trap-here-2)
   (let ((loc (current-source-location))
	)
     #t
     ))

;; step:
;;    (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
;;                                  #:into? #t #:instruction? #f)
;;    (throw 'quit)))

;; quit:
;; (throw 'quit)
(define (my-repl-welcome repl)
   (display "Enter `,help' for help.\n"))
(set! (@ (system repl common) repl-welcome) my-repl-welcome)


;; copy from system/repl/command.scm
;; this returns a continuation
(define (repl-next-resumer msg)
   ;; Capture the dynamic environment with this prompt thing. The
   ;; result is a procedure that takes a frame.
   (% (let ((stack (abort
                    (lambda (k)
                      ;; Call frame->stack-vector before reinstating the
                      ;; continuation, so that we catch the %stacks fluid
                      ;; at the time of capture.
                      (lambda (frame)
                        (k (frame->stack-vector frame)))))))
        (format #t "~a~%" msg)
        ((module-ref (resolve-interface '(system repl repl)) 'start-repl)
         #:debug (make-debug stack 0 msg #t)))))

#;(define-meta-command (resume repl)
   "resume"
   (let ((debug (repl-debug repl)))
     (if debug
	(let ((msg (simple-format #f "resume ..."))
	      (cur (vector-ref (debug-frames debug) (debug-index debug))))
	  (add-ephemeral-stepping-trap! cur (repl-next-resumer msg)
					#:into? #t #:instruction? #f)
	  ))))

;; This allows user to just get the hell out of guile.
;;(define-meta-command ((quit-guile extra) repl)
(define-meta-command ((qq extra) repl)
   "quit-guile
Quit the guile session."
   (primitive-exit 1))

(define-meta-command ((loc extra) repl)
   "loc
Show where in source."
   (let* ((debug (repl-debug repl))
	 (indx (debug-index debug))
	 (frms (debug-frames debug))
	 (frm (vector-ref frms (1+ indx)))
	 (src (and frm (frame-source frm)))
	 (loc `((column . ,(car src))
		(filename . ,(cadr src))
		(line . ,(caddr src))))
	 )
     (show-src-loc loc)
     ))

(define (foo)
   (let ((a 1) (b 2) (c 3))
     (set! b 22)
     ;;(show-src-loc (current-source-location))
     (let iter ((sum 0) (vals '(1 2 3 5 8 2)))
       (if (zero? sum) (jump-to-debugger))
       (cond
        ((null? vals) sum)
        (else
	(simple-format #t "~S\n" sum)
	(iter (+ sum (car vals)) (cdr vals)))))))

;;(simple-format #t "~S\n" (foo))

;;; --- last line ---