From b76f0e77bef065bce2e96190f4980cf5f472ecdc Mon Sep 17 00:00:00 2001 From: Guillaume Marceau Date: Tue, 18 Jan 2005 20:01:01 +0000 Subject: [PATCH] Factored out the mztake parts from the annotator. The annotator takes lists of locations to annotate intead of taking a process and some clients. svn: r179 --- collects/mztake/TAGS | 77 ++++++++++++++++++ collects/mztake/debugger-annotate.ss | 87 +++++++++++++++++---- collects/mztake/debugger-model.ss | 67 ---------------- collects/mztake/mztake.ss | 48 ++++++------ collects/mztake/private/more-useful-code.ss | 2 +- 5 files changed, 172 insertions(+), 109 deletions(-) create mode 100644 collects/mztake/TAGS delete mode 100644 collects/mztake/debugger-model.ss diff --git a/collects/mztake/TAGS b/collects/mztake/TAGS new file mode 100644 index 0000000000..172d82cc63 --- /dev/null +++ b/collects/mztake/TAGS @@ -0,0 +1,77 @@ + +debugger-annotate.ss,91 + (define (arglist-bindingsarglist-bindings10,204 + (cons #'var (arannotate20,430 + +debugger-model.ss,46 + (define debugger-moddebugger-model@12,332 + +debugger-tool.ss,0 + +info.ss,128 + (define namename2,41 + (define toolstools3,69 + (define tool-namestool-names4,111 + (define tool-iconstool-icons5,155 + +mztake-structs.ss,2742 + (define-struct tracestruct:trace-struct20,825 + (define-struct tracemake-trace-struct20,825 + (define-struct tracetrace-struct?20,825 + (define-struct tracetrace-struct-evnt-rcvr20,825 + (define-struct traceset-trace-struct-evnt-rcvr!20,825 + (define-struct trace-structtrace-struct20,825 + + (define-struct (struct:break-trace22,900 + + (define-struct (make-break-trace22,900 + + (define-struct (break-trace?22,900 + + (define-struct (break-trace22,900 + (define-struct (breastruct:bind-trace23,904 + (define-struct (breamake-bind-trace23,904 + (define-struct (breabind-trace?23,904 + (define-struct (breabind-trace-variable-to-bind23,904 + (define-struct (breaset-bind-trace-variable-to-bind!23,904 + (define-struct (breabind-trace23,904 + (varistruct:debug-client26,997 + (varimake-debug-client26,997 + (varidebug-client?26,997 + (varidebug-client-modpath26,997 + (variset-debug-client-modpath!26,997 + (varidebug-client-tracepoints26,997 + (variset-debug-client-tracepoints!26,997 + (varidebug-client-line-col->pos26,997 + (variset-debug-client-line-col->pos!26,997 + (varidebug-client-process26,997 + (variset-debug-client-process!26,997 + (varidebug-client26,997 + struct:debug-process31,1313 + make-debug-process31,1313 + debug-process?31,1313 + debug-process-custodian31,1313 + set-debug-process-custodian!31,1313 + debug-process-run-semaphore31,1313 + set-debug-process-run-semaphore!31,1313 + debug-process-running?31,1313 + set-debug-process-running?!31,1313 + debug-process-exited?31,1313 + set-debug-process-exited?!31,1313 + debug-process-exceptions31,1313 + set-debug-process-exceptions!31,1313 + debug-process-runtime31,1313 + set-debug-process-runtime!31,1313 + debug-process-main-client31,1313 + set-debug-process-main-client!31,1313 + debug-process-clients31,1313 + set-debug-process-clients!31,1313 + debug-process31,1313 + ; Creates a trace thcreate-bind-trace59,3677 + ; Creates a trace thcreate-break-trace63,3900 + (define (create-breacreate-empty-debug-process66,3952 + create-empty-debug-client76,4469 + +mztake-syntax.ss,0 + +mztake.ss,0 diff --git a/collects/mztake/debugger-annotate.ss b/collects/mztake/debugger-annotate.ss index 0fa9b0aa6d..d553626abf 100644 --- a/collects/mztake/debugger-annotate.ss +++ b/collects/mztake/debugger-annotate.ss @@ -1,12 +1,58 @@ (module debugger-annotate mzscheme (require (prefix kernel: (lib "kerncase.ss" "syntax")) - (lib "marks.ss" "mztake" "private")) + (lib "marks.ss" "mztake" "private") + (lib "mred.ss" "mred") + (lib "load-annotator.ss" "mztake" "private") + (lib "more-useful-code.ss" "mztake" "private") + (lib "list.ss")) -;; (define count 0) - - (provide annotate) + (provide annotate-stx + run/incremental-annotation + bindings) + ;; TARGETS is a list of pairs: + ;; `(,module-long-filename (,character-offset ...)) + + (define (run/incremental-annotation main-module custodian targets receive-result) + + (define ((break target) mark-set kind final-mark) + (let ([mark-list (continuation-mark-set->list mark-set debug-key)]) + (receive-result (make-normal-breakpoint-info (cons final-mark mark-list) target)))) + + (define ((err-display-handler source) message exn) + (thread (lambda () (receive-result (make-error-breakpoint-info (list source exn)))))) + + (define (annotate-module-with-error-handler stx err-hndlr) + (syntax-case stx (module #%plain-module-begin) + [(module name req (#%plain-module-begin body ...)) + #`(module name req (#%plain-module-begin + (error-display-handler #,err-hndlr) + body ...))])) + + (define (path->target path) + (first (filter (lambda (c) (equal? (first c) path)) + targets))) + + (let* ([all-used-module-paths (map first targets)] + + [annotate-module? (lambda (fn m) + (memf (lambda (sym) (equal? sym fn)) + all-used-module-paths))] + + [annotator (lambda (fn m stx) + ;;(printf "annotating: ~a~n~n" fn) + (let* ([target (path->target fn)] + [breakpoints (second target)] + [stx (annotate-stx (expand stx) (list fn breakpoints) (break target))]) + ;; add an error handler so anything that goes wrong points to the correct module + (annotate-module-with-error-handler stx (err-display-handler fn))))]) + + (parameterize ([current-custodian custodian] + [current-namespace (make-namespace-with-mred)] + [error-display-handler (err-display-handler (format "Loading module ~a..." main-module))]) + (require/annotations `(file ,main-module) annotate-module? annotator)))) + (define (arglist-bindings arglist-stx) (syntax-case arglist-stx () [var @@ -17,7 +63,12 @@ [(var . others) (cons #'var (arglist-bindings #'others))])) - (define (annotate stx breakpoints breakpoint-origin break) + (define (annotate-break? expr targets) + (and (eq? (syntax-source expr) (first targets)) + (memq (- (syntax-position expr) 1) ; syntax positions start at one. + (second targets)))) + + (define (annotate-stx stx targets break-fn) (define (top-level-annotate stx) (kernel:kernel-syntax-case stx #f @@ -89,7 +140,7 @@ (define (break-wrap debug-info annotated) #`(begin - (#,break (current-continuation-marks) 'debugger-break #,debug-info) + (#,break-fn (current-continuation-marks) 'debugger-break #,debug-info) #,annotated)) (define annotated @@ -140,7 +191,6 @@ [(quote-syntax _) expr] - ;; FIXME: we have to think harder about this [(with-continuation-mark key mark body) (quasisyntax/loc expr (with-continuation-mark key #,(annotate #`mark bound-vars #f) @@ -162,18 +212,21 @@ [else (error 'expr-syntax-object-iterator "unknown expr: ~a" (syntax-object->datum expr))])) -;; (set! count (+ count 1)) -;; (if (= (modulo count 100) 0) -;; (fprintf (current-error-port) "syntax-source: ~v\nsyntax-position: ~v\n" (syntax-source expr) (syntax-position expr))) - - - (if (and (eq? (syntax-source expr) breakpoint-origin) - (memq (- (syntax-position expr) 1) ; syntax positions start at one. - breakpoints)) + (if (annotate-break? expr targets) (break-wrap (make-debug-info expr bound-vars bound-vars 'at-break #f) annotated) annotated)) - (top-level-annotate stx))) + (top-level-annotate stx)) + + ;; Retreives the binding of a variable from a normal-breakpoint-info. + ;; Returns a list of pairs `(,variable-name-stx ,variable-value). Each + ;; item in the list is a shadowed instance of a variable with the given + ;; name, with the first item being the one in scope. + (define (bindings event sym) + (let ([mark-list (normal-breakpoint-info-mark-list event)]) + (map (lambda (binding) (list (mark-binding-binding binding) + (mark-binding-value binding))) + (lookup-all-bindings (lambda (id) (eq? (syntax-e id) sym)) + mark-list))))) - \ No newline at end of file diff --git a/collects/mztake/debugger-model.ss b/collects/mztake/debugger-model.ss deleted file mode 100644 index aa2339ad3a..0000000000 --- a/collects/mztake/debugger-model.ss +++ /dev/null @@ -1,67 +0,0 @@ -(module debugger-model mzscheme - (require (lib "unit.ss") - (lib "mred.ss" "mred") - (lib "marks.ss" "mztake" "private") - "debugger-annotate.ss" - "mztake-structs.ss" - (lib "load-annotator.ss" "mztake" "private") - (lib "more-useful-code.ss" "mztake" "private")) - - (provide debugger-model@) - - (define debugger-model@ - (unit - (import receive-result - process) - (export run) - - (define run-semaphore (debug-process-run-semaphore process)) - - (define ((break client) mark-set kind final-mark) - (let ([mark-list (continuation-mark-set->list mark-set debug-key)]) - (receive-result (make-normal-breakpoint-info (cons final-mark mark-list) client)) - (semaphore-wait run-semaphore))) - - - (define ((err-display-handler source) message exn) - (thread (lambda () (receive-result (make-error-breakpoint-info (list source exn)))))) - - - (define (annotate-module-with-error-handler stx err-hndlr) - (syntax-case stx (module #%plain-module-begin) - [(module name req (#%plain-module-begin body ...)) - #`(module name req (#%plain-module-begin - (error-display-handler #,err-hndlr) - body ...))])) - - - ; Return run functions - (define (run) - (parameterize ([error-display-handler (err-display-handler "Trying to load client code...")]) - (let* ([clients (debug-process-clients process)] - - [all-used-module-paths (map (lambda (c) (debug-client-modpath c)) - clients)] - - [path->client (lambda (path) - (car (filter (lambda (c) (equal? (debug-client-modpath c) path)) - clients)))] - - [annotate-module? (lambda (fn m) - (memf (lambda (sym) (equal? sym fn)) - all-used-module-paths))] - - [annotator (lambda (fn m stx) - ;(printf "annotating: ~a~n~n" fn) - (let* ([client (path->client fn)] - [breakpoints (hash-keys (debug-client-tracepoints client))] - [stx (annotate (expand stx) breakpoints fn (break client))]) - ; add an error handler so anything that goes wrong points to the correct module - (annotate-module-with-error-handler stx (err-display-handler fn))))] - - [main-mod (debug-client-modpath (debug-process-main-client process))]) - - (parameterize ([current-custodian (debug-process-custodian process)] - [current-namespace (make-namespace-with-mred)] - [error-display-handler (err-display-handler (format "Loading module ~a..." main-mod))]) - (require/annotations `(file ,main-mod) annotate-module? annotator)))))))) \ No newline at end of file diff --git a/collects/mztake/mztake.ss b/collects/mztake/mztake.ss index ae8e17d4b5..13ca20be47 100644 --- a/collects/mztake/mztake.ss +++ b/collects/mztake/mztake.ss @@ -117,14 +117,13 @@ TESTING/CAPABILITIES------------------------------------------------------------ |# (require (lib "match.ss") - (lib "unit.ss") (lib "contract.ss") (lib "marks.ss" "mztake" "private") ; TODO local private copy until stepper release (prefix frp: (lib "frp.ss" "frtime")) (lib "useful-code.ss" "mztake" "private") (lib "more-useful-code.ss" "mztake" "private") ; mostly for hash- bindings "mztake-structs.ss" - "debugger-model.ss") + "debugger-annotate.ss") (provide/contract [start/resume (debug-process? . -> . void?)] [kill (debug-process? . -> . void?)] @@ -188,19 +187,27 @@ TESTING/CAPABILITIES------------------------------------------------------------ ; ;; ; ; ;; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;;;;; ;;;; ; ; ; ;;;;;; ;;;; ; ;;; ; ; ;;;; ; + + (define (find-client process modpath) + (first + (filter (lambda (c) (equal? modpath (debug-client-modpath c))) + (debug-process-clients process)))) ; Callback for when a breakpoint (tracepoint) is hit by the model ; ((client) breakpoint-struct) -> () (define ((receive-result process) result) ; Before we process the trace, see if we are supposed to pause + ;; TODO : this condition variable has a race condition (unless (running-now? process) (semaphore-wait (debug-process-run-semaphore process))) (match result ; regular breakpoint - [($ normal-breakpoint-info (top-mark rest-mark ...) client) + [($ normal-breakpoint-info (top-mark rest-mark ...) target) (let* ([byte-offset (sub1 (syntax-position (mark-source top-mark)))] + ;; TODO : find-client is slow and awkward + [client (find-client process (first target))] [traces (hash-get (debug-client-tracepoints client) byte-offset)]) (assert (not (empty? traces)) @@ -212,8 +219,8 @@ TESTING/CAPABILITIES------------------------------------------------------------ (frp:send-synchronous-events to-send)) ; Now that we processed the trace, do we want to pause or continue - (when (running-now? process) - (semaphore-post (debug-process-run-semaphore process))))] + (unless (running-now? process) + (semaphore-wait (debug-process-run-semaphore process))))] [($ error-breakpoint-info (source exn)) ; all errors and raises from the TARGET program will be caught here @@ -270,19 +277,6 @@ TESTING/CAPABILITIES------------------------------------------------------------ (display (format "mztake: ~a~n---~n" str))) - ; retreives the binding of a variable from a bind trace event - (define (binding event sym) - (define (do-n-times fn n arg) - (foldl (lambda (x arg) (fn arg)) arg (build-list n (lambda (x) x)))) - - (let ([mark-list (normal-breakpoint-info-mark-list event)] - [current-frame-num 0]) - (map (lambda (binding) (list (mark-binding-binding binding) - (mark-binding-value binding))) - (lookup-all-bindings (lambda (id) (eq? (syntax-e id) sym)) - (do-n-times cdr current-frame-num mark-list))))) - - (define create-trace (case-lambda [(client line col type args) @@ -308,11 +302,11 @@ TESTING/CAPABILITIES------------------------------------------------------------ (list variable-to-bind))] [values (map (lambda (var) - (let ([val (binding event var)]) + (let ([val (bindings event var)]) (if (empty? val) (script-error (format "Variable not found at the syntax location for the BIND: `~a'" var)) - (cadar (binding event var))))) + (cadar (bindings event var))))) vars)]) (list evnt-rcvr (if (list? variable-to-bind) values @@ -372,6 +366,15 @@ TESTING/CAPABILITIES------------------------------------------------------------ ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ;;;; ;;; ;;;; ;;;; ;;;; ; ;;;; ; ; ; ;;; ;;;; + + (define (run* process receive-result) + (run/incremental-annotation + (debug-client-modpath (debug-process-main-client process)) + (debug-process-custodian process) + (map (lambda (c) (list (debug-client-modpath c) + (hash-keys (debug-client-tracepoints c)))) + (debug-process-clients process)) + receive-result)) (define (start-debug-process receive-result process) ; initialize the semaphore @@ -380,10 +383,7 @@ TESTING/CAPABILITIES------------------------------------------------------------ (frp:set-cell! (debug-process-exited? process) #f) (thread (lambda () - ; connect to the debugger-model@ unit - (define-values/invoke-unit (run) debugger-model@ #f receive-result process) - ; run the process - (thread-wait (thread (lambda () (run)))) + (thread-wait (thread (lambda () (run* process receive-result)))) ; program terminates (stop process) (print-info (format "process exited normally: ~a" (main-client-name process)))))) diff --git a/collects/mztake/private/more-useful-code.ss b/collects/mztake/private/more-useful-code.ss index 26ac413dd7..df90ad45aa 100644 --- a/collects/mztake/private/more-useful-code.ss +++ b/collects/mztake/private/more-useful-code.ss @@ -279,7 +279,7 @@ (define (hash-values hash) (hash-fold hash empty (lambda (key val acc) (cons val acc)))) (define (hash-pairs hash) - (hash-fold hash empty (lambda (key val acc) (cons (cons key val) acc)))) + (hash-fold hash empty (lambda (key val acc) (cons (list key val) acc)))) (define (hash-add-all! to-hash from-hash) ;; // memcpy-style argument order (hash-for-each from-hash (lambda (key val) (hash-put! to-hash key val))))