chicken-users
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Re: [Chicken-users] debugging query


From: Felix Winkelmann
Subject: Re: [Chicken-users] debugging query
Date: Fri, 12 Mar 2004 08:30:53 +0100
User-agent: Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.6) Gecko/20040113

Clifford Stein wrote:

I'm curious how people debug their code with Chicken.

I'm pretty much doing everything with the interpreter and I find the
only way I can track down error messages like:

Error: (-) bad argument type: #<procedure>

is to put a bunch of print statements in.  Is there a way for the
interpreter to display the line number and the name of the source file
to make it a little easier to track down?

Also, when loading a file, the interpreter does some syntax checking and
can report errors.   Again, it tells me there's an error but won't tell
me where (sometimes it prints the  offending code-block, but other times
the messages are really generic).
Suggestions?


Admittedly, error-reporting is rather weak in the interpreter. Compiled code
is able to produce a backtrace, which is (a small) improvement.
Please find attached a simple debugger that can be loaded into the
interpreter, which is at least able to produce a backtrace.

Installation:

$ chicken-setup debug

Usage:

Enter (require 'debug)

On errors, you will be dropped into a debugger-repl. The debugger
mode can also be invoked by calling (debug). Enter ,? for help.
Note that not all features have been tested thoroughly, yet.
Also, tail-calls turn into non-tail calls (since the call-stack
is maintained in a dynamically scoped manner).

Feedback is (as always) welcome.


cheers,
felix

;;;; debug.scm - Compile lambda to closure, with debugging info - felix


(declare 
  (uses scheduler)
  (fixnum)
  (usual-integrations)
  (compile-time-macros-only)
  (hide ##dbg#watch-assignment! ##dbg#entry ##dbg#push-frame-and-call dbgout 
dbgout* ##dbg#bind-entry
        top-env find-frame print-exn print-error caught-exception-types caught? 
property-predicate test-condition
        current-exception debugging watch-list del break-list list-items 
find-info show-backtrace) )

(cond-expand
 [paranoia]
 [else
  (declare
    ;(no-bound-checks)
    (bound-to-procedure 
     ##dbg#lookup-symbol-info ##dbg#entry ##dbg#push-frame-and-call 
##dbg#watch-assignment!
     ##sys#check-char ##sys#check-exact ##sys#check-port ##sys#check-string 
##sys#load-library
     ##sys#for-each ##sys#map ##sys#setslot ##sys#allocate-vector 
##sys#check-pair ##sys#not-a-proper-list-error
     ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling 
##sys#truncate ##sys#round 
     ##sys#check-number ##sys#cons-flonum ##sys#copy-env-table
     ##sys#flonum-fraction ##sys#make-port ##sys#fetch-and-check-port-arg 
##sys#print ##sys#check-structure 
     ##sys#make-structure ##sys#test-feature
     ##sys#error-handler ##sys#hash-symbol ##sys#register-macro 
##sys#check-syntax
     ##sys#hash-table-ref ##sys#hash-table-set! ##sys#canonicalize-body 
##sys#decompose-lambda-list
     ##sys#make-c-string ##sys#resolve-include-filename ##sys#register-macro-2 
     ##sys#load ##sys#error ##sys#warn ##sys#hash-table-location
     ##sys#make-flonum ##sys#make-pointer ##sys#null-pointer 
##sys#address->pointer 
     ##sys#pointer->address ##sys#compile-to-closure
     ##sys#ensure-heap-reserve ##sys#syntax-error-hook ##sys#read-prompt-hook
     ##sys#repl-eval-hook ##sys#append ##sys#secondary-macroexpand 
##sys#lookup-id
     ##sys#macroexpand-hook) ) ] )


;;; Symbol info mapping:
;
; - The symbol-info-table contains a vector of the form 
;
;   #(NAME (PROPERTY ...))
;
;   for each registered symbol. PROPERTY is one of the following:
;
;   (watch)      - any assignments to a global variable with this name is 
watched.
;   (break)      - break on entry into an interpreted function with this name.
;   (break-call) - break before calling the interpreted or compiled function.
;   (watch PROCEDURE EXP)
;   (break PROCEDURE EXP)
;   (break-call PROCEDURE EXP)
;                - as watch/break/break-call, but only triggers a watchpoint, 
when the
;                  `(PROCEDURE RTE)' evaluates to a true value.
;

(define-constant symbol-info-table-size 301)

(define ##dbg#symbol-info-table (make-vector symbol-info-table-size '()))

(define (##dbg#lookup-symbol-info name)
  (##sys#check-symbol name)
  (let* ([k (##sys#hash-symbol name symbol-info-table-size)]
         [bucket0 (##sys#slot ##dbg#symbol-info-table k)] )
    (let loop ([bucket bucket0])
      (if (null? bucket)
          (let ([p (vector name '())])
            (##sys#setslot ##dbg#symbol-info-table k (cons p bucket0))
            p)
          (let ([b (##sys#slot bucket 0)])
            (if (eq? name (##sys#slot b 0))
                b
                (loop (##sys#slot bucket 1)) ) ) ) ) ) )


;;; A slightly modified closure-compiler:

(define ##sys#compile-to-closure
  (let ([macroexpand-1 macroexpand-1]
        [macro? macro?]
        [write write]
        [cadadr cadadr]
        [reverse reverse]
        [with-input-from-file with-input-from-file]
        [unbound (##sys#slot '##sys#arbitrary-unbound-symbol 0)]
        [display display] )
    (lambda (exp env me)

      (define (lookup var e)
        (let loop ((envs e) (ei 0))
          (cond ((null? envs) (values #f var))
                ((posq var (##sys#slot envs 0)) => (lambda (p) (values ei p)))
                (else (loop (##sys#slot envs 1) (fx+ ei 1))) ) ) )

      (define (defined? var e)
        (receive (i j) (lookup var e) i) )

      (define (undefine vars e)
        (let loop ([envs e])
          (if (null? envs)
              '()
              (let ([envi (##sys#slot envs 0)])
                (cons
                 (let delq ([ee envi])
                   (if (null? ee)
                       '()
                       (let ([h (##sys#slot ee 0)]
                             [r (##sys#slot ee 1)] )
                         (if (memq h vars)
                             r
                             (cons h (delq r)) ) ) ) )
                 (loop (##sys#slot envs 1)) ) ) ) ) )

      (define (posq x lst)
        (let loop ((lst lst) (i 0))
          (cond ((null? lst) #f)
                ((eq? x (##sys#slot lst 0)) i)
                (else (loop (##sys#slot lst 1) (fx+ i 1))) ) ) )

      (define (macroexpand-1-checked x e me)
        (let ([x2 (##sys#secondary-macroexpand (macroexpand-1 x me))])
          (if (pair? x2)
              (let ([h (##sys#slot x2 0)])
                (if (and (eq? h 'let) (not (defined? 'let e)))
                    (let ([next (##sys#slot x2 1)])
                      (if (and (pair? next) (symbol? (##sys#slot next 0)))
                          (macroexpand-1-checked x2 e me)
                          x2) )
                    x2) )
              x2) ) )

      (define (compile x e h me)
        (cond [(symbol? x)
               (receive (i j) (lookup x e)
                 (cond [(not i)
                        (let ([y (macroexpand-1-checked x e me)])
                          (if (eq? x y)
                              (if ##sys#eval-environment
                                  (let ([loc (##sys#hash-table-location 
##sys#eval-environment x #t)])
                                    (unless loc (##sys#error "reference to 
undefined identifier" x))
                                    (cond-expand 
                                     [unsafe (lambda v (##sys#slot loc 1))]
                                     [else
                                      (lambda v 
                                        (let ([val (##sys#slot loc 1)])
                                          (if (eq? unbound val)
                                              (##sys#error "unbound variable" x)
                                              val) ) ) ] ) )
                                  (cond-expand
                                   [unsafe (lambda v (##core#inline "C_slot" x 
0))]
                                   [else (lambda v (##core#inline "C_retrieve" 
x))] ) )
                              (compile y e h me) ) ) ]
                       [(zero? i) (lambda (v) (##sys#slot (##sys#slot v 0) j))]
                       [else (lambda (v) (##sys#slot (##core#inline 
"C_u_i_list_ref" v i) j))] ) ) ]
              [(number? x)
               (case x
                 [(-1) (lambda v -1)]
                 [(0) (lambda v 0)]
                 [(1) (lambda v 1)]
                 [(2) (lambda v 2)]
                 [else (lambda v x)] ) ]
              [(boolean? x)
               (if x
                   (lambda v #t)
                   (lambda v #f) ) ]
              [(or (char? x)
                   (string? x) )
               (lambda v x) ]
              [(not (pair? x)) (##sys#error "syntax error - illegal non-atomic 
object" x)]
              [(symbol? (##sys#slot x 0))
               (let ([head (##sys#slot x 0)])
                 (if (defined? head e)
                     (compile-call x e me)
                     (let ([x2 (macroexpand-1-checked x e me)])
                       (if (eq? x2 x)
                           (case head

                             [(quote)
                              (##sys#check-syntax 'quote x '(quote _) #f)
                              (let* ([c (cadr x)])
                                (case c
                                  [(-1) (lambda v -1)]
                                  [(0) (lambda v 0)]
                                  [(1) (lambda v 1)]
                                  [(2) (lambda v 2)]
                                  [(#t) (lambda v #t)]
                                  [(#f) (lambda v #f)]
                                  [(()) (lambda v '())]
                                  [else (lambda v c)] ) ) ]

                             [(##core#qualified)
                              (compile (cadr x) e h me) ]

                             [(##core#check)
                              (compile (cadr x) e h me) ]

                             [(##core#global-ref)
                              (let ([var (cadr x)])
                                (if ##sys#eval-environment
                                    (let ([loc (##sys#hash-table-location 
##sys#eval-environment var #t)])
                                      (lambda v (##sys#slot loc 1)) )
                                    (lambda v (##core#inline "C_slot" var 0)) ) 
) ]

                             [(##core#immutable)
                              (compile (cadr x) e #f me) ]
                   
                             [(##core#undefined) (lambda (v) 
(##core#undefined))]

                             [(if)
                              (##sys#check-syntax 'if x '(if _ _ . #(_)) #f)
                              (let* ([test (compile (cadr x) e #f me)]
                                     [cns (compile (caddr x) e #f me)]
                                     [alt (if (pair? (cdddr x))
                                              (compile (cadddr x) e #f me)
                                              (compile '(##core#undefined) e #f 
me) ) ] )
                                (lambda (v) (if (test v) (cns v) (alt v))) ) ]

                             [(begin)
                              (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f)
                              (let* ([body (##sys#slot x 1)]
                                     [len (length body)] )
                                (case len
                                  [(0) (compile '(##core#undefined) e #f me)]
                                  [(1) (compile (##sys#slot body 0) e #f me)]
                                  [(2) (let* ([x1 (compile (##sys#slot body 0) 
e #f me)]
                                              [x2 (compile (cadr body) e #f 
me)] )
                                         (lambda (v) (x1 v) (x2 v)) ) ]
                                  [else
                                   (let* ([x1 (compile (##sys#slot body 0) e #f 
me)]
                                          [x2 (compile (cadr body) e #f me)] 
                                          [x3 (compile `(begin ,@(##sys#slot 
(##sys#slot body 1) 1)) e #f me)] )
                                     (lambda (v) (x1 v) (x2 v) (x3 v)) ) ] ) ) ]

                             [(set! ##core#set!)
                              (##sys#check-syntax 'set! x '(_ variable _) #f)
                              (let ([var (cadr x)])
                                (receive (i j) (lookup var e)
                                  (let ([val (compile (caddr x) e var me)])
                                    (cond [(not i)
                                           (let ([info 
(##dbg#lookup-symbol-info var)])
                                             (if ##sys#eval-environment
                                                 (let ([loc 
(##sys#hash-table-location
                                                             
##sys#eval-environment 
                                                             var
                                                             
##sys#environment-is-mutable) ] )
                                                   (unless loc (##sys#error 
"assignment of undefined identifier" var))
                                                   (if (##sys#slot loc 2)
                                                       (lambda (v) 
(##dbg#watch-assignment! info loc 1 (val v)))
                                                       (lambda v (##sys#error 
"assignment to immutable variable" var)) ) )
                                                 (lambda (v) 
(##dbg#watch-assignment! info j 0 (val v))) ) ) ]
                                          [(zero? i) (lambda (v) (##sys#setslot 
(##sys#slot v 0) j (val v)))]
                                          [else
                                           (lambda (v)
                                             (##sys#setslot (##core#inline 
"C_u_i_list_ref" v i) j (val v)) ) ] ) ) ) ) ]

                             [(let)
                              (##sys#check-syntax 'let x '(let #((variable _) 
0) . #(_ 1)) #f)
                              (let* ([bindings (cadr x)]
                                     [n (length bindings)] 
                                     [vars (map (lambda (x) (car x)) bindings)] 
                                     [e2 (cons vars e)]
                                     [body (##sys#compile-to-closure
                                            (##sys#canonicalize-body (cddr x))
                                            e2
                                            me) ] )
                                (case n
                                  [(1) (let ([val (compile (cadar bindings) e 
#f me)])
                                         (lambda (v) (##dbg#bind-entry e2 body 
(cons (vector (val v)) v))) ) ]
                                  [(2) (let ([val1 (compile (cadar bindings) e 
#f me)]
                                             [val2 (compile (cadadr bindings) e 
#f me)] )
                                         (lambda (v)
                                           (##dbg#bind-entry e2 body (cons 
(vector (val1 v) (val2 v)) v)) ) ) ]
                                  [(3) (let* ([val1 (compile (cadar bindings) e 
#f me)]
                                              [val2 (compile (cadadr bindings) 
e #f me)] 
                                              [t (cddr bindings)]
                                              [val3 (compile (cadar t) e #f 
me)] )
                                         (lambda (v)
                                           (##dbg#bind-entry e2 body (cons 
(vector (val1 v) (val2 v) (val3 v)) v)) ) ) ]
                                  [(4) (let* ([val1 (compile (cadar bindings) e 
#f me)]
                                              [val2 (compile (cadadr bindings) 
e #f me)] 
                                              [t (cddr bindings)]
                                              [val3 (compile (cadar t) e #f 
me)] 
                                              [val4 (compile (cadadr t) e #f 
me)] )
                                         (lambda (v)
                                           (##dbg#bind-entry e2 body (cons 
(vector (val1 v) (val2 v) (val3 v) (val4 v)) v)) ) ) ]
                                  [else
                                   (let ([vals (map (lambda (x) (compile (cadr 
x) e #f me)) bindings)])
                                     (lambda (v)
                                       (let ([v2 (##sys#make-vector n)])
                                         (do ([i 0 (fx+ i 1)]
                                              [vlist vals (##sys#slot vlist 1)] 
)
                                             ((fx>= i n))
                                           (##sys#setslot v2 i ((##sys#slot 
vlist 0) v)) )
                                         (##dbg#bind-entry e2 body (cons v2 v)) 
) ) ) ] ) ) ]
                             ;; (compile
                             ;; `((lambda ,(##sys#map (lambda (x) (car x)) 
bindings) 
                             ;; ,@(##sys#slot (##sys#slot x 1) 1) )
                             ;; ,@(##sys#map (lambda (x) (cadr x)) bindings) )
                             ;; e #f me) ) ]

                             [(lambda)
                              (##sys#check-syntax 'lambda x '(lambda 
lambda-list . #(_ 1)) #f)
                              (let ([llist (cadr x)])
                                (##sys#decompose-lambda-list
                                 llist
                                 (lambda (vars argc rest)
                                   (let* ([e2 (cons vars e)]
                                          [body (##sys#compile-to-closure
                                                 (##sys#canonicalize-body (cddr 
x))
                                                 e2
                                                 me) ] 
                                          [info (and h 
(##dbg#lookup-symbol-info h))] )
                                     (case argc
                                       [(0) (if rest
                                                (lambda (v) (lambda r 
(##dbg#entry info e2 llist body (cons (vector r) v))))
                                                (lambda (v) (lambda () 
(##dbg#entry info e2 llist body (cons #f v))))) ]
                                       [(1) (if rest
                                                (lambda (v) (lambda (a1 . r) 
(##dbg#entry info e2 llist body (cons (vector a1 r) v))))
                                                (lambda (v) (lambda (a1) 
(##dbg#entry info e2 llist body (cons (vector a1) v))))) ]
                                       [(2) (if rest
                                                (lambda (v) 
                                                  (lambda (a1 a2 . r) 
(##dbg#entry info e2 llist body (cons (vector a1 a2 r) v))))
                                                (lambda (v) 
                                                  (lambda (a1 a2) (##dbg#entry 
info e2 llist body (cons (vector a1 a2) v))))) ]
                                       [(3) (if rest
                                                (lambda (v)
                                                  (lambda (a1 a2 a3 . r) 
(##dbg#entry info e2 llist body (cons (vector a1 a2 a3 r) v))))
                                                (lambda (v)
                                                  (lambda (a1 a2 a3) 
(##dbg#entry info e2 llist body (cons (vector a1 a2 a3) v))))) ]
                                       [(4) (if rest
                                                (lambda (v)
                                                  (lambda (a1 a2 a3 a4 . r)
                                                    (##dbg#entry info e2 llist 
body (cons (vector a1 a2 a3 a4 r) v))) )
                                                (lambda (v)
                                                  (lambda (a1 a2 a3 a4)
                                                    (##dbg#entry info e2 llist 
body (##sys#cons (##sys#vector a1 a2 a3 a4) v))))) ]
                                       [else (if rest
                                                 (lambda (v)
                                                   (lambda as
                                                     (##dbg#entry 
                                                      info e2 llist body
                                                      (##sys#cons (apply 
##sys#vector (fudge-argument-list argc as)) v)) ) )
                                                 (lambda (v)
                                                   (lambda as 
                                                     (let ([len (length as)])
                                                       (if (not (fx= len argc))
                                                           (##sys#error "bad 
argument count" argc len)
                                                           (##dbg#entry 
                                                            info e2 llist body
                                                            (##sys#cons (apply 
##sys#vector as) v))) ) ) ) ) ] ) ) ) ) ) ]

                             [(##core#loop-lambda)
                              (compile `(lambda ,@(cdr x)) e #f me) ]

                             [(##core#named-lambda)
                              (compile `(lambda ,@(cddr x)) e (cadr x) me) ]

                             [(##core#require-for-syntax)
                              (let ([ids (map (lambda (x) 
((##sys#compile-to-closure x '() '()) '())) (cdr x))])
                                (apply require ids)
                                (let ([rs (##sys#lookup-runtime-requirements 
ids)])
                                  (compile
                                   (if (null? rs)
                                       '(##core#undefined)
                                       `(require ,@(map (lambda (x) `',x) rs)) )
                                   e #f me) ) ) ]

                             [(##core#elaborationtimeonly 
##core#elaborationtimetoo) ; <- Note this!
                              ((##sys#compile-to-closure (cadr x) '() '()) '())
                              (compile '(##core#undefined) e #f me) ]

                             [(##core#compiletimetoo)
                              (compile (cadr x) e #f me) ]

                             [(##core#compiletimeonly ##core#declare 
##core#callunit) 
                              (compile '(##core#undefined) e #f me) ]

                             [(##core#define-inline ##core#define-constant)
                              (compile `(set! ,(cadadr x) ,@(cddr x)) e #f me) ]
                   
                             [(##core#include)
                              (compile
                               (##sys#compiler-toplevel-macroexpand-hook
                                (with-input-from-file 
(##sys#resolve-include-filename (cadadr x))
                                  (lambda ()
                                    (do ([x (read) (read)]
                                         [xs '() (cons x xs)] )
                                        ((eof-object? x) 
                                         `(begin ,@(reverse xs))) ) ) ) )
                               e #f me) ]

                             [(##core#primitive ##core#inline 
##core#inline_allocate ##core#foreign-lambda 
                               ##core#define-foreign-variable 
##core#define-external-variable ##core#let-location
                               ##core#define-foreign-type 
##core#foreign-lambda*)
                              (##sys#error "syntax error - can not evaluate 
compiler-special-form" x) ]

                             [(##core#app)
                              (compile-call (cdr x) e me) ]

                             [else
                              (cond [##sys#strict-mode (compile-call x e me)]

                                    [(eq? head 'let-macro)
                                     (##sys#check-syntax 'let-macro x 
'(let-macro #(list 0) . #(_ 1)) #f)
                                     (set! ##sys#syntax-error-culprit #f)
                                     (let ([me2 (##sys#expand-local-macrodefs 
(cadr x))])
                                       (compile
                                        (##sys#canonicalize-body (cddr x))
                                        (undefine (map (lambda (x) (car x)) 
me2) e)
                                        #f
                                        (##sys#append me2 me) ) ) ]

                                    [(eq? head 'let-id-macro)
                                     (##sys#check-syntax 'let-id-macro x 
'(let-id-macro #((symbol _) 0) . #(_ 1)) #f)
                                     (let ([me2 (map (lambda (mdef) 
                                                       (cons (car mdef) (lambda 
(form) (cadr mdef))) )
                                                     (cadr x) ) ] )
                                       (compile
                                        (##sys#canonicalize-body (cddr x))
                                        (undefine (map (lambda (m) (##sys#slot 
m 0)) me2) e)
                                        #f
                                        (##sys#append me2 me) ) ) ]

                                    [(eq? head 'location)
                                     (##sys#error "syntax error - can not 
evaluate compiler-special-form" x) ]

                                    [else (compile-call x e me)] ) ] )

                           (compile x2 e h me) ) ) ) ) ]

              [else (compile-call x e me)] ) )

      (define (fudge-argument-list n alst)
        (if (null? alst) 
            (list alst)
            (do ([n n (fx- n 1)]
                 [args alst (##sys#slot args 1)]
                 [last #f args] )
                ((fx= n 0)
                 (##sys#setslot last 1 (list args))
                 alst) ) ) )

      (define (checked-length lst)
        (let loop ([lst lst] [n 0])
          (cond [(null? lst) n]
                [(pair? lst) (loop (##sys#slot lst 1) (fx+ n 1))]
                [else #f] ) ) )

      (define (compile-call x e me)
        (let* ([hd (##sys#slot x 0)]
               [fn (compile hd e #f me)]
               [args (##sys#slot x 1)]
               [argc (checked-length args)] 
               [info (and (symbol? hd) 
                          (##dbg#lookup-symbol-info hd) ) ] )
          (case argc
            [(#f) (##sys#error "syntax error - malformed expression" x)]
            [(0) (lambda (v) (##dbg#push-frame-and-call info (fn v)))]
            [(1) (let ([a1 (compile (##sys#slot args 0) e #f me)])
                   (lambda (v) (##dbg#push-frame-and-call info (fn v) (a1 v))) 
) ]
            [(2) (let* ([a1 (compile (##sys#slot args 0) e #f me)]
                        [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e 
#f me)] )
                   (lambda (v) (##dbg#push-frame-and-call info (fn v) (a1 v) 
(a2 v))) ) ]
            [(3) (let* ([a1 (compile (##sys#slot args 0) e #f me)]
                        [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e 
#f me)]
                        [a3 (compile (##core#inline "C_u_i_list_ref" args 2) e 
#f me)] )
                   (lambda (v) (##dbg#push-frame-and-call info (fn v) (a1 v) 
(a2 v) (a3 v))) ) ]
            [(4) (let* ([a1 (compile (##sys#slot args 0) e #f me)]
                        [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e 
#f me)]
                        [a3 (compile (##core#inline "C_u_i_list_ref" args 2) e 
#f me)] 
                        [a4 (compile (##core#inline "C_u_i_list_ref" args 3) e 
#f me)] )
                   (lambda (v) (##dbg#push-frame-and-call info (fn v) (a1 v) 
(a2 v) (a3 v) (a4 v))) ) ]
            [else (let ([as (##sys#map (lambda (a) (compile a e #f me)) args)])
                    (lambda (v) (apply ##dbg#push-frame-and-call info (fn v) 
(##sys#map (lambda (a) (a v)) as))) ) ] ) ) )

      (compile exp env #f me) ) ) )


;;; Debugging hooks:
;
; - The call-stack contains a alternating list of call-frames, binding-frames 
and entry-frames (reversed), where each 
;   call-frame is a vector of the following form:
;
;   #(call FUNCTION-NAME-INFO (or #f) REDO ARGUMENT-LIST)
;
;   each entry-frame:
;
;   #(entry FUNCTION-NAME-INFO (or #f) REDO COMPILE-TIME-ENVIRONMENT 
LAMBDA-LIST FUNCTION RUNTIME-ENVIRONMENT)
;
;   and each binding-frame:
;
;   #(bind COMPILE-TIME-ENVIRONMENT RUNTIME-ENVIRONMENT)

(define ##dbg#call-stack '())
(define watch-list '())
(define break-list '())

(define (test-condition prop)
  (or (null? (##sys#slot prop 1))
      (handle-exceptions ex 
          (begin
            (dbgout "[debug] condition failed (will be disabled): ")
            (dbgout* (caddr prop))
            (dbgout #\newline)
            (print-error ex)
            (##sys#setislot prop 1 '()) 
            #t)
        ((cadr prop) '()) ) ) )

(define (##dbg#watch-assignment! info block slot val)
  (let ([old (##sys#slot block slot)])
    (##sys#setslot block slot val)
    (and-let* ([a (and info (not debugging) (assq 'watch (##sys#slot info 1)))])
      (when (test-condition a)
        (dbgout "[debug] watchpoint: " (##sys#slot info 0) "\n  was: ")
        (dbgout* old)
        (dbgout "   is: ")
        (dbgout* val)
        (dbgout #\newline)
        (receive _ (##dbg#break) #f) ) ) ) )

(define ##dbg#push-frame-and-call
  (let ([call-with-current-continuation call-with-current-continuation])
    (lambda (info fn . args)
      (call-with-current-continuation
       (lambda (k)
         (define (redo flag . args)
           (if flag
               (##sys#dynamic-wind
                (lambda ()
                  (set! ##dbg#call-stack (cons (vector 'call info redo args) 
##dbg#call-stack)))
                (lambda ()
                  (and-let* ([a (and info (not debugging) (assq 'break-call 
(##sys#slot info 1)))])
                    (when (test-condition a)
                      (dbgout "[debug] breakpoint (call): " (##sys#slot info 0))
                      (receive _ (##dbg#break) #f) ) )
                  (apply fn args) )
                (lambda ()
                  (set! ##dbg#call-stack (##sys#slot ##dbg#call-stack 1))) )
               (apply k args) ) )
         (apply redo #t args) ) ) ) ) )

(define ##dbg#entry 
  (lambda (info cte llist body v)
    (##sys#dynamic-wind
     (lambda () (set! ##dbg#call-stack (cons (vector 'entry info #f cte llist 
body v) ##dbg#call-stack)))
     (lambda ()
       ;;... (check for breakpoint)
       (body v) )
     (lambda () (set! ##dbg#call-stack (##sys#slot ##dbg#call-stack 1))) ) ) )

(define (##dbg#bind-entry cte body v)
  (##sys#dynamic-wind
   (lambda () (set! ##dbg#call-stack (cons (vector 'bind cte v) 
##dbg#call-stack)))
   (lambda () (body v))
   (lambda () (set! ##dbg#call-stack (##sys#slot ##dbg#call-stack 1))) ) )


;;; New exception handlers for normal threads and the primordial one:

(define caught-exception-types '(exn))
(define current-exception #f)

(define (caught? ex)
  (and (not debugging)
       (or (eq? caught-exception-types #t)
           (and (##sys#structure? ex 'condition) 
                (let loop ([types (##sys#slot ex 1)])
                  (cond [(null? types) #f]
                        [(memq (##sys#slot types 0) caught-exception-types)]
                        [else (loop (##sys#slot types 1))] ) ) ) ) ) )

(define (print-exn ex)
  (dbgout "Uncaught exception in thread " (##sys#slot ##sys#current-thread 6) 
": ")
  (if (##sys#structure? ex 'condition)
      (begin
        (dbgout "condition of type: " (##sys#slot ex 1) "\n")
        (do ([plist (##sys#slot ex 2) (cddr plist)])
            ((null? plist))
          (dbgout "  " (car plist) " -> ")
          (dbgout* (cadr plist))
          (dbgout #\newline) ) )
      (begin
        (dbgout* ex) 
        (dbgout #\newline) ) ) )

(define print-error
  (let ([print-error-message print-error-message]
        [flush-output flush-output] )
    (lambda (ex)
      (print-error-message ex ##dbg#command-output-port)
      (flush-output ##dbg#command-output-port) ) ) )

(set! ##sys#default-exception-handler
  (let ([old ##sys#default-exception-handler])
    (lambda (ex)
      (if (caught? ex)
          (begin
            (dbgout "[debug] ")
            (print-error ex)
            (set! current-exception ex)
            (##dbg#break) )
          (old ex) ) ) ) )

(set! ##sys#current-exception-handler
  (let ([old ##sys#current-exception-handler])
    (lambda (ex)
      (if (caught? ex)
          (begin
            (dbgout "[debug] ")
            (print-error ex)
            (set! current-exception ex)
            (##dbg#break) )
          (old ex) ) ) ) )


;;; Break-handler:

(define ##dbg#command-table '())
(define ##dbg#command-input-port ##sys#standard-input)
(define ##dbg#command-output-port ##sys#standard-output)
(define ##dbg#continue values)
(define ##dbg#thread-list #f)

(define dbgout
  (let ([display display]
        [flush-output flush-output] )
    (lambda args
      (for-each (cut display <> ##dbg#command-output-port) args) 
      (flush-output ##dbg#command-output-port) ) ) )

(define dbgout*
  (let ([write write]
        [flush-output flush-output] )
    (lambda args
      (##sys#with-print-length-limit
       120
       (lambda ()
         (for-each (cut write <> ##dbg#command-output-port) args) ) )
      (flush-output ##dbg#command-output-port) ) ) )

(define (debug . args) (apply ##dbg#break args))

(define debugging #f)

(define ##dbg#break
  (let ([read read]
        [eval eval]
        [call-with-current-continuation call-with-current-continuation]
        [read-char read-char]
        [reverse reverse]
        [open-input-string open-input-string] )
    (define (parse-args)
      (let ([buffer (make-string 1024)])
        (handle-exceptions ex
            (begin
              (dbgout "invalid argument syntax\n")
              #f)
          (let loop ([i 0])
            (let ([c (read-char ##dbg#command-input-port)])
              (if (or (eof-object? c) (char=? #\newline c) (char=? #\return c))
                  (let ([in (open-input-string (substring buffer 0 i))])
                    (let loop ([args '()])
                      (let ([x (read in)])
                        (if (eof-object? x)
                            (reverse args)
                            (loop (cons x args)) ) ) ) )
                  (begin
                    (string-set! buffer i c)
                    (loop (fx+ i 1)) ) ) ) ) ) ) )
    (lambda msg
      (when debugging (##sys#error "debugger already active"))
      (when (pair? msg) (dbgout msg #\newline))
      (call-with-current-continuation 
       (lambda (k)
         (##sys#dynamic-wind
          (lambda ()
            (set! ##dbg#thread-list (##sys#fetch-and-clear-threads))
            (set! debugging #t)
            (set! ##dbg#continue k) )
          (lambda ()
            (dbgout "\nBacktrace:\n")
            (show-backtrace 5)
            (dbgout #\newline)
            (let loop ()
              (dbgout "debug>>> ")
              (let ([cmd (read ##dbg#command-input-port)])
                (handle-exceptions ex (print-error ex)
                  (cond [(eof-object? cmd) 
                         (dbgout "end of file - terminating\n")
                         (exit) ]
                        [(and (pair? cmd) (eq? 'unquote (car cmd)))
                         (let ([a (assq (cadr cmd) ##dbg#command-table)])
                           (if a 
                               (and-let* ([args (parse-args)])
                                 (apply (cdr a) args) )
                               (dbgout "undefined debugger command: " cmd 
#\newline) ) ) ]
                        [else 
                         (let-values ([(cte rte) (top-env)])
                           (dbgout* ((##sys#compile-to-closure cmd cte '()) 
rte))
                           (dbgout #\newline) ) ] ) )
                (loop) ) ) )
          (lambda ()
            (set! debugging #f)
            (##sys#restore-threads ##dbg#thread-list)
            (set! ##dbg#thread-list #f) ) ) ) ) ) ) )

(define (top-env)
  (let loop ([stack ##dbg#call-stack])
    (if (null? stack)
        (values '() '())
        (let ([e (car stack)])
          (case (vector-ref e 0)
            [(bind) (values (vector-ref e 1) (vector-ref e 2))]
            [(entry) (values (vector-ref e 3) (vector-ref e 6))]
            [else (loop (cdr stack))] ) ) ) ) )

(define (##dbg#add-command name proc)
  (let ([a (assq name ##dbg#command-table)])
    (unless a 
      (set! a (cons name #f))
      (set! ##dbg#command-table (cons a ##dbg#command-table)) )
    (set-cdr! a proc) ) )

(define (del lst pred)
  (##sys#check-list lst)
  (if (null? lst)
      '()
      (let ([y (##sys#slot lst 0)])
        (if (pred y)
            (del (##sys#slot lst 1) pred)
            (cons y (del (##sys#slot lst 1) pred)) ) ) ) )

(define (property-predicate propn)
  (lambda (x) (eq? propn (##sys#slot x 0)) ) )
               
(define-macro (define-debugger-command head . body)
  (match head
    [((names ...) . llist) 
     `(for-each (cute ##dbg#add-command <> (lambda ,llist ,@body)) ',names) ]
    [(name . llist) `(##dbg#add-command ',name (lambda ,llist ,@body))] ) )

(define-debugger-command ((? h help))
  (dbgout #<<EOF
,?  ,h  ,help                   this information
,q  ,quit                       quit current process
,t  ,top                        reset to toplevel
,e  ,environment                show lexical environment
,c  ,continue EXP ...           return values and continue
,b  ,backtrace                  show call-frame backtrace
,catch [TYPE ...]               catch exceptions of given types
,uncatch [TYPE ...]             don't catch exceptions
,terminate [THREAD ...]         terminate threads
,exception                      show current exception
,watch [VAR ...]                set watchpoint
,unwatch [VAR ...]              clear watchpoint
,break [NAME ...]               set breakpoint
,unbreak [NAME ...]             clear breakpoint
,condition VAR EXP              set watchpoint/breakpoint condition
,restart INDEX X ...            restart call-frame
,return INDEX X ...             return from call-frame

EOF
  ) )

(define-debugger-command ((q quit)) (exit))

(define-debugger-command ((t top))
  (if (eq? ##sys#current-thread ##sys#primordial-thread)
      (reset)
      (dbgout "can not reset non-primordial thread\n") ) )

(define-debugger-command (terminate . t)
  ;; this should remove the terminated threads from the thread-list
  (for-each
   (lambda (ct)
     (##sys#check-structure ct 'thread)
     (##sys#setslot ct 7 current-exception)
     (##sys#thread-kill! ct 'terminated) )
   (if (null? t)
       (list ##sys#current-thread)
       t) ) )

(define-debugger-command (exception)
  (print-exn current-exception) )

(define-debugger-command (threads)
  (let ([ready (cons ##sys#current-thread (##sys#slot ##dbg#thread-list 0))]
        [fd (##sys#slot ##dbg#thread-list 2)]
        [to (##sys#slot ##dbg#thread-list 3)] )
    (for-each (lambda (t) (dbgout (##sys#slot t 6) "  ready\n")) ready)
    (for-each
     (lambda (a)
       (let ([fd (car a)])
         (for-each (lambda (t) (dbgout (##sys#slot t 6) "  blocked  (fd: " fd 
")\n")) (cdr a)) ) )
     fd)
    (for-each
     (lambda (a) 
       (dbgout (##sys#slot (cdr a) 6) "  blocked  (timeout: " (car a) ")\n") )
     to) ) )

(define-debugger-command ((e environment))
  (define (show i cte rte)
    (unless (null? cte)
      (dbgout i ":\n")
      (for-each
       (lambda (v x)
         (dbgout "  " v " -> ")
         (dbgout* x)
         (dbgout #\newline) )
       (car cte)
       (vector->list (car rte)) )
      (show (add1 i) (cdr cte) (cdr rte)) ) )
  (let-values ([(cte rte) (top-env)])
    (show 1 cte rte) ) )

(define-debugger-command ((c continue) . args)
  (apply ##dbg#continue (map eval args)) )

(define-debugger-command ((b backtrace))
  (show-backtrace 999) )

(define (show-backtrace limit)
  (define (infoname info)
    (if info (vector-ref info 0) '<lambda>) )
  (let loop ([stack ##dbg#call-stack] [i 0])
    (if (> i limit)
        (dbgout "...\n")
        ;; llist + rte should be transformed to actual parameter list.
        (match stack
          [() #f]
          [(#('entry info1 _ _ llist _ _)
            #('call info2 _ args)
            . more)
           (if (eq? info1 info2)
               (begin
                 (dbgout i ": ")
                 (dbgout* (cons (infoname info1) args))
                 (dbgout #\newline)
                 (loop more (add1 i)) )
               (begin
                 (dbgout "   ")
                 (dbgout* (cons (infoname info1) llist))
                 (dbgout #\newline i ": ")
                 (dbgout* (cons (infoname info2) args))
                 (dbgout #\newline)
                 (loop more (add1 i))) ) ]
          [(#('entry info _ _ llist _ _) . more)
           (dbgout "  ")
           (dbgout* (cons (infoname info) llist))
           (dbgout #\newline)
           (loop more i) ]
          [(#('call info _ args) . more)
           (dbgout i ": ")
           (dbgout* (cons (infoname info) args))
           (dbgout #\newline) 
           (loop more (add1 i)) ]
          [(_ . more) (loop more i)] ) ) ) )

(define (find-frame index)
  (let loop ([stack ##dbg#call-stack] [i 0])
    (match stack
      [() #f]
      [(#('entry info1 _ _ _ _ _) (and frame #('call info2 _ _)) . more)
       (if (eq? info1 info2)
           (if (eq? i index)
               frame
               (loop more (add1 i)) )
           (loop more (add1 i)) ) ]
      [((and frame #('call info _ _)) . more)
       (if (eq? i index)
           frame
           (loop more (add1 i)) ) ]
      [(_ . more) (loop more i)] ) ) )

(define-debugger-command (catch . types)
  (match types
    [() #t]
    [(#t . _) (set! caught-exception-types #t)]
    [(names ...) (set! caught-exception-types names)]
    [_ (dbgout "invalid arguments\n")] )
  (dbgout caught-exception-types #\newline) )

(define-debugger-command (uncatch . types)
  (set! caught-exception-types
    (cond [(null? types) '(exn)]
          [(list? types)
           (let loop ([types caught-exception-types])
             (if (memq (##sys#slot types 0) names)
                 (loop (##sys#slot types 1))
                 (cons (##sys#slot types 0) (loop (##sys#slot types 1))) ) ) ]
          [else
           (dbgout "invalid arguments\n")
           caught-exception-types] ) )
  (dbgout caught-exception-types #\newline) )

(define-debugger-command (watch . vars)
  (for-each
   (lambda (v)
     (let ([info (##dbg#lookup-symbol-info v)])
       (unless (find-info v watch-list)
         (set! watch-list (cons info watch-list))
         (##sys#setslot info 1 (cons '(watch) (##sys#slot info 1))) ) ) )
   vars)
  (list-items watch-list 'watch) )

(define (list-items lst prop)
  (let loop ([lst lst] [i 0])
    (unless (null? lst)
      (let ([info (##sys#slot lst 0)])
        (dbgout i ": " (##sys#slot info 0))
        (and-let* ([a (assq prop (##sys#slot info 1))])
          (when (pair? (cdr a))
            (dbgout "  when: ")
            (dbgout* (caddr a)) ) )
        (dbgout #\newline) 
        (loop (cdr lst) (add1 i)) ) ) ) )

(define-debugger-command (unwatch . vars)
  (for-each
   (lambda (info)
     (##sys#setslot info 1 (del (##sys#slot info 1) (property-predicate 
'watch)))
     (set! watch-list (del watch-list (cut eq? <> info))) )
   (if (null? vars)
       watch-list
       (map ##dbg#lookup-symbol-info vars) ) ) )

(define-debugger-command (break . names)
  (for-each
   (lambda (v)
     (let ([info (##dbg#lookup-symbol-info v)])
       (unless (find-info v break-list)
         (set! break-list (cons info break-list)) 
         (##sys#setslot info 1 (cons '(break-call) (##sys#slot info 1))) ) ) )
   names)
  (list-items break-list 'break-call) )

(define-debugger-command (unbreak . vars)
  (for-each
   (lambda (info)
     (##sys#setslot info 1 (del (##sys#slot info 1) (property-predicate 
'break-call)))
     (set! break-list (del break-list (cut eq? <> info))) )
   (if (null? vars)
       break-list
       (map ##dbg#lookup-symbol-info vars) ) ) )

(define (find-info name lst)
  (let loop ([lst lst])
    (and (pair? lst)
         (let ([info (##sys#slot lst 0)])
           (if (eq? name (##sys#slot info 0))
               info
               (loop (##sys#slot lst 1)) ) ) ) ) )

(define-debugger-command (condition name exp)
  (let ([info (find-info name watch-list)])
    (if info
        (and-let* ([a (assq 'watch (##sys#slot info 1))])
          (##sys#setslot a 1 (list (##sys#compile-to-closure exp '() '()) exp)) 
          (list-items watch-list 'watch) )
        (and-let* ([info (find-info name break-list)]
                   [a (assq 'break-call (##sys#slot info 1))] )
          (##sys#setslot a 1 (list (##sys#compile-to-closure exp '() '()) exp)) 
          (list-items break-list 'break-call) ) ) ) )

(define-debugger-command (restart index . args)
  (let ([frame (find-frame index)])
    (if frame
        (let ([redo (##sys#slot frame 2)])
          (receive vals (apply redo #t (map eval args))
            (apply redo #f vals) ) )
        (dbgout "invalid frame index\n") ) ) )

(define-debugger-command (return index . args)
  (let ([frame (find-frame index)])
    (if frame
        (apply (##sys#slot frame 2) #f (map eval args))
        (dbgout "invalid frame index\n") ) ) )

reply via email to

[Prev in Thread] Current Thread [Next in Thread]