Re: Interactive Debugging

[Matt Wette]

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 ---