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

svn: r116

Browse Source
This commit is contained in:
Jono Spiro 2004-07-30 03:47:23 +00:00
parent a9923f1b16
commit fc52c29f5d
2 changed files with 385 additions and 356 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
collects/mztake/mztake-structs.ss Normal file
View File

@ -0,0 +1,88 @@
(module mztake-structs mzscheme
(require (lib "mred.ss" "mred")
(prefix frp: (lib "frp.ss" "frtime"))
"private/more-useful-code.ss")
(provide (all-defined))
; ;;;;; ; ;
; ; ; ; ;
; ; ; ;
; ; ;;;;;; ;;; ; ; ;;; ;;;;; ;;;;
; ; ; ;; ; ; ; ; ; ; ;
; ;;; ; ; ; ; ; ; ;
; ;;; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ;;;;
; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ;; ; ; ; ; ;
; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;;
(define-struct trace-struct (evnt-rcvr)) ; frp:event-receiver
(define-struct (break-trace trace-struct) ())
(define-struct (bind-trace trace-struct)
(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
(define-struct debug-process (namespace ; Namespace the process runs in
custodian ; If you shutdown-all it will kill the debugger process
run-semaphore ; When you post to this the debuggee will continue executing
eventspace ; The eventspace where events queue up
running? ; Is the program (supposed-to-be) currently running
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
clients)) ; list of all the clients attached to this process
;###########################################################################################################
; ;;;;; ; ; ;;;;; ;
; ; ; ; ; ;; ; ;
; ; ; ; ; ;
; ; ;;;;;; ;;; ; ; ;;; ;;;;; ; ; ;;; ;;; ;;;; ;;;;; ;;;; ; ;;; ;;;;
; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ;
; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;;;;;;; ; ; ; ; ; ; ;;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ;; ; ; ; ; ; ;
; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;;; ; ;;;; ;;;; ; ;;; ;;;; ; ;;;;
; 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 pauses the program
(define (create-break-trace) ; (void? . -> . trace?)
(make-break-trace (frp:event-receiver)))
(define (create-empty-debug-process)
(make-debug-process (make-namespace)
(make-custodian)
null ; run-semaphore - null so we know it has never started
(make-eventspace)
#f ; running?
(frp:new-cell) ; exited?
(frp:event-receiver) ; exceptions
null ; runtime
empty)) ; clients
(define (create-empty-debug-client)
(make-debug-client null ; modpath
null ; modsymbol
(make-hash) ; tracepoints
null ; line-col->pos function
null)) ; process
;###########################################################################################################
)

653
collects/mztake/mztake.ss
View File

@ -1,4 +1,9 @@
#| TODO #| TODO
offer a way to install a special handler for exceptions -- somehow identify which client an exceptions comes from
CONTRACT ALL SCRIPT FUNCTIONS
------------------- -------------------
does this work on binary drscheme files? does this work on binary drscheme files?
@ -8,7 +13,7 @@ need client-error to throw an exception, they are all fatal
all errors are fatal now -- you can do this when all errors are fatal now -- you can do this when
make all exposed cells and evstreams read-only make all exposed cells and evstreams read-only by lifting the identity function on them
does this handle module prefixes? does this handle module prefixes?
@ -124,122 +129,33 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
(module mztake mzscheme (module mztake mzscheme
(require (lib "match.ss") (require (lib "match.ss")
(lib "unit.ss")
(lib "contract.ss") (lib "contract.ss")
(lib "unitsig.ss") (lib "marks.ss" "stepper/private")
(lib "debugger-model.ss" "stepper" "private") (prefix frp: (lib "frp.ss" "frtime"))
(lib "debugger-annotate.ss" "stepper" "private")
(lib "marks.ss" "stepper" "private")
"private/useful-code.ss" "private/useful-code.ss"
"private/more-useful-code.ss" ; mostly for hash- bindings "private/more-useful-code.ss" ; mostly for hash- bindings
"private/load-annotator.ss" "mztake-structs.ss"
(prefix frp: (lib "frp.ss" "frtime"))) "debugger-model.ss")
; Provides come from the script section at the bottom of the code ; Provides come from the script section at the bottom of the code
(provide debugger) (provide create-debug-process
;(rename script:kill kill) create-debug-client
;(rename script:pause pause) trace/bind
;(rename script:trace/bind trace/bind) trace/break
;(rename script:trace/break trace/break) start/resume
;(rename script:set-running! set-running!) kill
;(rename debugger:exited? debugger:exited?) kill-all
;(rename script:start/resume start/resume) pause
;(rename script:create client:create) (rename debug-process-exceptions process:exceptions)
;(rename debugger:exceptions debugger:exceptions) (rename runtime/seconds process:runtime/seconds)
;(rename script:runtime/seconds debugger:runtime/seconds) (rename runtime/milliseconds process:runtime/milliseconds)
;(rename script:runtime/milliseconds debugger:runtime/milliseconds)) (rename debug-process-exited? process:exited?)
;(rename script-running? client-running?)) ; disabled until it works #|
set-running!
process:running? ; disabled until it works
|#
)
; ;;;;; ; ;
; ; ; ; ;
; ; ; ;
; ; ;;;;;; ;;; ; ; ;;; ;;;;; ;;;;
; ; ; ;; ; ; ; ; ; ; ;
; ;;; ; ; ; ; ; ; ;
; ;;; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ;;;;
; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ;; ; ; ; ; ;
; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;;
(define-struct trace (evnt-rcvr)) ; frp:event-receiver
(define-struct (break-trace trace) ())
(define-struct (bind-trace trace)
(variable-to-bind)) ; symbol
(define-struct client (filename ; string
tracepoints ; hash-table of traces
line-col->pos)); memoized O(n) function to map line/col -> byte offset
(define-struct client-process (namespace ; Namespace the process runs in
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
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
files/traces ; Hash-table with filenames as keys and hashtables of traces as values
))
(define run-semaphore null)
(define debugger:running? #f)
(define debugger:exited? (frp:new-cell))
(define debugger:exceptions (frp:event-receiver))
(define debugger:runtime
(frp:hold
((frp:changes
(frp:accum-b
((frp:changes frp:milliseconds)
. frp:-=> .
(match-lambda [(prev sum)
(if (frp:value-now debugger:running?)
(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:==> .
second)
0))
;###########################################################################################################
; ;;;;; ; ; ;;;;; ;
; ; ; ; ; ;; ; ;
; ; ; ; ; ;
; ; ;;;;;; ;;; ; ; ;;; ;;;;; ; ; ;;; ;;; ;;;; ;;;;; ;;;; ; ;;; ;;;;
; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ;
; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;;;;;;; ; ; ; ; ; ; ;;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ;; ; ; ; ; ; ;
; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;;; ; ;;;; ;;;; ; ;;; ;;;; ; ;;;;
; 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 pauses the program
(define (create-break-trace) ; (void? . -> . trace?)
(make-break-trace (frp:event-receiver)))
;###########################################################################################################
; ; ; ; ; ; ; ;
; ;;;;;; ; ; ; ; ; ; ;;;;;; ; ; ; ; ;
@ -255,14 +171,9 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ;; ; ; ;
; ;;;;;; ; ;;;; ;;;;;; ;;;; ; ; ; ;;;; ; ; ;;;; ; ;;;;;; ; ;;;; ;;;;;; ;;;; ; ; ; ;;;; ; ; ;;;;
; Keeps track of all defined clients
(define all-clients null) ;Keeps track of all debugging processes
(define all-debug-processes null)
;TODO For now, we have one global process in this list
(define all-client-processes null)
;TODO When you support more than one process, find and replace this function
(define (get-main-client-process) (first all-client-processes))
;########################################################################################################### ;###########################################################################################################
@ -285,13 +196,15 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
; Callback for when a breakpoint (tracepoint) is hit by the model ; Callback for when a breakpoint (tracepoint) is hit by the model
; ((client) breakpoint-struct) -> () ; ((client) breakpoint-struct) -> ()
(define ((receive-result client) result) (define ((receive-result process) result)
(match result (match result
; regular breakpoint ; regular breakpoint
[($ normal-breakpoint-info (top-mark rest-mark ...) kind) [($ normal-breakpoint-info (top-mark rest-mark ...) kind)
(print-debug "breakpoint hit")
(void)]
#|
(let* ([byte-offset (sub1 (syntax-position (mark-source top-mark)))] (let* ([byte-offset (sub1 (syntax-position (mark-source top-mark)))]
[trace-hash (client-tracepoints client)] [trace-hash (debug-file-tracepoints client)]
[traces (hash-get trace-hash byte-offset)]) [traces (hash-get trace-hash byte-offset)])
(assert (not (empty? traces)) (assert (not (empty? traces))
@ -300,18 +213,23 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
; Run all traces at this breakpoint ; Run all traces at this breakpoint
(let ([to-send (map (lambda (t) (trace->frp-event client result t)) traces)]) (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 ; now, breakpoint-halt message should be sent by the debugger model
;TODO eventually remove this from debugger-model.ss ;TODO eventually remove this from debugger-model.ss
[($ error-breakpoint-info message) [($ error-breakpoint-info (source exn))
(assert false)] ; 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))]
;end of a statement ;end of a statement
[($ breakpoint-halt) [($ breakpoint-halt)
; do we want to pause interactive debugging ; do we want to pause interactive debugging
(when (running-now?) (when (running-now? process)
(semaphore-post (client-process-run-semaphore (get-main-client-process))))] (semaphore-post (debug-process-run-semaphore process)))]
;when a top level expression finishes ;when a top level expression finishes
[($ expression-finished return-val-list) (void)])) [($ expression-finished return-val-list) (void)]))
@ -338,24 +256,30 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
; ; ; ; ; ;
; ;;;; ; ;;;;
#|(define (annotate-and-load-all-clients break namespace)
(let ([main-client-fn (client-filename (first all-clients))] (define (kill-all)
[annotate-module? (for-each (lambda (p) (kill p)) all-debug-processes)
(lambda (m) (display "All debug processes have been killed."))
(filter (lambda (c)
(client-
] ; wrapper for errors related to the script only
[annotator (define (script-error err)
(lambda (fn m stx) ; TODO I made this a syntax error so that the little 'goto' clickable box wouldnt show up
; it could easily be an (error)
[fn (client-filename client)] (display (format "mztake:script-error: ~a~n---~n" err))
[breakpoints (hash-keys (client-tracepoints client))] (kill-all))
[receive-result (receive-result client)]
[annotator (lambda (stx)
(annotate stx breakpoints fn break))]) (define (client-error err)
(parameterize ([current-namespace namespace]) ; TODO I made this a syntax error so that the little 'goto' clickable box wouldnt show up
(load/annotate main-client ; it could easily be an (error)
(printf "expanding: ~a~n~n" (syntax-object->datum (expand stx)))))))|# (display (format "mztake:client-error: ~a~n---~n" err))
(kill-all))
(define (print-debug str)
(display (format "mztake:debug: ~a~n---~n" str)))
; retreives the binding of a variable from a breakpoint event ; retreives the binding of a variable from a breakpoint event
(define (binding event sym) (define (binding event sym)
@ -370,30 +294,12 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
(define (do-n-times fn n arg) (define (do-n-times fn n arg)
(foldl (lambda (x arg) (fn arg)) arg (build-list n (lambda (x) x)))) (foldl (lambda (x arg) (fn arg)) arg (build-list n (lambda (x) x))))
; wrapper for errors related to the script only
(define (script-error err)
; TODO I made this a syntax error so that the little 'goto' clickable box wouldnt show up
; it could easily be an (error)
(display (format "mztake:script-error: ~a~n---~n" err)))
(define (client-error err)
; TODO I made this a syntax error so that the little 'goto' clickable box wouldnt show up
; it could easily be an (error)
(display (format "mztake:client-error: ~a~n---~n" err)))
(define (print-debug str)
(display (format "mztake:debug: ~a~n---~n" str)))
(define (fatal-script-error err client)
(script-error err)
(script:kill client))
; takes a single trace, looks up what it needs to do, and returns an frp-event to publish ; takes a single trace, looks up what it needs to do, and returns an frp-event to publish
(define (trace->frp-event client event trace) (define (trace->frp-event client event trace)
(match trace (match trace
[($ break-trace evnt-rcvr) [($ break-trace evnt-rcvr)
(script:pause client) #;(pause client)
(list evnt-rcvr #t)] (list evnt-rcvr #t)]
[($ bind-trace evnt-rcvr variable-to-bind) [($ bind-trace evnt-rcvr variable-to-bind)
(let* ([vars (if (list? variable-to-bind) variable-to-bind (let* ([vars (if (list? variable-to-bind) variable-to-bind
@ -401,8 +307,7 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
[values (map (lambda (var) [values (map (lambda (var)
(let ([val (binding event var)]) (let ([val (binding event var)])
(if (empty? val) (if (empty? val)
(fatal-script-error (format "No binding found in trace for symbol '~a" var) (script-error (format "No binding found in trace for symbol '~a" var))
client)
(cadar (binding event var))))) (cadar (binding event var)))))
vars)]) vars)])
(list evnt-rcvr (list evnt-rcvr
@ -417,104 +322,156 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
(begin0 (begin0
(let loop ([stx (read-syntax filename port)]) (let loop ([stx (read-syntax filename port)])
(unless (eof-object? stx) (unless (eof-object? stx)
(print-debug (format "expanding: ~a" (syntax-object->datum (expand stx)))) #;(print-debug (format "expanding: ~a" (syntax-object->datum (expand stx))))
(callback (callback
(expand stx) (expand stx)
(lambda () (loop (read-syntax filename port)))))) (lambda () (loop (read-syntax filename port))))))
(close-input-port port))))) (close-input-port port)))))
(define (start-debugger) ; returns a memoized function that takes (line column) -> position
(let* ([client (first all-clients)] ; line-col->pos : (debug-file? . -> . (number? number? . -> . (union void? number?)))
[_ (print-debug "change '[client (first all-clients)]' in (start-debugger)")] (define (line-col->pos filename)
[breakpoint-origin (client-filename client)] ; produces a nested list of (line column offset) for all addressable syntax
[breakpoints (hash-keys (client-tracepoints client))] (define (unwrap-syntax stx)
[program-expander (program-expander breakpoint-origin)] (let ([elt (list (syntax-line stx)
[receive-result (receive-result client)]) (syntax-column stx)
(sub1 (syntax-position stx)))])
; connect to the debugger-model@ unit (syntax-case stx ()
(define-values/invoke-unit/sig (go go-semaphore user-custodian) [(item ...) (cons elt (map unwrap-syntax (syntax->list stx)))]
debugger-model@ [x elt])))
#f ; prefix
(receive-result) (let ([pos-list
(program-expander) (flatten (parameterize ([port-count-lines-enabled #t])
; breakpoint-origin = filename from thunk of (program-expander) (let ([port (open-input-file filename)])
(breakpoints breakpoint-origin)) (begin0
(let loop ([stx (read-syntax filename port)])
(if (eof-object? stx) '()
(cons (unwrap-syntax stx)
(loop (read-syntax filename port)))))
(close-input-port port)))))])
(lambda (line col)
(let loop ([lst pos-list]
[last-coord (first pos-list)])
(cond
; none is found
[(empty? lst)
(script-error (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))
(= col (cadar lst)))
(third (first lst))]
[else (loop (rest lst)
(first lst))])))))
;###########################################################################################################
; ;;;;;; ;;;;;;;
; ; ; ;
; ; ; ;
; ; ; ; ;;; ;;;; ;;; ;;; ;;;; ;;;; ; ; ; ; ;;;; ;;; ;;;;
; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ;;;;;;; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;;;;; ; ; ; ; ;;;;;;; ;;;; ;;;; ; ; ; ; ; ; ;;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ;
; ; ; ;;;; ;;; ;;;; ;;;; ;;;; ; ;;;; ; ; ; ;;; ;;;;
(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)])
; initialize the semaphore
(set-debug-process-run-semaphore! process (make-semaphore))
; set initial state of exit predicate ; set initial state of exit predicate
(frp:set-cell! debugger:exited? #f) (frp:set-cell! (debug-process-exited? process) #f)
(set-client-process-run-semaphore! (get-main-client-process) go-semaphore) ; run the process
(let ([evaluation-thread (thread (lambda () (run)))])
(set-client-process-custodian! (get-main-client-process) user-custodian) (thread (lambda ()
(print-debug (format "~a" (client-process-custodian (get-main-client-process))))
; we run the program under its own custodian so we can easily kill it...that's IT
(let ([evaluation-thread
(parameterize ([current-custodian user-custodian])
(thread
(lambda ()
; all errors and raises from the TARGET program will be caught here
; FrTime errors from the script have their own eventstream
(with-handlers
([(lambda (exn) #t)
(lambda (exn)
(frp:send-event debugger:exceptions exn)
(client-error (if (exn? exn)
(format "exception: ~a" (exn-message exn))
exn)))])
(go)))))])
(thread (lambda ()
(thread-wait evaluation-thread) (thread-wait evaluation-thread)
; program terminates ; program terminates
(script:kill)))))) (kill process))))))
; returns a memoized function that takes (line column) -> position
(define/contract line-col->pos (client? . -> . (number? number? . -> . (union void? number?)))
(lambda (client)
(let ([filename (client-filename client)])
; produces a nested list of (line column offset) for all addressable syntax
(define (unwrap-syntax stx)
(let ([elt (list (syntax-line stx)
(syntax-column stx)
(sub1 (syntax-position stx)))])
(syntax-case stx ()
[(item ...) (cons elt (map unwrap-syntax (syntax->list stx)))]
[x elt])))
(let ([pos-list
(flatten (parameterize ([port-count-lines-enabled #t])
(let ([port (open-input-file filename)])
(begin0
(let loop ([stx (read-syntax filename port)])
(if (eof-object? stx) '()
(cons (unwrap-syntax stx)
(loop (read-syntax filename port)))))
(close-input-port port)))))])
(lambda (line col)
(let loop ([lst pos-list]
[last-coord (first pos-list)])
(cond
; none is found
[(empty? lst)
(fatal-script-error (format "No syntax found for trace at line/column ~a:~a in ~a" line col filename)
client)]
; if first is correct line and correct column
[(and (= line (caar lst))
(= col (cadar lst)))
(third (first lst))]
[else (loop (rest lst)
(first lst))])))))))
; predicate - is the debugee supposed to be running now? ; predicate - is the debugee supposed to be running now?
(define (running-now?) (define (running-now? process)
(and (not (null? (client-process-run-semaphore (get-main-client-process)))) (and (not (null? (debug-process-run-semaphore process)))
(frp:value-now debugger:running?))) (frp:value-now (debug-process-running? process))))
; Switches the running state on or off
; ((union frp:behavior? boolean?) . -> . void?)
(define (set-running! process run?)
(define (update)
; start the debugger if needed
(when (null? (debug-process-run-semaphore process))
(start-debug-process process))
(when run?
(semaphore-post (debug-process-run-semaphore process)))
(frp:value-now run?))
(cond [(frp:behavior? run?)
(script-error "set-running! can't take behaviors right now!")]
;(set! debugger:running? (frp:proc->signal update run?))]
[else (set-debug-process-running?! process run?)
(update)])
(void))
(define (pause process) (set-running! process #f))
(define (start/resume process)
(let ([val (frp:value-now (debug-process-exited? process))])
; only start the debugger once
(if ((not (equal? val frp:undefined)) . and . val)
(script-error "Cannot restart program once it has exited. Try restarting the script.")
(set-running! process #t))))
; Kills the debugger process immediately
(define (kill process)
(pause 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 (create-debug-process)
(let ([p (create-empty-debug-process)])
(set-debug-process-runtime! p (runtime 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))
;########################################################################################################### ;###########################################################################################################
@ -537,121 +494,88 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
; ; ; ;
; ; ; ;
; Switches the running state on or off
; ([boolean]) -> ()
(define/contract script:set-running! ((union frp:behavior? boolean?) . -> . void?)
(lambda (run?)
(define (update)
; start the debugger if needed
(when (null? (client-process-run-semaphore (get-main-client-process))) (start-debugger))
(when run? (semaphore-post run-semaphore))
(frp:value-now run?))
(cond [(frp:behavior? run?)
(set! debugger:running? (frp:proc->signal update run?))]
[else (set! debugger:running? run?)
(update)])
(void)))
(define (running? process)
(script-error "client-running? is broken")
(and (running-now? process)
(not (debug-process-exited? process))))
(define (runtime/milliseconds process)
(debug-process-runtime process))
;TODO dont forget to contract this ;TODO dont forget to contract this
(define (script:running?) (define (runtime/seconds process)
(script-error "client-running? is broken") (frp:hold ((frp:changes (runtime/milliseconds process))
(and (running-now?)
(not debugger:exited?)))
(define script:runtime/milliseconds debugger:runtime)
(define script:runtime/seconds
(frp:hold ((frp:changes debugger:runtime)
. frp:==> . . frp:==> .
(lambda (t) (truncate (/ t 1000)))) (lambda (t) (truncate (/ t 1000))))
0)) 0))
; Creates a debugger client ; Creates a debugger client
; (string) -> (client) ; ((union (listof (union string? symbol?)) string?) . -> . debug-file?)
(define/contract script:create ((union (listof (union string? symbol?)) string?) . -> . client?) (define (create-debug-client process filename)
(lambda (filename) ; throwaway namespace so the module-name-resolver doesn't load an unannotated module
; throwaway namespace so the module-name-resolver doesn't load an unannotated module (parameterize ([current-namespace (make-namespace)])
(parameterize ([current-namespace (make-namespace)]) (with-handlers ([exn:module?
(with-handlers ([exn:module? (lambda (exn)
(lambda (exn) (client-error (format "Expected a module in client: ~a" filename)))])
(client-error (format "Expected a module in client: ~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)))]
[modsymbol ((current-module-name-resolver) filename #f #f)]
[modpath (symbol->string modsymbol)]
[modpath (build-module-filename
(if (regexp-match #rx"^," modpath)
(substring modpath 1 (string-length modpath))
modpath))]
[client (create-empty-debug-client)])
(let* ([build-module-filename ; taken from module-overview.ss ;TODO remove me
(lambda (str) (print-debug (format "'~a' -> '~a'" filename modpath))
(let ([try (lambda (ext)
(let ([tst (string-append str ext)]) (set-debug-client-modpath! client modpath)
(and (file-exists? tst) tst)))]) (set-debug-client-modsymbol! client modsymbol)
(or (try ".ss") (try ".scm") (try "") str)))] (set-debug-client-process! client process)
(set-debug-client-line-col->pos! client (line-col->pos filename))
[modpath (symbol->string ((current-module-name-resolver) filename #f #f))] (set-debug-process-clients! process
[modpath (build-module-filename (cons client (debug-process-clients process)))
(if (regexp-match #rx"^," modpath)
(substring modpath 1 (string-length modpath)) client))))
modpath))]
[c (make-client modpath (make-hash) null)])
;TODO remove me
(print-debug (format "'~a' -> '~a'" filename modpath))
; set curried line-col->pos function for client
(set-client-line-col->pos! c (line-col->pos c))
(set! all-clients (cons c all-clients))
c)))))
(define (script:pause) (script:set-running! #f))
(define (script:start/resume)
; only start the debugger once
(if (frp:value-now debugger:exited?)
(script-error "Cannot restart program once it has exited. Try restarting the script.")
(script:set-running! #t)))
; Kills the debugger immediately
(define (script:kill)
(script:pause)
; shutdown the custodian
(custodian-shutdown-all (client-process-custodian (get-main-client-process)))
; set the exit predicate to 'exited'
(frp:set-cell! debugger:exited? #t))
; (client (offset | line column) (symbol | listof symbols) -> (frp:event-receiver) ; (client (offset | line column) (symbol | listof symbols) -> (frp:event-receiver)
(define/contract script:trace/bind (client? number? number? (union symbol? (listof symbol?)) . -> . frp:event?) ; (debug-client? number? number? (union symbol? (listof symbol?)) . -> . frp:event?)
(lambda (client line col binding-symbol) (define (trace/bind client line col binding-symbol)
(let ([trace-hash (client-tracepoints client)] (let ([trace-hash (debug-client-tracepoints client)]
[trace (create-bind-trace binding-symbol)] [trace (create-bind-trace binding-symbol)]
[pos ((client-line-col->pos client) line col)]) [pos ((debug-client-line-col->pos client) line col)])
; add the trace to the list of traces for that byte-offset ; add the trace to the list of traces for that byte-offset
(hash-put! trace-hash pos (hash-put! trace-hash pos
(cons trace (cons trace
(hash-get trace-hash pos (lambda () '())))) (hash-get trace-hash pos (lambda () '()))))
(trace-evnt-rcvr trace)))) (trace-struct-evnt-rcvr trace)))
(define/contract script:trace/break (client? number? number? . -> . frp:event?) ;(debug-file? number? number? . -> . frp:event?)
(lambda (client line col) (define (trace/break client line col)
(let ([trace-hash (client-tracepoints client)] (let ([trace-hash (debug-client-tracepoints client)]
[trace (create-break-trace)] [trace (create-break-trace)]
[pos ((client-line-col->pos client) line col)]) [pos ((debug-client-line-col->pos client) line col)])
(hash-put! trace-hash pos (hash-put! trace-hash pos
(cons trace (cons trace
(hash-get trace-hash pos (lambda () '())))) (hash-get trace-hash pos (lambda () '()))))
(trace-evnt-rcvr trace)))) (trace-struct-evnt-rcvr trace)))
;########################################################################################################### ;###########################################################################################################
; ;
; ;;;;; ; ; ;;;;; ;
; ; ; ; ; ; ; ;
@ -669,6 +593,21 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
; ; ; ;
; ; ; ;
#|
(define-syntax bind
(syntax-rules ()
[(_ (arg ...) body ...)
(trace () (arg ...) body ...)]
[(_ (arg ...))
(trace () (arg ...))]))
(define-syntax trace
(syntax-rules ()
[(trace client line col . type)
(print type)]))
(define-syntax debugger (define-syntax debugger
(syntax-rules () (syntax-rules ()
[(debug [(debug
@ -677,15 +616,17 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
(traces [trace-name trace-client-name (traces [trace-name trace-client-name
(trace-type . trace-args) (trace-body ...)] ...) (trace-type . trace-args) (trace-body ...)] ...)
(run process-name (run process-name
body ...) body ...))
(printf "clients: ~a~nrun: ~a~nbody: ~a~n" (printf "clients: ~a~nrun: ~a~nbody: ~a~n"
'(clients [client-name client-path (traces [trace-name trace-client trace-type . trace-args] ...)] ...) '(clients [client-name client-path (traces [trace-name trace-client trace-type . trace-args] ...)] ...)
'(run run-client-name) '(run run-client-name)
'(body ...)) '(body ...))]))
])) |#
;########################################################################################################### ;###########################################################################################################
) )