.
original commit: e6aa1a011104d75f164cf52c2a41cb388b926da2
This commit is contained in:
Matthew Flatt
parent
b3519c87cf
commit
f055c992eb
|
|
@ -1,8 +1,200 @@
|
|||
|
||||
(require-library "threadu.ss")
|
||||
(module thread mzscheme
|
||||
(import "spidey.ss")
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
(export consumer-thread
|
||||
merge-input
|
||||
with-semaphore
|
||||
semaphore-wait-multiple
|
||||
|
||||
dynamic-disable-break
|
||||
dynamic-enable-break
|
||||
make-single-threader)
|
||||
|
||||
(define-values/invoke-unit/sig mzlib:thread^
|
||||
mzlib:thread@)
|
||||
#|
|
||||
t accepts a function, f, and creates a thread. It returns the thread and a
|
||||
function, g. When g is applied it passes it's argument to f, and evaluates
|
||||
the call of f in the time of the thread that was created. Calls to g do not
|
||||
block.
|
||||
|#
|
||||
|
||||
(define consumer-thread
|
||||
(case-lambda
|
||||
[(f) (consumer-thread f void)]
|
||||
[(f init)
|
||||
(unless (procedure? f) (raise-type-error 'consumer-thread "procedure" f))
|
||||
(let ([sema (make-semaphore 0)]
|
||||
[protect (make-semaphore 1)]
|
||||
[front-state null]
|
||||
[back-state null])
|
||||
(values
|
||||
(thread
|
||||
(letrec ([loop
|
||||
(lambda ()
|
||||
(semaphore-wait sema)
|
||||
(let ([local-state
|
||||
(begin
|
||||
(semaphore-wait protect)
|
||||
(if (null? back-state)
|
||||
(let ([new-front (reverse front-state)])
|
||||
(set! back-state (cdr new-front))
|
||||
(set! front-state null)
|
||||
(semaphore-post protect)
|
||||
(car new-front))
|
||||
(begin0
|
||||
(car back-state)
|
||||
(set! back-state (cdr back-state))
|
||||
(semaphore-post protect))))])
|
||||
(apply f local-state))
|
||||
(loop))])
|
||||
(lambda ()
|
||||
(init)
|
||||
(loop))))
|
||||
(lambda new-state
|
||||
(let ([num (length new-state)])
|
||||
(unless (procedure-arity-includes? f num)
|
||||
(raise
|
||||
(make-exn:application:arity
|
||||
(format "<procedure-from-consumer-thread>: consumer procedure arity is ~e; provided ~s argument~a"
|
||||
(arity f) num (if (= 1 num) "" "s"))
|
||||
(current-continuation-marks)
|
||||
num
|
||||
(arity f)))))
|
||||
(semaphore-wait protect)
|
||||
(set! front-state (cons new-state front-state))
|
||||
(semaphore-post protect)
|
||||
(semaphore-post sema))))]))
|
||||
|
||||
|
||||
(define (merge-input a b)
|
||||
(or (input-port? a)
|
||||
(raise-type-error 'merge-input "input-port" a))
|
||||
(or (input-port? b)
|
||||
(raise-type-error 'merge-input "input-port" b))
|
||||
(let-values ([(rd wt) (make-pipe)])
|
||||
(let* ([copy1-sema (make-semaphore 500)]
|
||||
[copy2-sema (make-semaphore 500)]
|
||||
[ready1-sema (make-semaphore)]
|
||||
[ready2-sema (make-semaphore)]
|
||||
[check-first? #t]
|
||||
[close-sema (make-semaphore)]
|
||||
[mk-copy (lambda (from to copy-sema ready-sema)
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(semaphore-wait copy-sema)
|
||||
(let ([c (read-char from)])
|
||||
(unless (eof-object? c)
|
||||
(semaphore-post ready-sema)
|
||||
(write-char c to)
|
||||
(loop))))
|
||||
(semaphore-post close-sema)))])
|
||||
(thread (mk-copy a wt copy1-sema ready1-sema))
|
||||
(thread (mk-copy b wt copy2-sema ready2-sema))
|
||||
(thread (lambda ()
|
||||
(semaphore-wait close-sema)
|
||||
(semaphore-wait close-sema)
|
||||
(close-output-port wt)))
|
||||
(make-input-port
|
||||
(lambda () (let ([c (read-char rd)])
|
||||
(unless (eof-object? c)
|
||||
(if (and check-first? (semaphore-try-wait? ready1-sema))
|
||||
(semaphore-post copy1-sema)
|
||||
(if (not (semaphore-try-wait? ready2-sema))
|
||||
; check-first? must be #f
|
||||
(if (semaphore-try-wait? ready1-sema)
|
||||
(semaphore-post copy1-sema)
|
||||
(error 'join "internal error: char from nowhere!"))
|
||||
(semaphore-post copy2-sema)))
|
||||
(set! check-first? (not check-first?)))
|
||||
c))
|
||||
(lambda () (char-ready? rd))
|
||||
(lambda () (close-input-port rd))))))
|
||||
|
||||
(define with-semaphore
|
||||
(lambda (s f)
|
||||
(semaphore-wait s)
|
||||
(begin0 (f)
|
||||
(semaphore-post s))))
|
||||
|
||||
(define semaphore-wait-multiple
|
||||
(case-lambda
|
||||
[(semaphores) (semaphore-wait-multiple semaphores #f #f)]
|
||||
[(semaphores timeout) (semaphore-wait-multiple semaphores timeout #f)]
|
||||
[(semaphores timeout allow-break?)
|
||||
(let ([break-enabled? (or allow-break? (break-enabled))])
|
||||
(parameterize ([break-enabled #f])
|
||||
(for-each
|
||||
(lambda (s)
|
||||
(or (semaphore? s)
|
||||
(raise-type-error 'semaphore-wait-multiple "list of semaphores" semaphores)))
|
||||
semaphores)
|
||||
(or (not timeout) (real? timeout) (>= timeout 0)
|
||||
(raise-type-error 'semaphore-wait-multiple "positive real number" timeout))
|
||||
(let* ([result-l null]
|
||||
[ok? #f]
|
||||
[set-l (make-semaphore 1)]
|
||||
[one-done (make-semaphore)]
|
||||
[threads (let loop ([l semaphores])
|
||||
(if (null? l)
|
||||
null
|
||||
(cons (let ([s (car l)])
|
||||
(thread (lambda ()
|
||||
(let/ec
|
||||
k
|
||||
(current-exception-handler k)
|
||||
(semaphore-wait/enable-break s)
|
||||
(with-semaphore
|
||||
set-l
|
||||
(lambda () (set! result-l
|
||||
(cons s result-l))))
|
||||
(semaphore-post one-done)))))
|
||||
(loop (cdr l)))))]
|
||||
[timer-thread (if timeout
|
||||
(thread (lambda () (sleep timeout) (semaphore-post one-done)))
|
||||
#f)])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
; wait until someone is done
|
||||
((if break-enabled? semaphore-wait/enable-break semaphore-wait) one-done)
|
||||
(set! ok? #t))
|
||||
(lambda ()
|
||||
; tell everyone to stop
|
||||
(for-each (lambda (th) (break-thread th)) threads)
|
||||
(when timer-thread (break-thread timer-thread))
|
||||
; wait until everyone's done
|
||||
(for-each thread-wait threads)
|
||||
; If more that too manay suceeded, repost to the extras
|
||||
(let ([extras (if ok?
|
||||
(if (null? result-l)
|
||||
null
|
||||
(cdr result-l))
|
||||
result-l)])
|
||||
(for-each (lambda (s) (semaphore-post s)) extras))))
|
||||
(if (null? result-l)
|
||||
#f
|
||||
(car result-l)))))]))
|
||||
|
||||
(define dynamic-enable-break
|
||||
(polymorphic
|
||||
(lambda (thunk)
|
||||
(parameterize ([break-enabled #t])
|
||||
(thunk)))))
|
||||
|
||||
(define dynamic-disable-break
|
||||
(polymorphic
|
||||
(lambda (thunk)
|
||||
(parameterize ([break-enabled #f])
|
||||
(thunk)))))
|
||||
|
||||
(define make-single-threader
|
||||
(polymorphic
|
||||
(lambda ()
|
||||
(let ([sema (make-semaphore 1)])
|
||||
(lambda (thunk)
|
||||
(dynamic-wind
|
||||
(lambda () (semaphore-wait sema))
|
||||
thunk
|
||||
(lambda () (semaphore-post sema))))))))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -7,267 +7,247 @@
|
|||
; - If the library is loaded more than once, especially in the middle
|
||||
; of a trace, the behavior is not well-defined.
|
||||
|
||||
(define-signature mzlib:trace^
|
||||
(-:trace-level -:trace-print-args -:trace-print-results
|
||||
-:trace-table
|
||||
-:make-traced-entry -:traced-entry-original-proc -:traced-entry-trace-proc
|
||||
trace untrace))
|
||||
(module trace mzscheme
|
||||
(import "pretty.ss")
|
||||
|
||||
(begin-elaboration-time (require-library "prettyu.ss"))
|
||||
(export trace untrace)
|
||||
|
||||
(begin-elaboration-time
|
||||
(define mzlib:trace@
|
||||
(unit/sig mzlib:trace^
|
||||
(import mzlib:pretty-print^)
|
||||
(export-indirect -:trace-level -:trace-print-args
|
||||
-:trace-print-results
|
||||
-:trace-table
|
||||
-:make-traced-entry -:traced-entry-original-proc
|
||||
-:traced-entry-trace-proc)
|
||||
|
||||
(define max-dash-space-depth 10)
|
||||
(define number-nesting-depth 6)
|
||||
(define max-dash-space-depth 10)
|
||||
(define number-nesting-depth 6)
|
||||
|
||||
(define as-spaces
|
||||
(lambda (s)
|
||||
(let ((n (string-length s)))
|
||||
(apply string-append
|
||||
(let loop ((k n))
|
||||
(if (zero? k) '("")
|
||||
(cons " " (loop (sub1 k)))))))))
|
||||
(define as-spaces
|
||||
(lambda (s)
|
||||
(let ((n (string-length s)))
|
||||
(apply string-append
|
||||
(let loop ((k n))
|
||||
(if (zero? k) '("")
|
||||
(cons " " (loop (sub1 k)))))))))
|
||||
|
||||
(define-struct prefix-entry (for-first for-rest))
|
||||
(define-struct prefix-entry (for-first for-rest))
|
||||
|
||||
(define prefixes (make-vector 20 #f))
|
||||
(define prefix-vector-length 20)
|
||||
(define prefixes (make-vector 20 #f))
|
||||
(define prefix-vector-length 20)
|
||||
|
||||
(define lookup-prefix
|
||||
(lambda (n)
|
||||
(and (< n prefix-vector-length)
|
||||
(vector-ref prefixes n))))
|
||||
(define lookup-prefix
|
||||
(lambda (n)
|
||||
(and (< n prefix-vector-length)
|
||||
(vector-ref prefixes n))))
|
||||
|
||||
(define insert-prefix
|
||||
(lambda (n first rest)
|
||||
(if (>= n prefix-vector-length)
|
||||
(let ((v (make-vector (* 2 prefix-vector-length) #f)))
|
||||
(let loop ((k 0))
|
||||
(when (< k prefix-vector-length)
|
||||
(vector-set! v k (vector-ref prefixes k))
|
||||
(loop (add1 k))))
|
||||
(set! prefixes v)
|
||||
(set! prefix-vector-length (* 2 prefix-vector-length))
|
||||
(insert-prefix n first rest))
|
||||
(vector-set! prefixes n (make-prefix-entry first rest)))))
|
||||
(define insert-prefix
|
||||
(lambda (n first rest)
|
||||
(if (>= n prefix-vector-length)
|
||||
(let ((v (make-vector (* 2 prefix-vector-length) #f)))
|
||||
(let loop ((k 0))
|
||||
(when (< k prefix-vector-length)
|
||||
(vector-set! v k (vector-ref prefixes k))
|
||||
(loop (add1 k))))
|
||||
(set! prefixes v)
|
||||
(set! prefix-vector-length (* 2 prefix-vector-length))
|
||||
(insert-prefix n first rest))
|
||||
(vector-set! prefixes n (make-prefix-entry first rest)))))
|
||||
|
||||
(define construct-prefixes
|
||||
(lambda (level)
|
||||
(let loop ((n level)
|
||||
(first '("|"))
|
||||
(rest '(" ")))
|
||||
(if (>= n max-dash-space-depth)
|
||||
(let-values (((pre-first pre-rest)
|
||||
(build-prefixes number-nesting-depth)))
|
||||
(let ((s (number->string level)))
|
||||
(values
|
||||
(apply string-append
|
||||
(cons pre-first (cons "[" (cons s (cons "]" '())))))
|
||||
(apply string-append
|
||||
(cons pre-rest (cons " " (cons (as-spaces s)
|
||||
(cons " " '()))))))))
|
||||
(cond
|
||||
((= n 0) (values (apply string-append (reverse first))
|
||||
(apply string-append (reverse rest))))
|
||||
((= n 1) (loop (- n 1)
|
||||
(cons '" " first)
|
||||
(cons '" " rest)))
|
||||
(else (loop (- n 2)
|
||||
(cons " |" first)
|
||||
(cons " " rest))))))))
|
||||
(define construct-prefixes
|
||||
(lambda (level)
|
||||
(let loop ((n level)
|
||||
(first '("|"))
|
||||
(rest '(" ")))
|
||||
(if (>= n max-dash-space-depth)
|
||||
(let-values (((pre-first pre-rest)
|
||||
(build-prefixes number-nesting-depth)))
|
||||
(let ((s (number->string level)))
|
||||
(values
|
||||
(apply string-append
|
||||
(cons pre-first (cons "[" (cons s (cons "]" '())))))
|
||||
(apply string-append
|
||||
(cons pre-rest (cons " " (cons (as-spaces s)
|
||||
(cons " " '()))))))))
|
||||
(cond
|
||||
((= n 0) (values (apply string-append (reverse first))
|
||||
(apply string-append (reverse rest))))
|
||||
((= n 1) (loop (- n 1)
|
||||
(cons '" " first)
|
||||
(cons '" " rest)))
|
||||
(else (loop (- n 2)
|
||||
(cons " |" first)
|
||||
(cons " " rest))))))))
|
||||
|
||||
(define build-prefixes
|
||||
(lambda (level)
|
||||
(let ((p (lookup-prefix level)))
|
||||
(if p
|
||||
(values (prefix-entry-for-first p)
|
||||
(prefix-entry-for-rest p))
|
||||
(let-values (((first rest)
|
||||
(construct-prefixes level)))
|
||||
(insert-prefix level first rest)
|
||||
(values first rest))))))
|
||||
(define build-prefixes
|
||||
(lambda (level)
|
||||
(let ((p (lookup-prefix level)))
|
||||
(if p
|
||||
(values (prefix-entry-for-first p)
|
||||
(prefix-entry-for-rest p))
|
||||
(let-values (((first rest)
|
||||
(construct-prefixes level)))
|
||||
(insert-prefix level first rest)
|
||||
(values first rest))))))
|
||||
|
||||
(define -:trace-level (make-parameter -1))
|
||||
(define -:trace-level (make-parameter -1))
|
||||
|
||||
(define -:trace-print-args
|
||||
(lambda (name args)
|
||||
(let-values (((first rest)
|
||||
(build-prefixes (-:trace-level))))
|
||||
(parameterize ((pretty-print-print-line
|
||||
(lambda (n port offset width)
|
||||
(display
|
||||
(define -:trace-print-args
|
||||
(lambda (name args)
|
||||
(let-values (((first rest)
|
||||
(build-prefixes (-:trace-level))))
|
||||
(parameterize ((pretty-print-print-line
|
||||
(lambda (n port offset width)
|
||||
(display
|
||||
(if n
|
||||
(if (zero? n) first
|
||||
(format "~n~a" rest))
|
||||
(format "~n"))
|
||||
(if (zero? n) first
|
||||
(format "~n~a" rest))
|
||||
(format "~n"))
|
||||
port)
|
||||
(if n
|
||||
(if (zero? n)
|
||||
(string-length first)
|
||||
(string-length rest))
|
||||
0))))
|
||||
(pretty-print (cons name args))))))
|
||||
(if n
|
||||
(if (zero? n)
|
||||
(string-length first)
|
||||
(string-length rest))
|
||||
0))))
|
||||
(pretty-print (cons name args))))))
|
||||
|
||||
(define -:trace-print-results
|
||||
(lambda (name results)
|
||||
(let-values (((first rest)
|
||||
(build-prefixes (-:trace-level))))
|
||||
(parameterize ((pretty-print-print-line
|
||||
(lambda (n port offset width)
|
||||
(display
|
||||
(define -:trace-print-results
|
||||
(lambda (name results)
|
||||
(let-values (((first rest)
|
||||
(build-prefixes (-:trace-level))))
|
||||
(parameterize ((pretty-print-print-line
|
||||
(lambda (n port offset width)
|
||||
(display
|
||||
(if n
|
||||
(if (zero? n) first
|
||||
(format "~n~a" rest))
|
||||
(format "~n"))
|
||||
(if (zero? n) first
|
||||
(format "~n~a" rest))
|
||||
(format "~n"))
|
||||
port)
|
||||
(if n
|
||||
(if (zero? n)
|
||||
(string-length first)
|
||||
(string-length rest))
|
||||
0))))
|
||||
(cond
|
||||
((null? results)
|
||||
(if n
|
||||
(if (zero? n)
|
||||
(string-length first)
|
||||
(string-length rest))
|
||||
0))))
|
||||
(cond
|
||||
((null? results)
|
||||
(pretty-display "*** no values ***"))
|
||||
((null? (cdr results))
|
||||
((null? (cdr results))
|
||||
(pretty-print (car results)))
|
||||
(else
|
||||
(else
|
||||
(pretty-print (car results))
|
||||
(parameterize ((pretty-print-print-line
|
||||
(lambda (n port offset width)
|
||||
(display
|
||||
(if n
|
||||
(if (zero? n) rest
|
||||
(format "~n~a" rest))
|
||||
(format "~n"))
|
||||
port)
|
||||
(lambda (n port offset width)
|
||||
(display
|
||||
(if n
|
||||
(string-length rest)
|
||||
0))))
|
||||
(if (zero? n) rest
|
||||
(format "~n~a" rest))
|
||||
(format "~n"))
|
||||
port)
|
||||
(if n
|
||||
(string-length rest)
|
||||
0))))
|
||||
(for-each pretty-print (cdr results)))))))))
|
||||
|
||||
(define-struct traced-entry (original-proc trace-proc))
|
||||
(define-struct traced-entry (original-proc trace-proc))
|
||||
|
||||
(define -:make-traced-entry make-traced-entry)
|
||||
(define -:traced-entry-original-proc traced-entry-original-proc)
|
||||
(define -:traced-entry-trace-proc traced-entry-trace-proc)
|
||||
(define -:make-traced-entry make-traced-entry)
|
||||
(define -:traced-entry-original-proc traced-entry-original-proc)
|
||||
(define -:traced-entry-trace-proc traced-entry-trace-proc)
|
||||
|
||||
(define -:trace-table
|
||||
(make-hash-table))
|
||||
(define -:trace-table
|
||||
(make-hash-table))
|
||||
|
||||
(define trace
|
||||
(lambda ids
|
||||
(let loop ((ids ids))
|
||||
(unless (null? ids)
|
||||
(unless (symbol? (car ids))
|
||||
(error 'trace "~s not a name" (car ids)))
|
||||
(loop (cdr ids))))
|
||||
`(#%begin
|
||||
,@(map
|
||||
(lambda (id)
|
||||
`(#%with-handlers ((#%exn:variable?
|
||||
(#%lambda (exn)
|
||||
(#%if (#%eq? (#%exn:variable-id exn) ',id)
|
||||
(#%error 'trace
|
||||
"~s is not bound" ',id)
|
||||
(#%raise exn)))))
|
||||
(#%let ((global (#%global-defined-value ',id)))
|
||||
(#%unless (#%procedure? global)
|
||||
(#%error 'trace
|
||||
"the top-level value of ~s is not a procedure" ',id)))))
|
||||
ids)
|
||||
,@(map
|
||||
(lambda (id)
|
||||
(let ((traced-name (string->symbol
|
||||
(string-append "traced-"
|
||||
(symbol->string id))))
|
||||
(table-entry (gensym 'table-entry))
|
||||
(real-value (gensym 'real-value))
|
||||
(global-value (gensym 'global-value)))
|
||||
`(#%let ((,global-value (#%global-defined-value ',id)))
|
||||
(#%let ((,table-entry (#%hash-table-get -:trace-table ',id
|
||||
(#%lambda () #f))))
|
||||
(#%unless (#%and ,table-entry
|
||||
(#%eq? ,global-value
|
||||
(-:traced-entry-trace-proc ,table-entry)))
|
||||
(#%let* ((,real-value ,global-value)
|
||||
(,traced-name
|
||||
(#%lambda args
|
||||
(#%dynamic-wind
|
||||
(lambda ()
|
||||
(-:trace-level
|
||||
(#%add1 (-:trace-level))))
|
||||
(lambda ()
|
||||
(-:trace-print-args ',id args)
|
||||
(#%call-with-values
|
||||
(#%lambda ()
|
||||
(#%apply ,real-value args))
|
||||
(#%lambda results
|
||||
(flush-output)
|
||||
(-:trace-print-results ',id
|
||||
results)
|
||||
(#%apply #%values results))))
|
||||
(lambda ()
|
||||
(-:trace-level
|
||||
(#%sub1 (-:trace-level))))))))
|
||||
(#%hash-table-put! -:trace-table ',id
|
||||
(-:make-traced-entry ,real-value ,traced-name))
|
||||
(#%global-defined-value ',id ,traced-name)))))))
|
||||
ids)
|
||||
(#%quote ,ids))))
|
||||
(define-syntax trace
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id ...)
|
||||
(let ([ids (syntax->list (syntax (id ...)))])
|
||||
(for-each (lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error
|
||||
'trace
|
||||
"not an identifier"
|
||||
stx
|
||||
id)))
|
||||
ids)
|
||||
(with-syntax ([(traced-name ...)
|
||||
(map (lambda (id)
|
||||
(datum->syntax
|
||||
(string->symbol
|
||||
(string-append "traced-"
|
||||
(symbol->string (syntax-e id))))
|
||||
#f id))
|
||||
ids)])
|
||||
(syntax
|
||||
(begin
|
||||
(with-handlers ((exn:variable?
|
||||
(lambda (exn)
|
||||
(if (eq? (exn:variable-id exn) 'id)
|
||||
(error 'trace
|
||||
"~s is not bound" 'id)
|
||||
(raise exn)))))
|
||||
(let ((global (global-defined-value 'id)))
|
||||
(unless (procedure? global)
|
||||
(error 'trace
|
||||
"the top-level value of ~s is not a procedure" 'id))))
|
||||
...
|
||||
|
||||
|
||||
(define untrace
|
||||
(lambda ids
|
||||
(let loop ((ids ids))
|
||||
(unless (null? ids)
|
||||
(unless (symbol? (car ids))
|
||||
(error 'untrace "~s not an identifier" (car ids)))
|
||||
(loop (cdr ids)))
|
||||
`(#%apply #%append
|
||||
(#%list
|
||||
,@(map (lambda (id)
|
||||
`(let ((entry (#%hash-table-get -:trace-table
|
||||
',id (#%lambda () #f))))
|
||||
(#%if (#%and entry
|
||||
(#%eq? (#%global-defined-value ',id)
|
||||
(-:traced-entry-trace-proc entry)))
|
||||
(#%begin
|
||||
(#%hash-table-put! -:trace-table
|
||||
',id #f)
|
||||
(#%global-defined-value ',id
|
||||
(-:traced-entry-original-proc entry))
|
||||
(#%list ',id))
|
||||
'())))
|
||||
ids))))))
|
||||
(let ((global-value (global-defined-value 'id)))
|
||||
(let ((table-entry (hash-table-get -:trace-table 'id (lambda () #f))))
|
||||
(unless (and table-entry
|
||||
(eq? global-value
|
||||
(-:traced-entry-trace-proc table-entry)))
|
||||
(let* ((real-value global-value)
|
||||
(traced-name
|
||||
(lambda args
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(-:trace-level
|
||||
(add1 (-:trace-level))))
|
||||
(lambda ()
|
||||
(-:trace-print-args 'id args)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(apply real-value args))
|
||||
(lambda results
|
||||
(flush-output)
|
||||
(-:trace-print-results 'id results)
|
||||
(apply values results))))
|
||||
(lambda ()
|
||||
(-:trace-level
|
||||
(sub1 (-:trace-level))))))))
|
||||
(hash-table-put! -:trace-table 'id
|
||||
(-:make-traced-entry real-value traced-name))
|
||||
(global-defined-value 'id traced-name)))))
|
||||
...
|
||||
'(id ...)))))])))
|
||||
|
||||
)))
|
||||
(define-syntax untrace
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id ...)
|
||||
(let ([ids (syntax->list (syntax (id ...)))])
|
||||
(for-each (lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error
|
||||
'untrace
|
||||
"not an identifier"
|
||||
stx
|
||||
id)))
|
||||
ids)
|
||||
(syntax
|
||||
(apply append
|
||||
(list
|
||||
(let ((entry (hash-table-get -:trace-table
|
||||
'id (lambda () #f))))
|
||||
(if (and entry
|
||||
(eq? (global-defined-value 'id)
|
||||
(-:traced-entry-trace-proc entry)))
|
||||
(begin
|
||||
(hash-table-put! -:trace-table 'id #f)
|
||||
(global-defined-value 'id (-:traced-entry-original-proc entry))
|
||||
(list 'id))
|
||||
'()))
|
||||
...))))])))
|
||||
|
||||
(begin-elaboration-time
|
||||
(require-library "invoke.ss"))
|
||||
|
||||
(begin-elaboration-time
|
||||
(define-values/invoke-unit/sig mzlib:trace^
|
||||
(compound-unit/sig
|
||||
(import)
|
||||
(link
|
||||
(PRETTY : mzlib:pretty-print^
|
||||
(mzlib:pretty-print@))
|
||||
(TRACE : mzlib:trace^
|
||||
(mzlib:trace@ PRETTY)))
|
||||
(export
|
||||
(open TRACE)))
|
||||
#f))
|
||||
|
||||
(define-macro trace trace)
|
||||
(define-macro untrace untrace)
|
||||
|
||||
(begin-elaboration-time
|
||||
(keyword-name '-:trace-print-args)
|
||||
(keyword-name '-:trace-print-results)
|
||||
(keyword-name '-:trace-table)
|
||||
(keyword-name '-:make-traced-entry)
|
||||
(keyword-name '-:traced-entry-original-proc)
|
||||
(keyword-name '-:traced-entry-trace-proc))
|
||||
)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user