From d48873795e8c8cd1e10aa5290093f7f5314473d2 Mon Sep 17 00:00:00 2001 From: Greg Cooper Date: Sat, 7 Jul 2007 16:05:04 +0000 Subject: [PATCH] added multi-file debugging support, along with some cleanup and minor improvements svn: r6838 --- collects/mztake/annotator.ss | 7 +- collects/mztake/debug-tool.ss | 818 ++++++++++++++++++++-------------- 2 files changed, 490 insertions(+), 335 deletions(-) diff --git a/collects/mztake/annotator.ss b/collects/mztake/annotator.ss index 6ecffa7c53..51e12d958a 100644 --- a/collects/mztake/annotator.ss +++ b/collects/mztake/annotator.ss @@ -60,7 +60,8 @@ stx (lambda (debug-info annotated raw is-tail?) (let* ([start (syntax-position raw)] - [end (+ start (syntax-span raw) -1)]) + [end (+ start (syntax-span raw) -1)] + [break? (break? (syntax-source raw))]) (if is-tail? #`(let-values ([(value-list) #f]) (if (#,break? #,start) @@ -203,13 +204,13 @@ [else (annotate stx '() #f module-name )])) - (define (annotate expr bound-vars is-tail? module-name ) + (define (annotate expr bound-vars is-tail? module-name) (define annotate-break? (let ([pos (syntax-position expr)] [src (syntax-source expr)]) (and (or (not source) - (eq? src source #;(syntax-source stx))) + (eq? src #;source (syntax-source stx))) ; (is-a? src object%) ; FIX THIS pos (hash-table-get breakpoints pos (lambda () #t)) diff --git a/collects/mztake/debug-tool.ss b/collects/mztake/debug-tool.ss index 7de1141e68..365c7a75d3 100644 --- a/collects/mztake/debug-tool.ss +++ b/collects/mztake/debug-tool.ss @@ -7,6 +7,7 @@ (lib "unit.ss") (lib "contract.ss") (lib "mred.ss" "mred") + (lib "match.ss") (prefix drscheme:arrow: (lib "arrow.ss" "drscheme")) (lib "tool.ss" "drscheme") "marks.ss" @@ -14,30 +15,27 @@ (lib "bitmap-label.ss" "mrlib") "annotator.ss" "load-sandbox.ss" - ;(lib "framework.ss" "framework") + (lib "framework.ss" "framework") (lib "string-constant.ss" "string-constants") ) (provide tool@) - (define (robust-syntax-source stx) - (and (syntax? stx) (syntax-source stx))) - ; QUESTIONS/IDEAS ; what is the right way to deal with macros? ; how can the three tool classes communicate with each other safely - + (define tool@ (unit (import drscheme:tool^) (export drscheme:tool-exports^) (define phase1 void) (define phase2 void) - + (define (extract-language-level settings) (let* ([language (drscheme:language-configuration:language-settings-language settings)]) (car (last-pair (send language get-language-position))))) - + (define (debugger-does-not-work-for? lang) (member lang (list (string-constant beginning-student) (string-constant beginning-student/abbrev) @@ -45,13 +43,18 @@ (string-constant intermediate-student/lambda) (string-constant advanced-student)))) + (define (robust-syntax-source stx) + (and (syntax? stx) (syntax-source stx))) + (define (robust-vector-ref vec idx) (if (< idx (vector-length vec)) (vector-ref vec idx) #f)) - (define (break-at bp p) - (hash-table-get bp p #f)) + (define (safe-vector-set! vec idx val) + (when (< idx (vector-length vec)) + (vector-set! vec idx val)) + (void)) (define (truncate str n) (if (< (string-length str) n) @@ -64,7 +67,7 @@ (define (clean-status s) (truncate (regexp-replace* #rx"\n" s " ") 200)) - + (define (index-of chr str) (let loop ([i 0]) (if (< i (string-length str)) @@ -72,7 +75,7 @@ i (loop (add1 i))) #f))) - + (define (trim-expr-str str) (cond [(index-of #\newline str) => (lambda (i) @@ -86,6 +89,17 @@ (define (average . values) (/ (apply + values) (length values))) + (define (filename->defs source) + (if (is-a? source editor<%>) + source + (cond + [(send (group:get-the-frame-group) locate-file source) + => + (lambda (frame) + (let ([defss (map (lambda (t) (send t get-defs)) (send frame get-tabs))]) + (findf (lambda (d) (equal? (send d get-filename) source)) defss)))] + [else #f]))) + (define (debug-definitions-text-mixin super%) (class super% @@ -96,6 +110,7 @@ end-edit-sequence get-canvas get-top-level-window + get-filename get-tab) (define mouse-over-pos #f) @@ -106,7 +121,7 @@ 'solid)) (define bp-tmp-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) (define bp-tmp-brush (send the-brush-list find-or-create-brush "yellow" - 'solid)) + 'solid)) (define pc-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) (define pc-brush (send the-brush-list find-or-create-brush "forestgreen" 'solid)) (define pc-err-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) @@ -137,6 +152,7 @@ (for-each (lambda (p) (hash-table-put! breakpoints (car p) (cdr p))) shifts)) (inner (void) on-delete start len)) + (define/augment (after-delete start len) (inner (void) after-delete start len) (when (send (get-tab) debug?) @@ -156,12 +172,31 @@ (for-each (lambda (p) (hash-table-put! breakpoints (car p) (cdr p))) shifts)) (inner (void) on-insert start len)) + (define/augment (after-insert start len) (inner (void) after-insert start len) (when (send (get-tab) debug?) (send (get-tab) hide-debug)) (end-edit-sequence)) - + + (define (lookup-var id frames sk fk) + (cond + [(and id frames (lookup-first-binding + (lambda (id2) (module-identifier=? id id2)) + frames + (lambda () #f))) + => + (lambda (binding) + (sk (mark-binding-value binding) + (lambda (v) (mark-binding-set! binding v))))] + [(and id (send (get-tab) lookup-top-level-var + id + (lambda () #f))) + => + (lambda (tlb) + (sk (tlb) tlb))] + [else (fk)])) + (define/private (get-pos/text event) (let ([event-x (send event get-x)] [event-y (send event get-y)] @@ -202,8 +237,8 @@ (unbox xrb) (unbox yrb))] [(xr yr) (dc-location-to-editor-location xr-off yr-off)]) (values xl yl xr yr)))) - - (define/private (render v) + + (define/private (render v) (send (get-tab) render v)) (define/override (on-event event) @@ -214,7 +249,7 @@ (when mouse-over-pos (set! mouse-over-pos #f) (invalidate-bitmap-cache)) - (super on-event event)] + (super on-event event)] [(or (send event moving?) (send event entering?)) (let-values ([(pos text) (get-pos/text event)]) @@ -236,44 +271,31 @@ (let* ([frames (send (get-tab) get-stack-frames)] [pos-vec (send (get-tab) get-pos-vec)] [id (robust-vector-ref pos-vec pos)] - #; + #; [_ (printf "frames = ~a~npos-vec = ~a~nid = ~a~n" frames pos-vec id)]) (send (get-tab) set-mouse-over-msg - ; consider rewriting so we can look up top-level vars even - ; when not suspended - (cond - [(and id frames - (let/ec k - (let* ([id-sym (syntax-e id)] - [binding (lookup-first-binding - (lambda (id2) (module-identifier=? id id2)) - frames (lambda () - ;(printf "failed to find var ~a on stack~n" id) - (k (clean-status - (format "~a = ~a" id-sym - (render - ((send (get-tab) lookup-top-level-var - id - (lambda () (k #f))))))))))] - [val (mark-binding-value - binding)]) - (clean-status (format "~a = ~a" id-sym (render val))))))] - [""])))))) - (super on-event event)] + (clean-status + (lookup-var id frames + ; id found + (lambda (val _) + (format "~a = ~a" (syntax-e id) (render val))) + ; id not found + (lambda () "")))))))) + (super on-event event)] [(send event button-down? 'right) (let-values ([(pos text) (get-pos/text event)]) (if (and pos text) (let* ([pos (add1 pos)] [break-status (hash-table-get breakpoints pos (lambda () 'invalid))]) - (case break-status - [(#t #f) + (match break-status + [(or #t #f (? procedure?)) (let ([menu (make-object popup-menu% #f)]) (make-object menu-item% (if break-status - "Remove pause at this point" - "Pause at this point") + "Remove pause at this point" + "Pause at this point") menu (lambda (item evt) (hash-table-put! breakpoints pos (not break-status)) @@ -282,17 +304,14 @@ (if (and pc (= pos pc)) (let* ([stat (send (get-tab) get-break-status)] [f (get-top-level-window)] - [rendered-value (if (cons? stat) - (if (= 2 (length stat)) - (render (cadr stat)) - (format "~a" (cons 'values - (map (lambda (v) (render v)) (rest stat))))) - "")]) + [rendered-value + (if (cons? stat) + (if (= 2 (length stat)) + (render (cadr stat)) + (format "~a" (cons 'values + (map (lambda (v) (render v)) (rest stat))))) + "")]) (when (cons? stat) - #;(send (make-object menu-item% - (clean-status (format "expr -> ~a" rendered-value)) - menu - void) enable #f) (make-object menu-item% "Print return value to console" menu @@ -311,10 +330,10 @@ (send (get-tab) set-break-status (cons 'exit-break (call-with-values - (lambda () - (with-handlers ([exn:fail? k]) ; LATER: message box - (eval-string tmp))) - list)))))))))) + (lambda () + (with-handlers ([exn:fail? k]) ; LATER: message box + (eval-string tmp))) + list)))))))))) (make-object menu-item% "Continue to this point" menu @@ -328,23 +347,19 @@ (send (get-canvas) popup-menu menu (+ 1 (inexact->exact (floor (send event get-x)))) (+ 1 (inexact->exact (floor (send event get-y))))))] - [(invalid) + ['invalid (let* ([frames (send (get-tab) get-stack-frames)] [pos-vec (send (get-tab) get-pos-vec)] [id (robust-vector-ref pos-vec pos)] #; [_ (printf "frames = ~a~npos-vec = ~a~nid = ~a~n" - frames pos-vec id)]) - (unless (and - id frames - (let/ec k - (let* ([id-sym (syntax-e id)] - [binding (lookup-first-binding - (lambda (id2) (module-identifier=? id id2)) - frames (lambda () (k #f)))] - [val (mark-binding-value - binding)] - [menu (make-object popup-menu% #f)]) + frames pos-vec id)]) + (unless (lookup-var + id + frames + (lambda (val wr) + (let ([id-sym (syntax-e id)] + [menu (make-object popup-menu% #f)]) (make-object menu-item% (clean-status (format "Print value of ~a to console" id-sym)) @@ -357,14 +372,15 @@ (lambda (item evt) (let ([tmp (get-text-from-user - (format "New value for ~a" id-sym) #f #f - (format "~a" val))]) + (format "New value for ~a" id-sym) #f #f + (format "~a" val))]) (when tmp - (mark-binding-set! binding (eval-string tmp)))))) + (wr (eval-string tmp)))))) (send (get-canvas) popup-menu menu (+ 1 (inexact->exact (floor (send event get-x)))) (+ 1 (inexact->exact (floor (send event get-y))))) - #t))) + #t)) + (lambda () #f)) (super on-event event)))])) (super on-event event)))] [else (super on-event event)])) @@ -389,17 +405,19 @@ [(#f) (send dc set-pen bp-mo-pen) (send dc set-brush bp-mo-brush)] [else (send dc set-pen bp-tmp-pen) - (send dc set-brush bp-tmp-brush)]) + (send dc set-brush bp-tmp-brush)]) ;(drscheme:arrow:draw-arrow dc xl yl xr yr dx dy) (send dc draw-ellipse (+ xl dx) (+ yl dy yoff) diameter diameter) #; (send dc draw-polygon stop-sign - (+ xl dx) - (+ yl dy 2)) + (+ xl dx) + (+ yl dy 2)) (send dc set-pen op) (send dc set-brush ob))))))) - (let ([pos (send (get-tab) get-pc)]) - (when pos + (let ([pc-defs (send (get-tab) defs-containing-pc)] + [pos (send (get-tab) get-pc)]) + #;(printf "pc-defs = ~a, this frame = ~a, pos = ~a~n" pc-defs this pos) + (when (and (eq? pc-defs this) pos) (let*-values ([(xl yl xr yr) (find-char-box this (sub1 pos) pos)] [(ym) (average yl yr)]) (let ([op (send dc get-pen)] @@ -434,128 +452,193 @@ (send dc set-brush pc-brush)])) (drscheme:arrow:draw-arrow dc xm0 ym0 xr ym dx dy) (loop start-pos (rest marks))))))))) - - (define/augment (after-set-next-settings s) + + (define/augment (after-set-next-settings s) (let ([tlw (get-top-level-window)]) (when tlw (send tlw check-current-language-for-debugger))) - (inner (void) after-set-next-settings s)))) + (inner (void) after-set-next-settings s)))) (define (debug-interactions-text-mixin super%) (class super% (inherit run-in-evaluation-thread - display-results - #;get-tab) + display-results) (super-instantiate ()) - (define tab #f) - (define/private (get-tab) tab) - (define/public (set-tab t) (set! tab t)) - + (define debugged-thread #f) + (define tab #f) + (define/public (get-tab) tab) + (define/public (set-tab t) (set! tab t)) + + (define/private (stx-source->breakpoints src) + (send (send (if src (filename->defs src) this) get-tab) get-breakpoints)) + + (define/private (stx-source->pos-vec src) + (send (send (if src (filename->defs src) this) get-tab) get-pos-vec)) + ;; make-debug-eval-handler : (sexp -> value) -> sexp -> value ;; adds debugging information to `sexp' and calls `oe' (define/private (make-debug-eval-handler oe break? break-before break-after) (lambda (orig-exp) (if (compiled-expression? (if (syntax? orig-exp) - (syntax-e orig-exp) - orig-exp)) + (syntax-e orig-exp) + orig-exp)) (oe orig-exp) - (let loop ([exp (if (syntax? orig-exp) - orig-exp - (namespace-syntax-introduce - (datum->syntax-object #f orig-exp)))]) - (let ([top-e (expand-syntax-to-top-form exp)]) - (parameterize ([current-eval oe]) - (eval/annotations - top-e - (lambda (fn m) #f) ; TODO: multiple file support - (lambda (stx) - (let*-values ([(breakpoints) (send (get-tab) get-breakpoints)] - [(pos-vec) (send (get-tab) get-pos-vec)] - [(annotated break-posns) - (annotate-for-single-stepping - (expand-syntax top-e) - break? - break-before - break-after - (lambda (type bound binding) - ;(display-results (list bound)) - (when (eq? (robust-syntax-source bound) - (robust-syntax-source exp)) - (let loop ([i 0]) - (when (< i (syntax-span bound)) - (vector-set! pos-vec (+ i (syntax-position bound)) binding) - (loop (add1 i)))))) - (lambda (mod var val) - (send (get-tab) add-top-level-binding var val) - #; - (printf "top-level binding: ~a ~a ~a~n" mod var val)) - (send (get-tab) get-defs))]) - (hash-table-for-each - breakpoints - (lambda (pos status) - ; possible efficiency problem for large files with many breakpoints - (when (and (syntax-position top-e) - (>= pos (syntax-position top-e)) - (< pos (+ (syntax-position top-e) (syntax-span top-e))) - (not (memq pos break-posns))) - (hash-table-remove! breakpoints pos)))) - (for-each (lambda (posn) - (hash-table-put! - breakpoints posn - (hash-table-get breakpoints posn (lambda () #f)))) break-posns) - ;(display-results (list orig-exp)) - annotated))))))))) + (let* ([exp (if (syntax? orig-exp) + orig-exp + (namespace-syntax-introduce + (datum->syntax-object #f orig-exp)))] + [top-e (expand-syntax-to-top-form exp)]) + (parameterize ([current-eval oe]) + (eval/annotations + top-e + ; annotate-module? + (lambda (fn m) + #; + (printf "debugger: loading ~a (~a)~n" m fn) + (cond + [(filename->defs fn) + => + ; fn is loaded into defs + (lambda (defs) + (let ([extern-tab (send defs get-tab)] + [this-tab (get-tab)]) + ; TODO: make sure that defs's tab is + ; not already involved in a debugging session + ; perhaps allow takeover of previous session + (case (if (or (not (send extern-tab debug?)) + (eq? this-tab (send extern-tab get-master))) + (message-box + "Debugging Multi-File Program" + (format "Debug ~a?" fn) + #f + '(yes-no)) + (message-box + "Debugging Multi-File Program" + (format "~a is already involved in a debugging session." fn) + #f + '(ok))) + [(yes) + ; set tab up with shared data from the master tab + (send extern-tab prepare-execution #t) + (send this-tab add-slave extern-tab) + (call-with-values + (lambda () (send this-tab get-shared-data)) + (lambda vals (send extern-tab set-shared-data . vals))) + #t] + [(no ok) + (send extern-tab prepare-execution #f) + #f])))] + ; fn is not open, so don't try to debug it + [else #f])) + ; annotator + (lambda (stx) + (let*-values ([(source) (syntax-source stx)] + [(breakpoints) (stx-source->breakpoints source)] + [(pos-vec) (stx-source->pos-vec source)] + [(annotated break-posns) + (annotate-for-single-stepping + (expand-syntax stx) + break? + break-before + break-after + ; record-bound-identifier + (lambda (type bound binding) + ;(display-results (list bound)) + (when (eq? (robust-syntax-source bound) source) + (let loop ([i 0]) + (when (< i (syntax-span bound)) + (safe-vector-set! pos-vec (+ i (syntax-position bound)) binding) + (loop (add1 i)))))) + ; record-top-level-identifier + (lambda (mod var val) + ; filename->defs should succeed unless a slave tab gets closed + (cond + [(filename->defs source) + => + (lambda (defs) + (send (send defs get-tab) + add-top-level-binding var val))] + [else (printf "record-top-level failed~n")]) + #; + (printf "top-level binding: ~a ~a ~a~n" mod var val)) + source)]) + (hash-table-for-each + breakpoints + (lambda (pos status) + ; possible efficiency problem for large files with many breakpoints + (when (and (syntax-position stx) + (>= pos (syntax-position stx)) + (< pos (+ (syntax-position stx) (syntax-span stx))) + (not (memq pos break-posns))) + (hash-table-remove! breakpoints pos)))) + (for-each (lambda (posn) + (hash-table-put! + breakpoints posn + (hash-table-get breakpoints posn (lambda () #f)))) break-posns) + annotated)))))))) (define/override (reset-console) (super reset-console) - (when (and (get-tab) (send (get-tab) debug?)) - (let ([breakpoints (send (get-tab) get-breakpoints)]) - (run-in-evaluation-thread - (lambda () - ;(print-struct #t) - (let ([self (current-thread)] - [oeh (uncaught-exception-handler)] - [err-hndlr (error-display-handler)]) - (error-display-handler - (lambda (msg exn) - (err-hndlr msg exn) - (if (and (eq? self (current-thread)) (exn:fail? exn)) - (send (get-tab) suspend oeh - (continuation-mark-set->list (exn-continuation-marks exn) debug-key) - 'error)))) ; this breaks the buttons because it looks like we can resume - (current-eval - (make-debug-eval-handler - (current-eval) - (lambda (pos) - (or (hash-table-get breakpoints -1) - (let ([bp (hash-table-get breakpoints pos #f)]) - (if (procedure? bp) - (bp) - bp)))) - ; break-before - (lambda (top-mark ccm) - (let* ([debug-marks (continuation-mark-set->list ccm debug-key)]) - (send (get-tab) suspend oeh (cons top-mark debug-marks) 'entry-break))) - ; break-after - (case-lambda - [(top-mark ccm val) - (let* ([debug-marks (continuation-mark-set->list ccm debug-key)]) - (car (send (get-tab) suspend oeh (cons top-mark debug-marks) (list 'exit-break val))))] - [(top-mark ccm . vals) - (let* ([debug-marks (continuation-mark-set->list ccm debug-key)]) - (apply values - (send (get-tab) suspend oeh (cons top-mark debug-marks) (cons 'exit-break vals))))]))) - (uncaught-exception-handler - (lambda (exn) - (if (and (exn:break? exn) (send (get-tab) suspend-on-break?)) - (let ([marks (exn-continuation-marks exn)] - [cont (exn:break-continuation exn)]) - (send (get-tab) suspend oeh (continuation-mark-set->list marks debug-key) 'break) - (cont)) - (oeh exn)))))))))))) + (let ([tab (get-tab)]) + (when (and tab (send tab debug?)) + (let ([breakpoints (send tab get-breakpoints)]) + (run-in-evaluation-thread + (lambda () + ;(print-struct #t) + (let ([self (current-thread)] + [oeh (uncaught-exception-handler)] + [err-hndlr (error-display-handler)]) + (set! debugged-thread self) + (error-display-handler + (lambda (msg exn) + (err-hndlr msg exn) + (if (and (eq? self (current-thread)) (exn:fail? exn)) + (send (get-tab) suspend oeh + (continuation-mark-set->list (exn-continuation-marks exn) debug-key) + 'error)))) ; this breaks the buttons because it looks like we can resume + (current-eval + (make-debug-eval-handler + (current-eval) + ; break? -- curried to avoid looking up defs from source each time + (lambda (src) + (let* ([src-tab (send (filename->defs src) get-tab)] + [breakpoints + (if src + (send src-tab get-breakpoints) + breakpoints)] + [single-step? (send tab get-single-step-box)] + [closed? (send src-tab get-closed-box)]) + (lambda (pos) + (and (not (unbox closed?)) + (or (unbox single-step?) + (let ([bp (hash-table-get breakpoints pos #f)]) + (if (procedure? bp) + (bp) + bp))))))) + ; break-before + (lambda (top-mark ccm) + (let* ([debug-marks (continuation-mark-set->list ccm debug-key)]) + (send (get-tab) suspend oeh (cons top-mark debug-marks) 'entry-break))) + ; break-after + (case-lambda + [(top-mark ccm val) + (let* ([debug-marks (continuation-mark-set->list ccm debug-key)]) + (car (send (get-tab) suspend oeh (cons top-mark debug-marks) (list 'exit-break val))))] + [(top-mark ccm . vals) + (let* ([debug-marks (continuation-mark-set->list ccm debug-key)]) + (apply values + (send (get-tab) suspend oeh (cons top-mark debug-marks) (cons 'exit-break vals))))]))) + (uncaught-exception-handler + (lambda (exn) + (if (and (exn:break? exn) (send (get-tab) suspend-on-break?)) + (let ([marks (exn-continuation-marks exn)] + [cont (exn:break-continuation exn)]) + (send (get-tab) suspend oeh (continuation-mark-set->list marks debug-key) 'break) + (cont)) + (oeh exn))))))))))))) (define (debug-tab-mixin super%) (class super% @@ -563,29 +646,54 @@ (inherit get-defs get-ints get-frame) - - (define breakpoints (make-hash-table)) - (hash-table-put! breakpoints -1 #f) - (define suspend-sema (make-semaphore 1)) - (define resume-ch (make-channel)) - (define in-user-ch (make-channel)) - (define want-suspend-on-break? #f) - (define want-debug? #f) + + (field [breakpoints (make-hash-table)] + [suspend-sema (make-semaphore 1)] + [resume-ch (make-channel)] + [in-user-ch (make-channel)] + [want-suspend-on-break? #f] + [want-debug? #f] + [master this] + [slaves empty] + [closed? (box #f)] + [stack-frames (box #f)] + [break-status (box #f)] + [current-language-settings #f] + [pos-vec (vector #f)] + [single-step? (box #t)] + [top-level-bindings empty] + [control-panel #f]) + (define/public (debug?) want-debug?) - (define stack-frames #f) - (define current-language-settings #f) - (define pos-vec (make-vector 1)) + (define/public (get-master) master) + (define/public (add-slave s) + (set! slaves (cons s slaves))) + (define/public (get-closed-box) closed?) (define/public suspend-on-break? (case-lambda [() want-suspend-on-break?] [(v) (set! want-suspend-on-break? v)])) - (define/public (get-stack-frames) stack-frames) + (define/public (get-stack-frames) + (unbox stack-frames)) (define/public (get-pos-vec) pos-vec) (define/public (get-breakpoints) breakpoints) - (define break-status #f) - (define/public (get-break-status) break-status) - (define/public (set-break-status stat) (set! break-status stat)) - (define top-level-bindings empty) + (define/public (get-break-status) (unbox break-status)) + + (define/public (set-shared-data bs sf sema res-ch usr-ch step? m) + (set! break-status bs) + (set! stack-frames sf) + (set! suspend-sema sema) + (set! resume-ch res-ch) + (set! in-user-ch usr-ch) + (set! single-step? step?) + (set! master m)) + + (define/public (get-shared-data) + (values break-status stack-frames suspend-sema resume-ch in-user-ch single-step? master)) + + (define/public (get-single-step-box) single-step?) + (define/public (set-single-step?! v) (set-box! single-step? v)) + (define/public (set-break-status stat) (set-box! break-status stat)) (define/public (add-top-level-binding var val) (set! top-level-bindings (cons (cons var val) top-level-bindings))) (define/public (lookup-top-level-var var failure-thunk) @@ -599,130 +707,174 @@ #; (printf "~a = ~a -> ~a~n" var (caar bindings) res) res) (cdar bindings)] - [(loop (rest bindings))]))) - (define control-panel #f) + [else (loop (rest bindings))]))) + (define/public (resume) - (let ([v break-status]) - (resume-gui) - (channel-put resume-ch (if (pair? v) - (cdr v) - #f)))) + (let ([v (get-break-status)]) + (resume-gui) + (channel-put resume-ch (and (pair? v) (cdr v))))) + (define/public (set-mouse-over-msg msg) (send (get-frame) set-mouse-over-msg msg)) + (define/public (defs-containing-pc) + (let ([stack-frames (get-stack-frames)]) + (and (cons? stack-frames) + (let* ([src-stx (mark-source (first stack-frames))] + [source (syntax-source src-stx)]) + (if source + (filename->defs source) + (get-defs)))))) + (define/public (get-pc) - (if (cons? stack-frames) - (let* ([src-stx (mark-source (first stack-frames))] - [start (syntax-position src-stx)] - [end (and start (+ start (syntax-span src-stx) -1))]) - (if (cons? break-status) - end - start)) - #f)) - - (define/public (render v) - ;; ==drscheme eventspace thread== - ;; only when a user thread is suspended - (let ([result-ch (make-channel)]) - (channel-put in-user-ch (lambda () - (let ([s (open-output-string)]) - (send (drscheme:language-configuration:language-settings-language - current-language-settings) - render-value - v - (drscheme:language-configuration:language-settings-settings - current-language-settings) - s) - (channel-put result-ch (get-output-string s))))) - (channel-get result-ch))) + (let ([stack-frames (get-stack-frames)]) + (and (cons? stack-frames) + (let* ([src-stx (mark-source (first stack-frames))] + [start (syntax-position src-stx)] + [end (and start (+ start (syntax-span src-stx) -1))]) + (if (cons? (get-break-status)) + end + start))))) - (define/public (print-to-console v) - ;; ==drscheme eventspace thread== - ;; only when a user thread is suspended - (channel-put in-user-ch (lambda () (fprintf (current-error-port) " ### DEBUGGER: ~a~n" v)))) + (define (do-in-user-thread thunk) + (if (get-break-status) + (channel-put in-user-ch thunk) + (send (get-ints) run-in-evaluation-thread thunk))) + + (define/public (render v) + ;; ==drscheme eventspace thread== + ;; only when a user thread is suspended + (let ([result-ch (make-channel)]) + (do-in-user-thread + (lambda () + (let ([s (open-output-string)]) + (send (drscheme:language-configuration:language-settings-language + current-language-settings) + render-value + v + (drscheme:language-configuration:language-settings-settings + current-language-settings) + s) + (channel-put result-ch (get-output-string s))))) + (channel-get result-ch))) + + (define/public (print-to-console v) + ;; ==drscheme eventspace thread== + ;; only when a user thread is suspended + (do-in-user-thread (lambda () (fprintf (current-error-port) " ### DEBUGGER: ~a~n" v)))) + + (define/public suspend-gui + (opt-lambda (frames status [switch-tabs? #f]) + (set! want-suspend-on-break? #f) + (set-single-step?! #f) + (send (send (get-frame) get-pause-button) enable #f) + (send (send (get-frame) get-step-button) enable #t) + (send (send (get-frame) get-resume-button) enable #t) + ;;(fprintf (current-error-port) "break: ~a~n" (map expose-mark frames)) + ;;(printf "status = ~a~n" status) + (set-box! stack-frames frames) + (set-box! break-status status) + (when (cons? status) + (let ([expr (mark-source (first frames))]) + (cond + ; should succeed unless the user closes a slave tab during debugging + [(filename->defs (syntax-source expr)) + => + (lambda (defs) + (send (send (get-frame) get-status-message) set-label + (clean-status + (format "~a ==> ~a" + (trim-expr-str + (send defs get-text + (sub1 (syntax-position expr)) + (+ -1 (syntax-position expr) (syntax-span expr)))) + (if (= 2 (length status)) + (render (cadr status)) + (cons 'values (map (lambda (v) (render v)) (rest status))))))))]))) + (cond [(get-pc) + => (lambda (pc) + (cond [(defs-containing-pc) + => (lambda (defs) + (cond + [(and switch-tabs? (send defs get-filename)) + => + (lambda (fn) + (handler:edit-file fn))]) + (send defs scroll-to-position pc))]))]) + (send (get-defs) invalidate-bitmap-cache))) + + (define/public (resume-gui) + (set-box! stack-frames #f) + (set-box! break-status #f) + (send (send (get-frame) get-pause-button) enable #t) + (send (send (get-frame) get-step-button) enable #f) + (send (send (get-frame) get-resume-button) enable #f) + (send (send (get-frame) get-status-message) set-label "") + (send (get-defs) invalidate-bitmap-cache)) - (define/public (suspend-gui frames status) - (set! want-suspend-on-break? #f) - (hash-table-put! breakpoints -1 #f) - (send (send (get-frame) get-pause-button) enable #f) - (send (send (get-frame) get-step-button) enable #t) - (send (send (get-frame) get-resume-button) enable #t) - ;;(fprintf (current-error-port) "break: ~a~n" (map expose-mark frames)) - ;;(printf "status = ~a~n" status) - (set! stack-frames frames) - (set! break-status status) - (when (cons? status) - (let ([expr (mark-source (first frames))]) - (send (send (get-frame) get-status-message) set-label - (clean-status - (format "~a ==> ~a" - (trim-expr-str - (send (get-defs) get-text - (sub1 (syntax-position expr)) - (+ -1 (syntax-position expr) (syntax-span expr)))) - (if (= 2 (length status)) - (render (cadr status)) - (cons 'values (map (lambda (v) (render v)) (rest status))))))))) - (cond [(get-pc) => (lambda (pc) (send (get-defs) scroll-to-position pc))]) - (send (get-defs) invalidate-bitmap-cache)) - - (define/public (resume-gui) - (set! stack-frames #f) - (set! break-status #f) - (send (send (get-frame) get-pause-button) enable #t) - (send (send (get-frame) get-step-button) enable #f) - (send (send (get-frame) get-resume-button) enable #f) - (send (send (get-frame) get-status-message) set-label "") - (send (get-defs) invalidate-bitmap-cache)) - (define/public suspend - ;; ==called from user thread== + ;; ==called from user thread== (opt-lambda (break-handler frames [status #f]) - ;; suspend-sema ensures that we allow only one suspended thread - ;; at a time - (if (semaphore-try-wait? suspend-sema) - (begin - (parameterize ([current-eventspace (send (get-frame) get-eventspace)]) - (queue-callback (lambda () (suspend-gui frames status)))) - (with-handlers ([exn:break? - (lambda (exn) - (let ([wait-sema (make-semaphore)]) - (parameterize ([current-eventspace (send (get-frame) get-eventspace)]) - (queue-callback (lambda () - (resume-gui) - (semaphore-post wait-sema)))) - (semaphore-wait wait-sema)) - (semaphore-post suspend-sema) - (break-handler exn))]) - (begin0 - (let loop () - (sync/enable-break resume-ch - (handle-evt - in-user-ch - (lambda (thunk) - (thunk) - (loop))))) - (semaphore-post suspend-sema)))) - (if (pair? status) - (cdr status) - #f)))) + ;; suspend-sema ensures that we allow only one suspended thread + ;; at a time + (if (semaphore-try-wait? suspend-sema) + (begin + (parameterize ([current-eventspace (send (get-frame) get-eventspace)]) + (queue-callback (lambda () (suspend-gui frames status #t)))) + (with-handlers ([exn:break? + (lambda (exn) + (let ([wait-sema (make-semaphore)]) + (parameterize ([current-eventspace (send (get-frame) get-eventspace)]) + (queue-callback (lambda () + (resume-gui) + (semaphore-post wait-sema)))) + (semaphore-wait wait-sema)) + (semaphore-post suspend-sema) + (break-handler exn))]) + (begin0 + (let loop () + (sync/enable-break resume-ch + (handle-evt + in-user-ch + (lambda (thunk) + (thunk) + (loop))))) + (semaphore-post suspend-sema)))) + (if (pair? status) + (cdr status) + #f)))) (define/public (prepare-execution debug?) (set! want-debug? debug?) (if debug? (send (get-frame) show-debug) - (send (get-frame) hide-debug)) - (set! current-language-settings + (begin + (send (get-frame) hide-debug) + (set! master this) + (for-each + (lambda (t) (send t prepare-execution #f)) + slaves) + (set! slaves empty))) + (set! current-language-settings (and debug? (send (get-defs) get-next-settings))) - ;(set! breakpoints (make-hash-table)) - (hash-table-put! breakpoints -1 #t) + (set! single-step? (box #t)) (set! pos-vec (make-vector (add1 (send (get-defs) last-position)) #f)) (set! top-level-bindings empty) (set! resume-ch (make-channel)) + (set! suspend-sema (make-semaphore 1)) + (set! in-user-ch (make-channel)) + (set! break-status (box #f)) (set! want-suspend-on-break? #f) - (set! stack-frames #f) + (set! stack-frames (box #f)) (send (get-ints) set-tab this)) - + + (define/augment (on-close) + (inner (void) on-close) + (set-box! closed? #t) + (for-each + (lambda (t) (send t prepare-execution #f)) + slaves)) + (define/public (hide-debug) (send (get-frame) hide-debug)) @@ -745,17 +897,27 @@ get-menu-bar get-current-tab get-top-level-window - get-eventspace) + get-eventspace) - (define current-language-settings #f) + (define current-language-settings #f) (define control-panel #f) (define/public (set-mouse-over-msg msg) (when (not (string=? msg (send mouse-over-message get-label))) (send mouse-over-message set-label msg))) - - (define/override (execute-callback) - (send (get-current-tab) prepare-execution #f) - (super execute-callback)) + + (define/override execute-callback + (opt-lambda ([debug #f]) + (let* ([tab (get-current-tab)]) + (if (eq? tab (send tab get-master)) + (begin + (send (get-current-tab) prepare-execution debug) + (super execute-callback)) + (message-box + "Message from Debugger" + (format "This file is involved in a debugging session. To run/debug this file, finish the session for ~a and close or re-run it." + (send (send (send tab get-master) get-defs) get-filename/untitled-name)) + this + '(ok)))))) (define debug-parent-panel 'uninitialized-debug-parent-panel) (define debug-panel 'uninitialized-debug-panel) @@ -769,14 +931,8 @@ (alignment '(center center)) (style '(border)))) (send debug-parent-panel change-children (lambda (l) null)) - #; - (instantiate button% () - (label "Hide") - (parent debug-panel) - (callback (lambda (x y) (hide-debug))) - (stretchable-height #t)) (make-object vertical-panel% debug-parent-panel)) - + (define/public (hide-debug) (when (member debug-panel (send debug-parent-panel get-children)) (send debug-parent-panel change-children @@ -786,7 +942,7 @@ (unless (member debug-panel (send debug-parent-panel get-children)) (send debug-parent-panel change-children (lambda (l) (cons debug-panel l))))) - + (super-new) (define status-message @@ -798,12 +954,10 @@ (define debug-button (make-object button% ((bitmap-label-maker - (string-constant debug-tool-button-name) + (string-constant debug-tool-button-name) (build-path (collection-path "mztake" "icons") "icon-small.png")) this) (make-object vertical-pane% (get-button-panel)) - (lambda (button evt) - (send (get-current-tab) prepare-execution #t) - (super execute-callback)))) + (lambda (button evt) (execute-callback #t)))) (define pause-button (instantiate button% () @@ -828,7 +982,7 @@ [parent debug-panel] [callback (lambda (button evt) (if (send (get-current-tab) get-stack-frames) - (send (get-current-tab) resume) + (send (get-current-tab) resume) (bell)))] [enabled #f])) @@ -841,11 +995,11 @@ [callback (lambda (btn evt) (if (send (get-current-tab) get-stack-frames) (begin - (hash-table-put! (send (get-current-tab) get-breakpoints) -1 #t) - (send (get-current-tab) resume)) + (send (get-current-tab) set-single-step?! #t) + (send (get-current-tab) resume)) (bell)))] [enabled #f])) - + (define/public (get-debug-button) debug-button) (define/public (get-pause-button) pause-button) (define/public (get-resume-button) resume-button) @@ -857,9 +1011,9 @@ [label " "] [parent debug-panel] [stretchable-width #t])) - - (define/augment (on-tab-change old new) - (check-current-language-for-debugger) + + (define/augment (on-tab-change old new) + (check-current-language-for-debugger) (if (send new debug?) (let ([status (send new get-break-status)]) (if status @@ -867,14 +1021,14 @@ (send new resume-gui)) (show-debug)) (hide-debug)) - (inner (void) on-tab-change old new)) - - (define/public (check-current-language-for-debugger) + (inner (void) on-tab-change old new)) + + (define/public (check-current-language-for-debugger) (let* ([settings (send (get-definitions-text) get-next-settings)] [lang (drscheme:language-configuration:language-settings-language settings)] [visible? (and (send lang capability-value 'mztake:debug-button) - (not (debugger-does-not-work-for? - (extract-language-level settings))))]) + (not (debugger-does-not-work-for? + (extract-language-level settings))))]) (if visible? (unless (send debug-button is-shown?) (send (send debug-button get-parent) add-child debug-button)) @@ -885,9 +1039,9 @@ (lambda (_) (cons (send debug-button get-parent) (remq (send debug-button get-parent) _)))) - - ; hide debug button if it's not supported for the initial language: - (check-current-language-for-debugger))) + + ; hide debug button if it's not supported for the initial language: + (check-current-language-for-debugger))) (drscheme:language:register-capability 'mztake:debug-button (flat-contract boolean?) #t) (drscheme:get/extend:extend-definitions-text debug-definitions-text-mixin) (drscheme:get/extend:extend-interactions-text debug-interactions-text-mixin)