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

Revert "Ensure that threads created within call-with-limits are accounted during the time/space limits"

Browse Source 
This reverts commit 79f8636e1e.
This commit is contained in:
Jay McCarthy 2013-11-26 10:39:42 -07:00
parent 287a59ce12
commit 50402756cf
4 changed files with 39 additions and 136 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
pkgs/racket-pkgs/racket-doc/scribblings/reference/sandbox.scrbl
View File

@ -1007,10 +1007,6 @@ only to limit a whole testing session, instead of each expression.}
A macro version of @racket[call-with-limits].}
@defform[(with-timeout sec-expr body ...)]{
Expands to @racket[(with-limits sec-expr #f body ...)].}
@defproc*[([(exn:fail:resource? [v any/c]) boolean?]
[(exn:fail:resource-resource [exn exn:fail:resource?])

42
pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rkt
View File

@ -1,42 +0,0 @@
#lang racket/base
(require racket/sandbox)
(define (exn:fail:resource:time? x)
(and (exn:fail:resource? x)
(eq? 'time (exn:fail:resource-resource x))))
(module+ test
(require rackunit)
(define n 1)
(check-not-exn
(λ ()
(with-timeout
n
(sleep (sub1 n)))))
(check-exn
exn:fail:resource:time?
(λ ()
(with-timeout
n
(sleep (add1 n)))))
(check-exn
exn:fail:resource:time?
(λ ()
(with-timeout
n
(thread (λ () (sleep (add1 n)))))))
(check-exn
exn:fail:resource:time?
(λ ()
(with-timeout
n
(thread (λ ()
(thread (λ () (sleep (add1 n)))))))))
(check-exn
exn:fail:resource:time?
(λ ()
(with-timeout
n
(parameterize ([current-custodian (make-custodian)])
(thread (λ () (sleep (add1 n)))))))))

48
pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rktl
View File

@ -64,39 +64,23 @@
(or (regexp-match? re m) (list 'bad-exception-message: m)))
x)))
(define-syntax thunk (syntax-rules () [(thunk b ...) (lambda () b ...)]))
(define-syntax (t stx)
(syntax-case stx (--eval-- --top-- => <= =err> <err=)
[(t -?-)
(syntax/loc stx (void))]
[(t -?- --eval-- more ...)
(syntax/loc #'--eval-- (t --eval-- more ...))]
[(t -?- --top-- more ...)
(syntax/loc #'--top-- (t --top-- more ...))]
[(t --eval-- E)
(syntax/loc #'E (test #t run* (thunk (ev `E))))]
[(t --top-- E)
(syntax/loc #'E (test #t run* (thunk E)))]
[(t --eval-- E => R)
(syntax/loc #'E (test `(vals: ,R) run (thunk (ev `E))))]
[(t --top-- E => R)
(syntax/loc #'E (test `(vals: ,R) run (thunk E)))]
[(t --eval-- E =err> R)
(quasisyntax/loc #'E
(test #t e-match? R run #,(syntax/loc #'E (thunk (ev `E)))))]
[(t --top-- E =err> R)
(quasisyntax/loc #'E
(test #t e-match? R run #,(syntax/loc #'E (thunk E))))]
[(t -?- E => R more ...)
(syntax/loc #'E (begin (t -?- E => R) (t -?- more ...)))]
[(t -?- E =err> R more ...)
(syntax/loc #'E (begin (t -?- E =err> R) (t -?- more ...)))]
[(t -?- R <= E more ...)
(syntax/loc #'R (t -?- E => R more ...))]
[(t -?- R <err= E more ...)
(syntax/loc #'R (t E =err> R more ...))]
(define-syntax t
(syntax-rules (--eval-- --top-- => <= =err> <err=)
[(t -?-) (void)]
[(t -?- --eval-- more ...) (t --eval-- more ...)]
[(t -?- --top-- more ...) (t --top-- more ...)]
[(t --eval-- E) (test #t run* (thunk (ev `E)))]
[(t --top-- E) (test #t run* (thunk E))]
[(t --eval-- E => R) (test `(vals: ,R) run (thunk (ev `E)))]
[(t --top-- E => R) (test `(vals: ,R) run (thunk E))]
[(t --eval-- E =err> R) (test #t e-match? R run (thunk (ev `E)))]
[(t --top-- E =err> R) (test #t e-match? R run (thunk E))]
[(t -?- E => R more ...) (begin (t -?- E => R) (t -?- more ...))]
[(t -?- E =err> R more ...) (begin (t -?- E =err> R) (t -?- more ...))]
[(t -?- R <= E more ...) (t -?- E => R more ...)]
[(t -?- R <err= E more ...) (t E =err> R more ...)]
;; last so it doesn't match the above
[(t -?- E more ...)
(syntax/loc #'E (begin (t -?- E) (t -?- more ...)))]))
[(t -?- E more ...) (begin (t -?- E) (t -?- more ...))]))
(define (make-prog . lines)
(apply string-append (map (lambda (l) (string-append l "\n")) lines)))

81
pkgs/sandbox-lib/racket/sandbox.rkt
View File

@ -52,7 +52,6 @@
call-in-nested-thread*
call-with-limits
with-limits
with-timeout
call-with-custodian-shutdown
call-with-killing-threads
exn:fail:sandbox-terminated?
@ -370,71 +369,39 @@
(call-with-values thunk (lambda vs (list* values vs)))))
(lambda () 'kill) (lambda () 'shut)))
(define (custodian-managed-list* cust super)
(define ms (custodian-managed-list cust super))
(append-map
(λ (v)
(if (custodian? v)
(custodian-managed-list* v cust)
(list v)))
ms))
(define (call-with-limits sec mb thunk)
;; 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
(define parent-cust
(if (and mb memory-accounting?)
(make-custodian (current-custodian))
(current-custodian)))
(define cust (make-custodian parent-cust))
(define cust-box
(define-values [cust cust-box]
(if (and mb memory-accounting?)
;; memory limit, set on a new custodian so if there's an out-of-memory
;; error, the user's custodian is still alive
(begin
(custodian-limit-memory
parent-cust
(inexact->exact (round (* mb 1024 1024)))
parent-cust)
(make-custodian-box parent-cust #t))
#f))
(let ([c (make-custodian (current-custodian))])
(custodian-limit-memory c (inexact->exact (round (* mb 1024 1024))) c)
(values c (make-custodian-box c #t)))
(values (current-custodian) #f)))
(define timeout? #f)
(define timeout-t
(and sec
(thread (lambda ()
(define timeout-evt
(handle-evt
(alarm-evt (+ (current-inexact-milliseconds)
(* 1000 sec)))
(λ (a)
(set! timeout? #t))))
(let loop ()
(define ms (custodian-managed-list* cust parent-cust))
(define ts (filter thread? ms))
(sync
(if (empty? ts)
always-evt
(handle-evt
(apply choice-evt (map thread-dead-evt ts))
(λ _
(loop))))
timeout-evt))
(custodian-shutdown-all cust)))))
(define r
(parameterize ([current-custodian cust])
(nested thunk)))
(when timeout-t
(thread-wait timeout-t))
(if sec
(nested
(lambda ()
;; time limit
(when sec
(define t (current-thread))
(thread (lambda ()
(unless (sync/timeout sec t) (set! timeout? #t))
(kill-thread t))))
(thunk)))
(nested thunk))))
(cond [timeout? (set! r 'time)]
[(and cust-box (not (custodian-box-value cust-box)))
(if (memq r '(kill shut)) ; should always be 'shut
(set! r 'memory)
(format "cust died with: ~a" r))]) ; throw internal error below
(case r
[(kill)
(kill-thread (current-thread))]
[(shut)
(custodian-shutdown-all (current-custodian))]
[(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)
@ -443,11 +410,10 @@
(apply (car r) (cdr r))
(error 'call-with-limits "internal error in nested: ~e" r))]))
(define-syntax-rule (with-limits sec mb body ...)
(call-with-limits sec mb (lambda () body ...)))
(define-syntax-rule (with-timeout sec body ...)
(with-limits sec #f body ...))
(define-syntax with-limits
(syntax-rules ()
[(with-limits sec mb body ...)
(call-with-limits sec mb (lambda () body ...))]))
;; other resource utilities
@ -1060,8 +1026,7 @@
(define run-in-bg (mz/mr thread queue-callback))
(define bg-run->thread (if (sandbox-gui-available)
(lambda (ignored)
((mz/mr void eventspace-handler-thread)
(current-eventspace)))
((mz/mr void eventspace-handler-thread) (current-eventspace)))
values))
(define t (bg-run->thread (run-in-bg user-process)))
(set! user-done-evt (handle-evt t (lambda (_) (terminate+kill! #t #t))))