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

* Added `call-in-nested-thread*', and used it to improve

Browse Source 
`call-with-limits'; specifically, it can now distinguish killing the
  main thread or shutting down the custodian from an out-of-memory
  error.
* This also makes it possible to have threads created and stay alive
  between evaluations.
* Added tests for this.

svn: r12673
This commit is contained in:
Eli Barzilay 2008-12-02 12:23:35 +00:00
parent 33d7e4b0d2
commit eb54b1a5b2
2 changed files with 94 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

93
collects/scheme/sandbox.ss
View File

@ -32,6 +32,7 @@
call-in-sandbox-context
make-evaluator
make-module-evaluator
call-in-nested-thread*
call-with-limits
with-limits
exn:fail:resource?
@ -212,45 +213,61 @@
(define memory-accounting? (custodian-memory-accounting-available?))
;; similar to `call-in-nested-thread', but propagates killing the thread,
;; shutting down the custodian or setting parameters and thread cells;
;; optionally with thunks to call for kill/shutdown.
(define (call-in-nested-thread*
thunk
[kill (lambda () (kill-thread (current-thread)))]
[shutdown (lambda () (custodian-shutdown-all (current-custodian)))])
(let* ([p #f]
[c (make-custodian)]
[b (make-custodian-box c #t)])
(with-handlers ([(lambda (_) (not p))
;; if the after thunk was not called, then this error is
;; about the thread dying unnaturally, so propagate
;; whatever it did
(lambda (_) ((if (custodian-box-value b) kill shutdown)))])
(dynamic-wind void
(lambda ()
(parameterize ([current-custodian c])
(call-in-nested-thread
(lambda ()
(dynamic-wind void thunk
;; this should always be called unless the thread is killed or
;; the custodian is shutdown, distinguish the two cases
;; through the above box
(lambda ()
(set! p (current-preserved-thread-cell-values))))))))
(lambda () (when p (current-preserved-thread-cell-values p)))))))
(define (call-with-limits sec mb thunk)
(let ([r #f]
[c (make-custodian)]
;; used to copy parameter changes from the nested thread
[p current-preserved-thread-cell-values])
(when (and mb memory-accounting?)
(custodian-limit-memory c (* mb 1024 1024) c))
(parameterize ([current-custodian c])
;; The nested-thread can die on a time-out or memory-limit,
;; and never throws an exception, so we never throw an error,
;; just assume the a death means the custodian was shut down
;; due to memory limit. Note: cannot copy the
;; parameterization in this case.
(with-handlers ([exn:fail? (lambda (e)
(unless r (set! r (cons #f 'memory))))])
(call-in-nested-thread
(lambda ()
(define this (current-thread))
(define timer
(and sec
(thread (lambda ()
(sleep sec)
;; even in this case there are no parameters
;; to copy, since it is on a different thread
(set! r (cons #f 'time))
(kill-thread this)))))
(set! r
(with-handlers ([void (lambda (e) (list (p) raise e))])
(call-with-values thunk (lambda vs (list* (p) values vs)))))
(when timer (kill-thread timer))))))
(custodian-shutdown-all c)
(unless r (error 'call-with-limits "internal error"))
;; apply parameter changes first
(when (car r) (p (car r)))
(if (pair? (cdr r))
(apply (cadr r) (cddr r))
(raise (make-exn:fail:resource (format "with-limit: out of ~a" (cdr r))
(current-continuation-marks)
(cdr r))))))
;; note that when the thread is killed after using too much memory or time,
;; then all thread-local changes (parameters and thread cells) are discarded
(let ([r #f])
(call-in-nested-thread*
(lambda ()
;; memory limit
(when (and mb memory-accounting?)
(custodian-limit-memory (current-custodian) (* mb 1024 1024)))
;; time limit
(when sec
(let ([t (current-thread)])
(thread (lambda () (sleep sec) (set! r 'time) (kill-thread t)))))
(set! r (with-handlers ([void (lambda (e) (list raise e))])
(call-with-values thunk (lambda vs (list* values vs))))))
(lambda () (unless r (set! r 'kill)))
(lambda () (unless r (set! r 'shut))))
(case r
[(kill) (kill-thread (current-thread))]
[(shut) (custodian-shutdown-all (current-custodian))]
[(memory time)
(raise (make-exn:fail:resource (format "with-limit: out of ~a" r)
(current-continuation-marks)
r))]
[else (if (pair? r)
(apply (car r) (cdr r))
(error 'call-with-limits "internal error in nested: ~e" r))])))
(define-syntax with-limits
(syntax-rules ()

39
collects/tests/mzscheme/sandbox.ss
View File

@ -5,6 +5,28 @@
(require scheme/sandbox)
;; test call-in-nested-thread*
(let ()
(define-syntax-rule (nested body ...)
(call-in-nested-thread* (lambda () body ...)))
(test 1 values (nested 1))
;; propagates parameters
(let ([p (make-parameter #f)])
(nested (p 1))
(test 1 p)
(with-handlers ([void void]) (nested (p 2) (error "foo") (p 3)))
(test 2 p))
;; propagates kill-thread
(test (void) thread-wait
(thread (lambda ()
(nested (kill-thread (current-thread)))
;; never reach here
(semaphore-wait (make-semaphore 0)))))
;; propagates custodian-shutdown-all
(test (void) values
(parameterize ([current-custodian (make-custodian)])
(nested (custodian-shutdown-all (current-custodian))))))
(let ([ev void])
(define (run thunk)
(with-handlers ([void (lambda (e) (list 'exn: e))])
@ -386,6 +408,23 @@
(call-in-sandbox-context ev
(lambda () (custodian-shutdown-all (current-custodian))))
=err> "terminated"
--top--
;; now make sure it works with per-expression limits too
(set! ev (make-evaluator 'scheme/base))
--eval--
(kill-thread (current-thread)) =err> "terminated"
--top--
(set! ev (make-evaluator 'scheme/base))
--eval--
(custodian-shutdown-all (current-custodian)) =err> "terminated"
--top--
(set! ev (make-evaluator 'scheme/base))
(call-in-sandbox-context ev (lambda () (kill-thread (current-thread))))
=err> "terminated"
(set! ev (make-evaluator 'scheme/base))
(call-in-sandbox-context ev
(lambda () (custodian-shutdown-all (current-custodian))))
=err> "terminated"
))