From 8223b03b3b61672270c77ad438af02a49e322ea1 Mon Sep 17 00:00:00 2001 From: Jono Spiro Date: Fri, 30 Jul 2004 07:57:55 +0000 Subject: [PATCH] got it mostly working ... problems with require/annotations svn: r117 --- collects/mztake/debugger-model.ss | 84 ++++++++++++++++ collects/mztake/mztake-structs.ss | 2 - collects/mztake/mztake.ss | 66 ++++++------ collects/mztake/private/load-annotator.ss | 117 +++++++++++----------- 4 files changed, 177 insertions(+), 92 deletions(-) create mode 100644 collects/mztake/debugger-model.ss diff --git a/collects/mztake/debugger-model.ss b/collects/mztake/debugger-model.ss new file mode 100644 index 0000000000..cf4b5dc741 --- /dev/null +++ b/collects/mztake/debugger-model.ss @@ -0,0 +1,84 @@ +#| + (let* ([breakpoint-origin (debug-file-filename client)] + [breakpoints (hash-keys (debug-file-tracepoints client))] + [program-expander (program-expander breakpoint-origin)]) +|# + +(module debugger-model mzscheme + (require (lib "unit.ss") + (lib "mred.ss" "mred") + (lib "debugger-annotate.ss" "stepper/private") + (lib "marks.ss" "stepper/private") + (lib "list.ss") + "mztake-structs.ss" + "private/load-annotator.ss" + "private/more-useful-code.ss") + + (provide debugger-model@) + + (define (send-to-eventspace eventspace thunk) + (parameterize ([current-eventspace eventspace]) + (queue-callback thunk))) + + (define debugger-model@ + (unit + (import receive-result + process) + (export run) + + (define (run-semaphore) (debug-process-run-semaphore process)) + + (define (queue-result result) + (send-to-eventspace (debug-process-eventspace process) + (lambda () (receive-result result)))) + + (define basic-eval (current-eval)) + + (define ((break client) mark-set kind final-mark) + (let ([mark-list (continuation-mark-set->list mark-set debug-key)]) + (queue-result (make-normal-breakpoint-info (cons final-mark mark-list) client)) + (queue-result (make-breakpoint-halt)) + (semaphore-wait (run-semaphore)))) + + (define ((err-display-handler source) message exn) + (queue-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) (eq? 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))))] + + ;TODO hack + [_ (print "hack -- main-mod problem")] + [main-mod (first all-used-module-paths)]) + + (parameterize ([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-structs.ss b/collects/mztake/mztake-structs.ss index 6610197833..5c7daefa34 100644 --- a/collects/mztake/mztake-structs.ss +++ b/collects/mztake/mztake-structs.ss @@ -25,7 +25,6 @@ (variable-to-bind)) ; symbol (define-struct debug-client (modpath ; complete-path of the module - modsymbol ; symbol returned from the module-name-resolver tracepoints ; hash-table of traces line-col->pos ; memoized O(n) function to map line/col -> byte offset process)) ; parent debug-process @@ -79,7 +78,6 @@ (define (create-empty-debug-client) (make-debug-client null ; modpath - null ; modsymbol (make-hash) ; tracepoints null ; line-col->pos function null)) ; process diff --git a/collects/mztake/mztake.ss b/collects/mztake/mztake.ss index 920c48d6f6..03a26ffc10 100644 --- a/collects/mztake/mztake.ss +++ b/collects/mztake/mztake.ss @@ -131,6 +131,7 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2) (require (lib "match.ss") (lib "unit.ss") (lib "contract.ss") + (lib "stx.ss" "syntax") (lib "marks.ss" "stepper/private") (prefix frp: (lib "frp.ss" "frtime")) "private/useful-code.ss" @@ -171,7 +172,7 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2) ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ;;;;;; ; ;;;; ;;;;;; ;;;; ; ; ; ;;;; ; ; ;;;; - + ;Keeps track of all debugging processes (define all-debug-processes null) @@ -199,13 +200,9 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2) (define ((receive-result process) result) (match result ; regular breakpoint - [($ normal-breakpoint-info (top-mark rest-mark ...) kind) - (print-debug "breakpoint hit") - (void)] - #| + [($ normal-breakpoint-info (top-mark rest-mark ...) client) (let* ([byte-offset (sub1 (syntax-position (mark-source top-mark)))] - [trace-hash (debug-file-tracepoints client)] - [traces (hash-get trace-hash byte-offset)]) + [traces (hash-get (debug-client-tracepoints client) byte-offset)]) (assert (not (empty? traces)) (format "There are no traces at offset ~a, but a breakpoint is defined!~n" @@ -213,7 +210,7 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2) ; Run all traces at this breakpoint (let ([to-send (map (lambda (t) (trace->frp-event client result t)) traces)]) - (frp:send-synchronous-events to-send)))|# + (frp:send-synchronous-events to-send)))] ; now, breakpoint-halt message should be sent by the debugger model ;TODO eventually remove this from debugger-model.ss @@ -221,9 +218,7 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2) ; all errors and raises from the TARGET program will be caught here ; FrTime errors from the script have their own eventstream (frp:send-event (debug-process-exceptions process) exn) - (client-error (if (exn? exn) - (format "source: ~a | exception: ~a" source (exn-message exn)) - exn))] + (client-error (format "source: ~a | exception: ~a" source (if (exn? exn) (exn-message exn) exn)))] ;end of a statement [($ breakpoint-halt) @@ -259,7 +254,9 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2) (define (kill-all) (for-each (lambda (p) (kill p)) all-debug-processes) - (display "All debug processes have been killed.")) + (unless (empty? all-debug-processes) + (display "All debug processes have been killed.")) + (set! all-debug-processes empty)) ; wrapper for errors related to the script only @@ -356,7 +353,7 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2) (cond ; none is found [(empty? lst) - (script-error (format "No syntax found for trace at line/column ~a:~a in ~a" line col filename))] + (raise (format "No syntax found for trace at line/column ~a:~a in ~a" line col filename))] ; if first is correct line and correct column [(and (= line (caar lst)) @@ -385,19 +382,22 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2) ; ; ; ;;;; ;;; ;;;; ;;;; ;;;; ; ;;;; ; ; ; ;;; ;;;; (define (start-debug-process process) - (let* ([receive-result (receive-result process)] - ; connect to the debugger-model@ unit - [run (invoke-unit debugger-model@ receive-result process)]) + (let* ([receive-result (receive-result process)]) ; initialize the semaphore (set-debug-process-run-semaphore! process (make-semaphore)) ; set initial state of exit predicate (frp:set-cell! (debug-process-exited? process) #f) - ; run the process - (let ([evaluation-thread (thread (lambda () (run)))]) + (parameterize ([current-custodian (debug-process-custodian process)] + [current-namespace (debug-process-namespace process)]) + + ; connect to the debugger-model@ unit + (define-values/invoke-unit (run) debugger-model@ #f receive-result process) + (thread (lambda () - (thread-wait evaluation-thread) + ; run the process + (thread-wait (thread (lambda () (run)))) ; program terminates (kill process)))))) @@ -453,6 +453,7 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2) (define (create-debug-process) (let ([p (create-empty-debug-process)]) (set-debug-process-runtime! p (runtime p)) + (set! all-debug-processes (cons p all-debug-processes)) p)) @@ -527,9 +528,7 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2) (and (file-exists? tst) tst)))]) (or (try ".ss") (try ".scm") (try "") str)))] - [modsymbol ((current-module-name-resolver) filename #f #f)] - - [modpath (symbol->string modsymbol)] + [modpath (symbol->string ((current-module-name-resolver) filename #f #f))] [modpath (build-module-filename (if (regexp-match #rx"^," modpath) (substring modpath 1 (string-length modpath)) @@ -541,7 +540,6 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2) (print-debug (format "'~a' -> '~a'" filename modpath)) (set-debug-client-modpath! client modpath) - (set-debug-client-modsymbol! client modsymbol) (set-debug-client-process! client process) (set-debug-client-line-col->pos! client (line-col->pos filename)) (set-debug-process-clients! process @@ -552,15 +550,19 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2) ; (client (offset | line column) (symbol | listof symbols) -> (frp:event-receiver) ; (debug-client? number? number? (union symbol? (listof symbol?)) . -> . frp:event?) - (define (trace/bind client line col binding-symbol) - (let ([trace-hash (debug-client-tracepoints client)] - [trace (create-bind-trace binding-symbol)] - [pos ((debug-client-line-col->pos client) line col)]) - ; add the trace to the list of traces for that byte-offset - (hash-put! trace-hash pos - (cons trace - (hash-get trace-hash pos (lambda () '())))) - (trace-struct-evnt-rcvr trace))) + (define-syntax trace/bind + (syntax-rules () + [(_ client line col binding-symbol) + (with-handlers ([(lambda (exn) #t) + (lambda (exn) (raise-syntax-error 'trace/bind exn ))]) + (let ([trace-hash (debug-client-tracepoints client)] + [trace (create-bind-trace binding-symbol)] + [pos ((debug-client-line-col->pos client) line col)]) + ; add the trace to the list of traces for that byte-offset + (hash-put! trace-hash pos + (cons trace + (hash-get trace-hash pos (lambda () '())))) + (trace-struct-evnt-rcvr trace)))])) ;(debug-file? number? number? . -> . frp:event?) diff --git a/collects/mztake/private/load-annotator.ss b/collects/mztake/private/load-annotator.ss index e4282905fb..1fd29b6d4e 100644 --- a/collects/mztake/private/load-annotator.ss +++ b/collects/mztake/private/load-annotator.ss @@ -9,7 +9,8 @@ (lib "class.ss" "mzlib") (lib "mred.ss" "mred")) - (provide load-with-annotations) + (provide require/annotations + load/annotate) #|load-with-annotations : @@ -26,7 +27,7 @@ >annotator : (string? symbol? syntax? . -> . syntax?) |# - (define (load-with-annotations initial-module annotate-module? annotator) + (define (require/annotations initial-module annotate-module? annotator) (parameterize ([current-load/use-compiled (let ([ocload/use-compiled (current-load/use-compiled)]) @@ -34,71 +35,71 @@ (with-handlers ([exn:module? (lambda (exn) - (raise (format "mztake:not-a-module: file:`~a' module:`~a'" fn m)))]) + (raise (format "mztake:client:not-a-module: file:`~a' module:`~a'" fn m)))]) (cond [(annotate-module? fn m) (load/annotate annotator fn m)] [else (ocload/use-compiled fn m)]))))]) - (eval #`(require #,initial-module)))) - - (define (load/annotate annotator fn m) - (let-values ([(base _ __) (split-path fn)] - [(in-port src) (build-input-port fn)]) - (dynamic-wind - (lambda () (void)) - - (lambda () - (parameterize ([read-accept-compiled #f] - [current-load-relative-directory base]) - (unless m (raise 'module-name-not-passed-to-load/annotate)) - (with-module-reading-parameterization - (lambda () - (let* ([first (expand (read-syntax src in-port))] - [module-ized-exp (annotator fn m (check-module-form first m fn))] - [second (read in-port)]) - (unless (eof-object? second) - (raise-syntax-error - 'load/annotate - (format "expected only a `module' declaration for `~s', but found an extra expression" m) - second)) - (eval module-ized-exp)))))) - - (lambda () (close-input-port in-port))))) - - - - ; taken directly from mred.ss -- it's not exported... - (define (build-input-port filename) - (let ([p (open-input-file filename)]) - (port-count-lines! p) - (let ([p (cond [(regexp-match-peek "^WXME01[0-9][0-9] ## " p) - (let ([t (make-object text%)]) - (send t insert-file p 'standard) - (close-input-port p) - (open-input-text-editor t))] - [else p])]) - (port-count-lines! p) - (let loop () - (when (with-handlers ([not-break-exn? (lambda (x) #f)]) - (regexp-match-peek "^#!" p)) - (let lloop ([prev #f]) - (let ([c (read-char-or-special p)]) - (if (or (eof-object? c) - (eq? c #\return) - (eq? c #\newline)) - (when (eq? prev #\\) - (loop)) - (lloop c)))))) + (eval #`(require #,initial-module)))) + + (define (load/annotate annotator fn m) + (let-values ([(base _ __) (split-path fn)] + [(in-port src) (build-input-port fn)]) + (dynamic-wind + (lambda () (void)) + + (lambda () + (parameterize ([read-accept-compiled #f] + [current-load-relative-directory base]) + (unless m (raise 'module-name-not-passed-to-load/annotate)) + (with-module-reading-parameterization + (lambda () + (let* ([first (expand (read-syntax src in-port))] + [module-ized-exp (annotator fn m (check-module-form first m fn))] + [second (read in-port)]) + (unless (eof-object? second) + (raise-syntax-error + 'load/annotate + (format "expected only a `module' declaration for `~s', but found an extra expression" m) + second)) + (eval module-ized-exp)))))) + + (lambda () (close-input-port in-port))))) + + + + ; taken directly from mred.ss -- it's not exported... + (define (build-input-port filename) + (let ([p (open-input-file filename)]) + (port-count-lines! p) + (let ([p (cond [(regexp-match-peek "^WXME01[0-9][0-9] ## " p) + (let ([t (make-object text%)]) + (send t insert-file p 'standard) + (close-input-port p) + (open-input-text-editor t))] + [else p])]) + (port-count-lines! p) + (let loop () + (when (with-handlers ([not-break-exn? (lambda (x) #f)]) + (regexp-match-peek "^#!" p)) + (let lloop ([prev #f]) + (let ([c (read-char-or-special p)]) + (if (or (eof-object? c) + (eq? c #\return) + (eq? c #\newline)) + (when (eq? prev #\\) + (loop)) + (lloop c)))))) (values p filename)))) (define (test annotate-all?) - (load-with-annotations '(lib "mztake.ss" "mztake") - (lambda (fn m) - (printf "~a ~a~n" fn m) - annotate-all?) - (lambda (fn m stx) stx))) + (require/annotations '(lib "mztake.ss" "mztake") + (lambda (fn m) + (printf "~a ~a~n" fn m) + annotate-all?) + (lambda (fn m stx) stx))) ;(test #t) ; slow ;(test #f) ; fast ) \ No newline at end of file