From 0b04359f47dd7fb0970c3589376df998092addfa Mon Sep 17 00:00:00 2001 From: Guillaume Marceau Date: Sun, 8 May 2005 18:32:49 +0000 Subject: [PATCH] cleaning up sine.ss svn: r183 --- .../demos/sine/sine-mztake-uncommented.ss | 34 +- collects/mztake/mztake-structs.ss | 26 +- collects/mztake/mztake.ss | 397 ++++++++---------- 3 files changed, 204 insertions(+), 253 deletions(-) diff --git a/collects/mztake/demos/sine/sine-mztake-uncommented.ss b/collects/mztake/demos/sine/sine-mztake-uncommented.ss index f9f7375b16..6436d5ba9d 100644 --- a/collects/mztake/demos/sine/sine-mztake-uncommented.ss +++ b/collects/mztake/demos/sine/sine-mztake-uncommented.ss @@ -1,25 +1,18 @@ (require (lib "animation.ss" "frtime") - (lib "list.ss" "frtime") (lib "useful-code.ss" "mztake" "private")) (require (lib "mztake.ss" "mztake")) -(define x/sinx (hold (trace "sine.ss" 5 8 (bind (x sin-x) (list x sin-x))))) +(define/bind (loc "sine.ss" 5 8) x sin-x) -(define x (first x/sinx)) -(define sin-x (second x/sinx)) - -(printf-b "x: ~a" x) -(printf-b "sin(x/20): ~a" sin-x) - - -(printf-b "largest x: ~a sin(x/20): ~a" - (largest-val-b (changes (first x/sinx))) - (largest-val-b (changes (second x/sinx)))) - -(printf-b "smallest x:~a sin(x/20):~a" - (smallest-val-b (changes (first x/sinx))) - (smallest-val-b (changes (second x/sinx)))) +(define (pick-cute-color x y) + (if (< 200 y) + (if (< 200 x) "blue" "darkblue") + (if (< 200 x) "red" "darkred"))) +(define (make-cute-circle x y) + (make-circle (make-posn x y) + 5 + (pick-cute-color x y))) (display-shapes (list* (make-line (make-posn 0 200) (make-posn 400 200) "gray") @@ -27,12 +20,7 @@ (let ([x (+ 200 x)] [sin-x (+ 200 (* 100 sin-x))]) - (history-b 50 (changes (make-circle - (make-posn x sin-x) - 5 - (if (< 200 sin-x) - (if (< 200 x) "blue" "darkblue") #| Quadrants 3 and 4 |# - (if (< 200 x) "red" "darkred")))))))) #| 1 and 2 |# + (history-b 50 (changes (make-cute-circle x sin-x)))))) -(start/resume) +(set-running! (even? seconds)) diff --git a/collects/mztake/mztake-structs.ss b/collects/mztake/mztake-structs.ss index d8c5d1ab90..da3af20f7f 100644 --- a/collects/mztake/mztake-structs.ss +++ b/collects/mztake/mztake-structs.ss @@ -2,7 +2,9 @@ (require (prefix frp: (lib "frp.ss" "frtime")) (lib "more-useful-code.ss" "mztake" "private")) - (provide (all-defined)) + (provide (all-defined-except loc make-loc) + (rename loc loc$) + (rename make-loc loc)) ; ;;;;; ; ; ; ; ; ; ; @@ -26,14 +28,21 @@ (define-struct debug-process (custodian ; If you shutdown-all it will kill the debugger process run-semaphore ; When you post to this the debuggee will continue executing - running? ; Is the program (supposed-to-be) currently running + running-e ; Is the program (supposed-to-be) currently running + run-manager ; saves behavior that actually pauses/resumes from GC + pause-requested? + resume-requested? + exited? ; FrTime cell receives #t when the target exits exceptions ; (an event stream) Exceptions thrown during the evaluation of the target - runtime ; Behavior with current runtime in milliseconds main-client ; the main client module that will be run clients ; list of all the clients attached to this process + + where ; a behavior signaling each position where we pause marks)) ; while paused, the marks at the point of the pause (else false) + (define-struct loc (modpath line col)) + ;########################################################################################################### @@ -52,17 +61,6 @@ ; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;;; ; ;;;; ;;;; ; ;;; ;;;; ; ;;;; - (define (create-empty-debug-process) - (make-debug-process (make-custodian) - null ; run-semaphore - null so we know it has never started - #f ; running? - (frp:new-cell) ; exited? - (frp:event-receiver) ; exceptions - null ; runtime - null ; main-client - empty ; clients - false)) ; marks - (define (create-empty-debug-client) (make-debug-client null ; modpath (make-hash) ; tracepoints diff --git a/collects/mztake/mztake.ss b/collects/mztake/mztake.ss index 7b331c66d7..6ca189dc1c 100644 --- a/collects/mztake/mztake.ss +++ b/collects/mztake/mztake.ss @@ -6,6 +6,8 @@ (lib "contract.ss") (lib "marks.ss" "mztake" "private") (prefix frp: (lib "frp.ss" "frtime")) + (rename (lib "frtime.ss" "frtime") frp:value-nowable? value-nowable?) + (rename (lib "frtime.ss" "frtime") frp:behaviorof behaviorof) (lib "useful-code.ss" "mztake" "private") (lib "more-useful-code.ss" "mztake" "private") ; mostly for hash- bindings "mztake-structs.ss" @@ -13,19 +15,15 @@ "annotator.ss" ) - (provide/contract [start/resume (() (debug-process?) . opt-> . void?)] - [kill (() (debug-process?) . opt-> . void?)] + (provide/contract [kill (() (debug-process?) . opt-> . void?)] [kill-all (-> void?)] [pause (() (debug-process?) . opt-> . void?)] + [resume (debug-process? . -> . void?)] + [set-running-e! (frp:event? . -> . void?)] + [set-running! (frp:value-nowable? . -> . void?)] [rename debug-process-exceptions process:exceptions (debug-process? . -> . frp:event?)] - [rename runtime/seconds - process:runtime/seconds - (debug-process? . -> . frp:behavior?)] - [rename runtime/milliseconds - process:runtime/milliseconds - (debug-process? . -> . frp:behavior?)] [rename debug-process-exited? process:exited? (debug-process? . -> . frp:behavior?)]) @@ -81,6 +79,10 @@ ; ;;;; + (define (kill process) + (unless (debug-process-exited? process) + (process:->dead process))) + (define (kill-all) (unless (empty? all-debug-processes) (for-each (lambda (p) (kill p)) all-debug-processes) @@ -163,8 +165,6 @@ ; ; ; ;;;; ;;; ;;;; ;;;; ;;;; ; ;;;; ; ; ; ;;; ;;;; - (define current-process (make-parameter (create-empty-debug-process))) - (define (find-client process modpath) (cond [(memf (lambda (c) (equal? (debug-client-modpath c) (path->string modpath))) @@ -174,28 +174,38 @@ (define (break? process client) (let ([tracepoints (and client (debug-client-tracepoints client))]) (lambda (pos) - (or (not (running-now? process)) + (or (debug-process-pause-requested? process) (and tracepoints (hash-get tracepoints (sub1 pos) (lambda () false))))))) (define (receive-result process client top-mark rest-marks) (let* ([byte-offset (sub1 (syntax-position (mark-source top-mark)))] [traces (hash-get (debug-client-tracepoints client) byte-offset (lambda () empty))] - [marks (cons top-mark (continuation-mark-set->list rest-marks debug-key))]) + [marks (cons top-mark (continuation-mark-set->list rest-marks debug-key))] + [w (map (compose syntax-local-infer-name mark-source) marks)] + [where-event ((frp:signal-thunk (debug-process-where process)) #t)]) (set-debug-process-marks! process marks) + (if (empty? traces) + + (frp:send-synchronous-event where-event w) + ; Run all traces at this trace point - (let ([to-send (map (lambda (t) - (list (trace-struct-evnt-rcvr t) - ((trace-struct-thunk t)))) - traces)]) - (unless (empty? to-send) - (frp:send-synchronous-events to-send))) + (let* ([to-send (map (lambda (t) + (list (trace-struct-evnt-rcvr t) + ((trace-struct-thunk t)))) + traces)]) + (frp:send-synchronous-events (cons (list where-event w) to-send)))) - ; Now that we processed the trace, do we want to pause ojr continue - (unless (running-now? process) - (semaphore-wait (debug-process-run-semaphore process))) + ; Now that we processed the trace, do we want to pause or continue + (when (debug-process-pause-requested? process) + (set-debug-process-pause-requested?! process false) + (let loop () + (unless (debug-process-resume-requested? process) + (semaphore-wait (debug-process-run-semaphore process)) + (loop))) + (set-debug-process-resume-requested?! process false)) (set-debug-process-marks! process false))) @@ -210,7 +220,8 @@ (receive-result process client top-mark marks) ; TODO: allow substitute value false) - (define (run* process) + (define (launch-sandbox process) + (require/sandbox+annotations (debug-process-custodian process) ;; error-display-handler : @@ -237,112 +248,90 @@ (break-after process client) (lambda (kind bound binding) (void)))]) annotated-stx)))))) - - (define (start-debug-process process) - ; initialize the semaphore + + (define (process:new->running process) (set-debug-process-run-semaphore! process (make-semaphore)) - ; set initial state of exit predicate - (frp:set-cell! (debug-process-exited? process) #f) (thread (lambda () - (thread-wait (thread (lambda () (run* process)))) - ; program terminates - (stop process) - (print-info (format "process exited: ~a" (main-client-name process)))))) - - - ; predicate - is the debugee supposed to be running now? - (define (running-now? process) - (and (not (null? (debug-process-run-semaphore process))) - (frp:value-now (debug-process-running? process)))) - + (launch-sandbox process) + (process:running->finished process)))) + (define (process:running->finished process) + (process:->dead process)) + + (define (process:->dead process) + (set! all-debug-processes (remq process all-debug-processes)) + (custodian-shutdown-all (debug-process-custodian process)) + (frp:set-cell! (debug-process-exited? process) true)) + + (define set-running-e! + (opt-lambda (e [process (current-process)]) + (resume process) + (frp:set-cell! (debug-process-running-e process) e))) + + (define set-running! + (opt-lambda (b [process (current-process)]) + (if (frp:value-now b) (resume process) (pause process)) + (frp:set-cell! (debug-process-running-e process) (frp:changes b)))) + + (define (process:running->paused process) + (set-debug-process-pause-requested?! process true)) + + (define (process:paused->running process) + (set-debug-process-resume-requested?! process true) + (semaphore-post (debug-process-run-semaphore process))) + (define (main-client-name process) (let-values ([(_ name __) (split-path (debug-client-modpath (debug-process-main-client process)))]) name)) + (define (pause process) + (when (and (debug-process-run-semaphore process) + (not (frp:value-now (debug-process-exited? process))) + (not (debug-process-pause-requested? process))) + (process:running->paused process))) - - ; Switches the running state on or off - ; (debug-process? boolean? . -> . void?) - (define set-running! - (opt-lambda (run? [process (current-process)]) - (set-debug-process-running?! process run?) - - ; start the debugger if needed - (when (null? (debug-process-run-semaphore process)) - (print-info (format "starting debugger for ~a" (main-client-name process))) - (start-debug-process process)) - - (when run? - (semaphore-post (debug-process-run-semaphore process))) - (void))) - - - (define pause - (opt-lambda ([process (current-process)]) - (print-info (format "pausing debugger for ~a" (main-client-name process))) - (set-running! #f process))) - - - (define start/resume - (opt-lambda ([process (current-process)]) - (let ([val (frp:value-now (debug-process-exited? process))]) - (when (not (null? (debug-process-run-semaphore process))) - (print-info (format "resuming debugger for ~a" (main-client-name process)))) - - ; only start the debugger once for each process - (if ((not (equal? val frp:undefined)) . and . val) - (print-info (format "Cannot restart a process once it has exited (~a). Try restarting the script." - (main-client-name process))) - (set-running! #t process))))) - - ; Kills and prints out a message stating it - (define kill - (opt-lambda ([process (current-process)]) - (print-info (format "killing debugger for ~a" (main-client-name process))) - (stop process))) - - ; Kills the debugger process immediately and permanently - (define stop - (opt-lambda ([process (current-process)]) - ; remove the process from the process list - (set! all-debug-processes (remq process all-debug-processes)) - - (set-running! #f process) - ; shutdown the custodian - (custodian-shutdown-all (debug-process-custodian process)) - ; set the exit predicate to 'exited' - (frp:set-cell! (debug-process-exited? process) #t))) - - - ; creates and initializes a debug process + (define (resume process) + (cond + [(not (debug-process-run-semaphore process)) (process:new->running process)] + [(and (not (frp:value-now (debug-process-exited? process))) + (not (debug-process-resume-requested? process))) + (process:paused->running process)])) + (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)) - (current-process p) - p)) - - - ; returns a behavior that keeps track of runtime - (define (runtime process) - (frp:hold - ((frp:changes - (frp:accum-b - ((frp:changes frp:milliseconds) - . frp:-=> . - (match-lambda [(prev sum) - (if (frp:value-now (debug-process-running? process)) - (list (frp:value-now frp:milliseconds) - (+ (- (frp:value-now frp:milliseconds) prev) sum)) - (list (frp:value-now frp:milliseconds) sum))])) - (list (frp:value-now frp:milliseconds) 0))) - . frp:==> . - cadr) ; take the second element - 0)) + + (letrec ([running-e (frp:new-cell frp:never-e)] + [run-manager (running-e . frp:==> . + (lambda (r) + (if r (resume process) (pause process))))] + [process (make-debug-process (make-custodian) + false ; run-semaphore - false so we know it has never started + running-e ; running-e + run-manager ; run-manager + false ; pause-requested? + false ; resume-requested? + (frp:new-cell false) ; exited? + (frp:event-receiver) ; exceptions + false ; main-client + empty ; clients + (frp:new-cell empty) ; where + false)]) ; marks + (set! all-debug-processes (cons process all-debug-processes)) + process)) + (define where + (frp:new-cell empty)) + + (define current-process + (let* ([proc (create-debug-process)] + [p (make-parameter proc)]) + (frp:set-cell! where (debug-process-where proc)) + (case-lambda + [() (p)] + [(new-p) (frp:set-cell! where (debug-process-where new-p)) (p new-p)]))) + + ;########################################################################################################### @@ -365,80 +354,65 @@ ; ; - #; - (define (running? process) - (script-error "client-running? is broken") - (and (running-now? process) - (not (debug-process-exited? process)))) - - #; - (define (time-per-event/milliseconds process behavior) - (frp:lift (truncate (/ (frp:value-now (debug-process-runtime process)) - (add1 (frp:value-now (count-e (frp:changes behavior)))))))) - - (define (runtime/milliseconds process) - (debug-process-runtime process)) - - (define (runtime/seconds process) - (frp:hold ((frp:changes (debug-process-runtime process)) - . frp:==> . - (lambda (t) (truncate (/ t 1000)))) - 0)) - ; Creates a debugger client ; (debug-process? require-path. -> . debug-file?) - (define (create-debug-client process filename) + (define (create-debug-client process modpath) ; throwaway namespace so the module-name-resolver doesn't load an unannotated module (parameterize ([current-namespace (make-namespace)]) - (with-handlers ([exn:fail? - (lambda (exn) - (client-error (format "Expected a module in client file: ~a" filename)))]) - - (let* ([build-module-filename ; taken from module-overview.ss - (lambda (str) - (let ([try (lambda (ext) - (let ([tst (string-append str ext)]) - (and (file-exists? tst) tst)))]) - (or (try ".ss") (try ".scm") (try "") str)))] - - [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)) - modpath))] - - [client (create-empty-debug-client)]) - (for-each (lambda (c) - (when (equal? modpath (debug-client-modpath c)) - (raise-syntax-error 'mztake:script-error:create-debug-client - (format "A client for `~a' is already defined for this process." modpath)))) - (debug-process-clients process)) + (let ([client (create-empty-debug-client)]) + (for-each (lambda (c) + (when (equal? modpath (debug-client-modpath c)) + (raise-syntax-error 'mztake:script-error:create-debug-client + (format "A client for `~a' is already defined for this process." modpath)))) + (debug-process-clients process)) - (print-debug (format "'~a' -> '~a'" filename modpath)) + (set-debug-client-modpath! client modpath) + (set-debug-client-process! client process) + (set-debug-client-line-col->pos! client (line-col->pos modpath)) + (set-debug-process-clients! process + (append (list client) (debug-process-clients process))) - (set-debug-client-modpath! client modpath) - (set-debug-client-process! client process) - (set-debug-client-line-col->pos! client (line-col->pos modpath)) - (set-debug-process-clients! process - (append (list client) (debug-process-clients process))) + ; set the main module if it has not been set + ; this implies that the first client created is always the main module + (unless (debug-process-main-client process) + (set-debug-process-main-client! process client)) - ; set the main module if it has not been set - ; this implies that the first client created is always the main module - (when (null? (debug-process-main-client process)) - (set-debug-process-main-client! process client)) - - client)))) + client))) + (define (set-main! mod-path) + (let ([client (find-client (current-process) mod-path)]) + (if client + (set-debug-process-main-client! (current-process) client) + (create-debug-client (current-process) mod-path)))) - (define (trace* modpath line col thunk) - (let* ([clients (member modpath (debug-process-clients (current-process)))] - [client (if clients - (first clients) - (create-debug-client (current-process) modpath))] + (define (hold-b b) + (frp:hold (frp:filter-e (lambda (ev) (not (frp:undefined? ev))) (frp:changes b)))) + + (define (expand-module-filename filename) + (define (build-module-filename str) ; taken from module-overview.ss + (let ([try (lambda (ext) + (let ([tst (string-append str ext)]) + (and (file-exists? tst) tst)))]) + (or (try ".ss") (try ".scm") (try "") str))) + + (let ([modpath (symbol->string ((current-module-name-resolver) filename #f #f))]) + (build-module-filename + (if (regexp-match #rx"^," modpath) + (substring modpath 1 (string-length modpath)) + modpath)))) + + (define (trace* loc thunk) + (let* ([modpath (expand-module-filename (loc-modpath loc))] + [clients (filter (lambda (c) + (equal? modpath (debug-client-modpath c))) + (debug-process-clients (current-process)))] + [client (if (empty? clients) + (create-debug-client (current-process) modpath) + (first clients))] [trace-hash (debug-client-tracepoints client)] [trace (make-trace-struct (frp:event-receiver) thunk)] - [pos ((debug-client-line-col->pos client) line col)]) + [pos ((debug-client-line-col->pos client) (loc-line loc) (loc-col loc))]) ; add the trace to the list of traces for that byte-offset (hash-put! trace-hash pos (append (hash-get trace-hash pos (lambda () '())) @@ -447,10 +421,10 @@ (define-syntax trace (syntax-rules () - [(_ client line col) - (trace* client line col (lambda () true))] - [(_ client line col body ...) - (trace* client line col (lambda () body ...))])) + [(_ loc) + (trace* loc (lambda () true))] + [(_ loc body ...) + (trace* loc (lambda () body ...))])) (define-syntax bind (syntax-rules () @@ -461,40 +435,31 @@ (debug-process-marks (current-process)))))] ...) body0 body ...)])) - ; (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) - (when (empty? binding-symbol) - (script-error (format "No symbols defined in BIND for client: `~a'" - (debug-client-modpath client)))) - - (with-handlers ([(lambda (exn) #t) - (lambda (exn) (raise-syntax-error 'mztake:script-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 - (append (hash-get trace-hash pos (lambda () '())) - (list trace))) - (trace-struct-evnt-rcvr trace)))) - - - ;(debug-file? number? number? . -> . frp:event?) - #; - (define (trace/entry client line col) - (let ([trace-hash (debug-client-tracepoints client)] - [trace (create-entry-trace)] - [pos ((debug-client-line-col->pos client) line col)]) - (hash-put! trace-hash pos - (append (hash-get trace-hash pos (lambda () '())) - (list trace))) - (trace-struct-evnt-rcvr trace))) - - - (provide trace trace* bind create-debug-process - create-debug-client + (define-syntax define/bind + (syntax-rules () + [(_ loc name ...) + (begin + (define here loc) + (define name (frp:hold (trace here (bind (name) name)))) + ...)])) + + (define (syntax-local-infer-name stx) + (or (syntax-property stx 'inferred-name) + (let ([s (syntax-source stx)]) + (and s + (let ([s (cond + [(path? s) (path->string s)] + [else s])] + [l (syntax-line stx)] + [c (syntax-column stx)]) + (if l + (string->symbol (format "~a:~a:~a" s l c)) + (let ([p (syntax-position stx)]) + (string->symbol (format "~a::~a" s p))))))))) + + (provide loc$ loc loc-modpath loc-line loc-col + trace trace* bind define/bind create-debug-process + create-debug-client where set-main! mztake-version) ;###########################################################################################################