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
This commit is contained in:
Guillaume Marceau
parent
5780f1bad6
commit
b76f0e77be
77
collects/mztake/TAGS
Normal file
77
collects/mztake/TAGS
Normal file
|
|
@ -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
|
||||
|
|
@ -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)))))
|
||||
|
||||
|
||||
|
|
@ -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))))))))
|
||||
|
|
@ -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))))))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user