suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added current-process and trace* and bind

Browse Source 
svn: r182
This commit is contained in:
Guillaume Marceau 2005-02-22 18:25:10 +00:00
parent bd1c915644
commit 58114baeee
6 changed files with 135 additions and 185 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/mztake/annotator.ss
View File

@ -8,7 +8,7 @@
(lib "load-annotator.ss" "mztake" "private") (lib "load-annotator.ss" "mztake" "private")
(prefix srfi: (lib "search.ss" "srfi" "1")) (prefix srfi: (lib "search.ss" "srfi" "1"))
) )
(provide annotate-stx annotate-for-single-stepping bindings) (provide annotate-stx annotate-for-single-stepping)
(define (arglist-bindings arglist-stx) (define (arglist-bindings arglist-stx)
(syntax-case arglist-stx () (syntax-case arglist-stx ()
@ -27,6 +27,7 @@
;; Returns a list of pairs `(,variable-name-stx ,variable-value). Each ;; 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 ;; item in the list is a shadowed instance of a variable with the given
;; name, with the first item being the one in scope. ;; name, with the first item being the one in scope.
#;
(define (bindings top-mark marks sym) (define (bindings top-mark marks sym)
(let ([mark-list (cons top-mark (continuation-mark-set->list marks debug-key))]) (let ([mark-list (cons top-mark (continuation-mark-set->list marks debug-key))])
(map (lambda (binding) (list (mark-binding-binding binding) (map (lambda (binding) (list (mark-binding-binding binding)

15
collects/mztake/demos/sine/sine-mztake-uncommented.ss
View File

@ -1,16 +1,13 @@
(require (lib "animation.ss" "frtime")) (require (lib "animation.ss" "frtime")
(require (lib "mztake-syntax.ss" "mztake")) (lib "list.ss" "frtime")
(lib "useful-code.ss" "mztake" "private"))
(define-mztake-process p ("sine.ss" [x/sinx-trace 5 8 bind '(x sin-x)])) (require (lib "mztake.ss" "mztake"))
(define x/sinx (hold x/sinx-trace))
(define x/sinx (hold (trace "sine.ss" 5 8 (bind (x sin-x) (list x sin-x)))))
(define x (first x/sinx)) (define x (first x/sinx))
(define sin-x (second x/sinx)) (define sin-x (second x/sinx))
(printf-b "x: ~a" x) (printf-b "x: ~a" x)
(printf-b "sin(x/20): ~a" sin-x) (printf-b "sin(x/20): ~a" sin-x)
@ -37,5 +34,5 @@
(if (< 200 x) "blue" "darkblue") #| Quadrants 3 and 4 |# (if (< 200 x) "blue" "darkblue") #| Quadrants 3 and 4 |#
(if (< 200 x) "red" "darkred")))))))) #| 1 and 2 |# (if (< 200 x) "red" "darkred")))))))) #| 1 and 2 |#
(start/resume)
(start/resume p)

20
collects/mztake/mztake-structs.ss
View File

@ -17,11 +17,7 @@
; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;
; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;; ; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;;
(define-struct trace-struct (evnt-rcvr)) ; frp:event-receiver (define-struct trace-struct (evnt-rcvr thunk)) ; frp:event-receiver
(define-struct (entry-trace trace-struct) ())
(define-struct (bind-trace trace-struct)
(variable-to-bind)) ; symbol
(define-struct debug-client (modpath ; complete-path of the module (define-struct debug-client (modpath ; complete-path of the module
tracepoints ; hash-table of traces tracepoints ; hash-table of traces
@ -35,7 +31,8 @@
exceptions ; (an event stream) Exceptions thrown during the evaluation of the target exceptions ; (an event stream) Exceptions thrown during the evaluation of the target
runtime ; Behavior with current runtime in milliseconds runtime ; Behavior with current runtime in milliseconds
main-client ; the main client module that will be run main-client ; the main client module that will be run
clients)) ; list of all the clients attached to this process clients ; list of all the clients attached to this process
marks)) ; while paused, the marks at the point of the pause (else false)
;########################################################################################################### ;###########################################################################################################
@ -55,14 +52,6 @@
; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ;; ; ; ; ; ; ;
; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;;; ; ;;;; ;;;; ; ;;; ;;;; ; ;;;; ; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;;; ; ;;;; ;;;; ; ;;; ;;;; ; ;;;;
; Creates a trace that binds to the value of a variable in scope
(define (create-bind-trace sym-to-bind) ; ((union (listof symbol?) symbol?) . -> . trace?)
(make-bind-trace (frp:event-receiver) sym-to-bind))
; Creates a trace that simply alerts that it was hit
(define (create-entry-trace) ; (void? . -> . trace?)
(make-entry-trace (frp:event-receiver)))
(define (create-empty-debug-process) (define (create-empty-debug-process)
(make-debug-process (make-custodian) (make-debug-process (make-custodian)
null ; run-semaphore - null so we know it has never started null ; run-semaphore - null so we know it has never started
@ -71,7 +60,8 @@
(frp:event-receiver) ; exceptions (frp:event-receiver) ; exceptions
null ; runtime null ; runtime
null ; main-client null ; main-client
empty)) ; clients empty ; clients
false)) ; marks
(define (create-empty-debug-client) (define (create-empty-debug-client)
(make-debug-client null ; modpath (make-debug-client null ; modpath

39
collects/mztake/mztake-syntax.ss
View File

@ -1,39 +0,0 @@
#|
(mztake-process p ("sine.ss" [sin/x 5 8 bind '(sin-x x)]
[foo 10 20 bind '(sin-x x)])
("sine-extra.ss"))
(define sin/x (hold sin/x))
(define x (+ 200 (second sin/x)))
(print-b "x:" x)
*** translates to ***
(define p (create-debug-process))
(define-values (sin/x foo ...)(
(let ([tmp (create-debug-client p "sine.ss")])
(values (create-trace tmp 5 8 'bind '(sin-x x))))
...
|#
(module mztake-syntax (lib "frtime-big.ss" "frtime")
(require (lib "mztake.ss" "mztake")
(lib "useful-code.ss" "mztake" "private"))
(define-syntax define-mztake-process
(syntax-rules (define-mztake-process)
[(define-mztake-process proc-id (client (trace line col cmd . args) ...) ...)
(begin
(define proc-id (create-debug-process))
(begin
(define-values (trace ...)
(let ([tmp (create-debug-client proc-id 'client)])
(values
(create-trace tmp line col 'cmd . args)
...))) ...))]))
(provide define-mztake-process
(all-from (lib "frtime-big.ss" "frtime"))
(all-from (lib "mztake.ss" "mztake"))
(all-from (lib "useful-code.ss" "mztake" "private"))))

242
collects/mztake/mztake.ss
View File

@ -13,10 +13,10 @@
"annotator.ss" "annotator.ss"
) )
(provide/contract [start/resume (debug-process? . -> . void?)] (provide/contract [start/resume (() (debug-process?) . opt-> . void?)]
[kill (debug-process? . -> . void?)] [kill (() (debug-process?) . opt-> . void?)]
[kill-all (-> void?)] [kill-all (-> void?)]
[pause (debug-process? . -> . void?)] [pause (() (debug-process?) . opt-> . void?)]
[rename debug-process-exceptions [rename debug-process-exceptions
process:exceptions process:exceptions
(debug-process? . -> . frp:event?)] (debug-process? . -> . frp:event?)]
@ -107,43 +107,8 @@
(display (format "mztake: ~a~n---~n" str))) (display (format "mztake: ~a~n---~n" str)))
(define create-trace ;; returns a memoized function that takes (line column) -> position
(case-lambda ;; line-col->pos : (debug-file? . -> . (number? number? . -> . (union void? number?)))
[(client line col type args)
(case type
['bind (trace/bind client line col args)]
['entry (trace/entry client line col)]
[else (script-error (format "Invalid trace type: `~a' in client: `~a'"
(symbol->string type)
(debug-client-modpath client)))])]
[(client line col type)
(create-trace client line col type null)]))
; takes a single trace, looks up what it needs to do, and returns an frp-event to publish
(define (trace->frp-event client top-mark marks trace)
(match trace
[($ entry-trace evnt-rcvr)
(list evnt-rcvr #t)]
[($ bind-trace evnt-rcvr variable-to-bind)
(let* ([vars (if (list? variable-to-bind) variable-to-bind
(list variable-to-bind))]
[values (map
(lambda (var)
(let ([val (bindings top-mark marks var)])
(if (empty? val)
(script-error
(format "Variable not found at the syntax location for the BIND: `~a'" var))
(cadar (bindings top-mark marks var)))))
vars)])
(list evnt-rcvr
(if (list? variable-to-bind) values
(first values))))]))
; returns a memoized function that takes (line column) -> position
; line-col->pos : (debug-file? . -> . (number? number? . -> . (union void? number?)))
(define (line-col->pos filename) (define (line-col->pos filename)
; produces a nested list of (line column offset) for all addressable syntax ; produces a nested list of (line column offset) for all addressable syntax
(define (unwrap-syntax stx) (define (unwrap-syntax stx)
@ -198,41 +163,41 @@
; ; ; ;;;; ;;; ;;;; ;;;; ;;;; ; ;;;; ; ; ; ;;; ;;;; ; ; ; ;;;; ;;; ;;;; ;;;; ;;;; ; ;;;; ; ; ; ;;; ;;;;
(define current-process (make-parameter (create-empty-debug-process)))
(define (find-client process modpath) (define (find-client process modpath)
(begin0/rtn (cond
(cond [(memf (lambda (c) (equal? (debug-client-modpath c) (path->string modpath)))
[(memf (lambda (c) (equal? (debug-client-modpath c) (path->string modpath))) (debug-process-clients process)) => first]
(debug-process-clients process)) => first] [else false]))
[else false])
(printf "find-client ~s ~s : ~s~n" (map debug-client-modpath (debug-process-clients process)) modpath rtn)))
(define (break? process client) (define (break? process client)
(printf "break? ~a ~a~n" client (debug-client-tracepoints client))
(let ([tracepoints (and client (debug-client-tracepoints client))]) (let ([tracepoints (and client (debug-client-tracepoints client))])
(if tracepoints (lambda (pos)
(lambda (pos) (or (not (running-now? process))
(begin0/rtn (and tracepoints
(hash-get tracepoints (sub1 pos) (lambda () false)) (hash-get tracepoints (sub1 pos) (lambda () false)))))))
(printf "break? ~a~n" rtn)))
(lambda (pos) false))))
(define (receive-result process client top-mark marks) (define (receive-result process client top-mark rest-marks)
(printf "receive-result~n")
(let* ([byte-offset (sub1 (syntax-position (mark-source top-mark)))] (let* ([byte-offset (sub1 (syntax-position (mark-source top-mark)))]
[traces (hash-get (debug-client-tracepoints client) byte-offset)]) [traces (hash-get (debug-client-tracepoints client) byte-offset (lambda () empty))]
[marks (cons top-mark (continuation-mark-set->list rest-marks debug-key))])
(assert (not (empty? traces))
(format "There are no traces at offset ~a, but a trace point is defined!~n"
(number->string byte-offset)))
(set-debug-process-marks! process marks)
; Run all traces at this trace point ; Run all traces at this trace point
(let ([to-send (map (lambda (t) (trace->frp-event client top-mark marks t)) traces)]) (let ([to-send (map (lambda (t)
(printf "frp:send-synchronous-events ~a~n" to-send) (list (trace-struct-evnt-rcvr t)
(frp:send-synchronous-events to-send)) ((trace-struct-thunk t))))
traces)])
(unless (empty? to-send)
(frp:send-synchronous-events to-send)))
; Now that we processed the trace, do we want to pause ojr continue ; Now that we processed the trace, do we want to pause ojr continue
(unless (running-now? process) (unless (running-now? process)
(semaphore-wait (debug-process-run-semaphore process))))) (semaphore-wait (debug-process-run-semaphore process)))
(set-debug-process-marks! process false)))
@ -256,12 +221,8 @@
`(file ,(debug-client-modpath (debug-process-main-client process))) `(file ,(debug-client-modpath (debug-process-main-client process)))
;; annotate-module? ;; annotate-module?
(lambda (filename module-name) (lambda (filename module-name)
(begin0/rtn
(memf (lambda (c) (equal? (debug-client-modpath c) (path->string filename)));; TODO: harmonize path & string (memf (lambda (c) (equal? (debug-client-modpath c) (path->string filename)));; TODO: harmonize path & string
(debug-process-clients process)) (debug-process-clients process)))
(printf "annotate-module? ~s ~s ~s : ~s~n"
(map debug-client-modpath (debug-process-clients process))
filename module-name rtn)))
;; annotator ;; annotator
(lambda (stx) (lambda (stx)
(let ([client (and (syntax-source stx) (let ([client (and (syntax-source stx)
@ -301,52 +262,59 @@
(split-path (debug-client-modpath (debug-process-main-client process)))]) (split-path (debug-client-modpath (debug-process-main-client process)))])
name)) name))
; Switches the running state on or off ; Switches the running state on or off
; (debug-process? boolean? . -> . void?) ; (debug-process? boolean? . -> . void?)
(define (set-running! process run?) (define set-running!
(set-debug-process-running?! process run?) (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 process)
(print-info (format "pausing debugger for ~a" (main-client-name process)))
(set-running! process #f))
(define (start/resume 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 ; start the debugger if needed
(if ((not (equal? val frp:undefined)) . and . val) (when (null? (debug-process-run-semaphore process))
(print-info (format "Cannot restart a process once it has exited (~a). Try restarting the script." (print-info (format "starting debugger for ~a" (main-client-name process)))
(main-client-name process))) (start-debug-process process))
(set-running! process #t))))
(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 ; Kills and prints out a message stating it
(define (kill process) (define kill
(print-info (format "killing debugger for ~a" (main-client-name process))) (opt-lambda ([process (current-process)])
(stop process)) (print-info (format "killing debugger for ~a" (main-client-name process)))
(stop process)))
; Kills the debugger process immediately and permanently ; Kills the debugger process immediately and permanently
(define (stop process) (define stop
; remove the process from the process list (opt-lambda ([process (current-process)])
(set! all-debug-processes (remq process all-debug-processes)) ; remove the process from the process list
(set! all-debug-processes (remq process all-debug-processes))
(set-running! process #f) (set-running! #f process)
; shutdown the custodian ; shutdown the custodian
(custodian-shutdown-all (debug-process-custodian process)) (custodian-shutdown-all (debug-process-custodian process))
; set the exit predicate to 'exited' ; set the exit predicate to 'exited'
(frp:set-cell! (debug-process-exited? process) #t)) (frp:set-cell! (debug-process-exited? process) #t)))
; creates and initializes a debug process ; creates and initializes a debug process
@ -354,6 +322,7 @@
(let ([p (create-empty-debug-process)]) (let ([p (create-empty-debug-process)])
(set-debug-process-runtime! p (runtime p)) (set-debug-process-runtime! p (runtime p))
(set! all-debug-processes (cons p all-debug-processes)) (set! all-debug-processes (cons p all-debug-processes))
(current-process p)
p)) p))
@ -396,14 +365,16 @@
; ; ; ;
#;(define (running? process) #;
(script-error "client-running? is broken") (define (running? process)
(and (running-now? process) (script-error "client-running? is broken")
(not (debug-process-exited? process)))) (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)) (define (time-per-event/milliseconds process behavior)
(add1 (frp:value-now (count-e (frp:changes behavior)))))))) (frp:lift (truncate (/ (frp:value-now (debug-process-runtime process))
(add1 (frp:value-now (count-e (frp:changes behavior))))))))
(define (runtime/milliseconds process) (define (runtime/milliseconds process)
(debug-process-runtime process)) (debug-process-runtime process))
@ -457,12 +428,43 @@
(when (null? (debug-process-main-client process)) (when (null? (debug-process-main-client process))
(set-debug-process-main-client! process client)) (set-debug-process-main-client! process client))
client)))) client))))
(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))]
[trace-hash (debug-client-tracepoints client)]
[trace (make-trace-struct (frp:event-receiver) thunk)]
[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)))
(define-syntax trace
(syntax-rules ()
[(_ client line col)
(trace* client line col (lambda () true))]
[(_ client line col body ...)
(trace* client line col (lambda () body ...))]))
(define-syntax bind
(syntax-rules ()
[(_ (name ...) body0 body ...)
(let ([name (mark-binding-value
(first (lookup-all-bindings
(lambda (id) (eq? (syntax-e id) 'name))
(debug-process-marks (current-process)))))] ...)
body0 body ...)]))
; (client (offset | line column) (symbol | listof symbols) -> (frp:event-receiver) ; (client (offset | line column) (symbol | listof symbols) -> (frp:event-receiver)
; (debug-client? number? number? (union symbol? (listof symbol?)) . -> . frp:event?) ; (debug-client? number? number? (union symbol? (listof symbol?)) . -> . frp:event?)
(define (trace/bind client line col binding-symbol) #;
(define (trace/bind client line col binding-symbol)
(when (empty? binding-symbol) (when (empty? binding-symbol)
(script-error (format "No symbols defined in BIND for client: `~a'" (script-error (format "No symbols defined in BIND for client: `~a'"
(debug-client-modpath client)))) (debug-client-modpath client))))
@ -480,6 +482,7 @@
;(debug-file? number? number? . -> . frp:event?) ;(debug-file? number? number? . -> . frp:event?)
#;
(define (trace/entry client line col) (define (trace/entry client line col)
(let ([trace-hash (debug-client-tracepoints client)] (let ([trace-hash (debug-client-tracepoints client)]
[trace (create-entry-trace)] [trace (create-entry-trace)]
@ -490,8 +493,7 @@
(trace-struct-evnt-rcvr trace))) (trace-struct-evnt-rcvr trace)))
(provide create-trace (provide trace trace* bind create-debug-process
create-debug-process
create-debug-client create-debug-client
mztake-version) mztake-version)

1
collects/mztake/private/load-annotator.ss
View File

@ -26,7 +26,6 @@
|# |#
(define (require/sandbox+annotations custodian err-display-handler initial-module annotate-module? annotator) (define (require/sandbox+annotations custodian err-display-handler initial-module annotate-module? annotator)
(printf "require/sandbox+annotations ~a~n" initial-module)
(parameterize ([current-custodian custodian] (parameterize ([current-custodian custodian]
[current-namespace (make-namespace-with-mred)] [current-namespace (make-namespace-with-mred)]
[error-display-handler err-display-handler]) [error-display-handler err-display-handler])