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

new thread breaking in sandbox, improved with-limits to use call-in-nested-thread

Browse Source 
svn: r7123
This commit is contained in:
Eli Barzilay 2007-08-19 23:27:14 +00:00
parent a626d25acd
commit 392f99b717
2 changed files with 78 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
collects/mzlib/sandbox.ss
View File

@ -16,6 +16,7 @@
sandbox-network-guard
sandbox-eval-limits
kill-evaluator
break-evaluator
set-eval-limits
put-input
get-output
@ -177,31 +178,43 @@
(define memory-accounting? (custodian-memory-accounting-available?))
(define (call-with-limits sec mb thunk)
(let ([cust (make-custodian)]
[ch (make-channel)]
;; use this to copy parameter changes from the sub-thread
[p current-preserved-thread-cell-values])
(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 cust (* mb 1024 1024) cust))
(let* ([work (parameterize ([current-custodian cust])
(thread (lambda ()
(channel-put ch
(with-handlers ([void (lambda (e)
(list (p) raise e))])
(call-with-values thunk
(lambda vs (list* (p) values vs))))))))]
[watch (thread (lambda ()
(channel-put ch
(if (sync/timeout sec work) 'memory 'time))))]
[r (channel-get ch)])
(custodian-shutdown-all cust)
(kill-thread watch)
(if (list? r)
;; apply parameter changes first
(begin (p (car r)) (apply (cadr r) (cddr r)))
(raise (make-exn:fail:resource (format "with-limit: out of ~a" r)
(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
(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)))))
(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)
r))))))
(cdr r)))))))
(define-syntax with-limits
(syntax-rules ()
@ -357,6 +370,7 @@
(define null-input (open-input-bytes #""))
(define (kill-evaluator eval) (eval kill-evaluator))
(define (break-evaluator eval) (eval break-evaluator))
(define (set-eval-limits eval . args) ((eval set-eval-limits) args))
(define (put-input eval . args) (apply (eval put-input) args))
(define (get-output eval) (eval get-output))
@ -376,13 +390,15 @@
(define limits (sandbox-eval-limits))
(define user-thread #t) ; set later to the thread
(define orig-cust (current-custodian))
(define (kill-me)
(define (user-kill)
(when user-thread
(let ([t user-thread])
(set! user-thread #f)
(custodian-shutdown-all cust)
(kill-thread t))) ; just in case
(void))
(define (user-break)
(when user-thread (break-thread user-thread)))
(define (user-process)
(with-handlers ([void (lambda (exn) (channel-put result-ch exn))])
;; first set up the environment
@ -397,7 +413,7 @@
;; finally wait for interaction expressions
(let loop ([n 1])
(let ([expr (channel-get input-ch)])
(when (eof-object? expr) (channel-put result-ch expr) (kill-me))
(when (eof-object? expr) (channel-put result-ch expr) (user-kill))
(let ([code (input->code (list expr) 'eval n)])
(with-handlers ([void (lambda (exn)
(channel-put result-ch (cons 'exn exn)))])
@ -411,7 +427,13 @@
(loop (add1 n)))))
(define (user-eval expr)
(let ([r (if user-thread
(begin (channel-put input-ch expr) (channel-get result-ch))
(begin (channel-put input-ch expr)
(let loop ()
(with-handlers ([exn:break?
(lambda (e)
(user-break)
(loop))])
(channel-get result-ch))))
eof)])
(cond [(eof-object? r) (error 'evaluator "terminated")]
[(eq? (car r) 'exn) (raise (cdr r))]
@ -439,7 +461,8 @@
[(eq? arg input-putter) input]
[else (error 'put-input "bad input: ~e" arg)])]))
(define (evaluator expr)
(cond [(eq? expr kill-evaluator) (kill-me)]
(cond [(eq? expr kill-evaluator) (user-kill)]
[(eq? expr break-evaluator) (user-break)]
[(eq? expr set-eval-limits) (lambda (args) (set! limits args))]
[(eq? expr put-input) input-putter]
[(eq? expr get-output) (output-getter output)]

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

@ -59,6 +59,34 @@
--top--
(when (custodian-memory-accounting-available?)
(t --eval-- (memory 1000000) =err> "out of memory"))
;; test parameter settings (tricky to get this right since
;; with-limits runs stuff in a different thread)
(set-eval-limits ev #f #f)
--eval--
(define p (make-parameter 0))
(p) => 0
(p 1)
(p) => 1
(thread-wait (thread (lambda () (p 100))))
(p) => 1
--top--
(set-eval-limits ev 1 3)
--eval--
(p) => 1
(p 2)
(p) => 2
(thread-wait (thread (lambda () (p 100))))
(p) => 2
--top--
(set-eval-limits ev #f #f)
--eval--
(p) => 2
;; breaking
--top--
(thread (lambda () (sleep 1) (break-evaluator ev)))
--eval--
(sleep 2) =err> "user break"
;; termination
--eval--
(printf "x = ~s\n" x) => (void)
,eof =err> "terminated"