From 79f8636e1e1d7c141ab3d658b41d7e85964097c8 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 22 Nov 2013 14:25:58 -0700 Subject: [PATCH] Ensure that threads created within call-with-limits are accounted during the time/space limits --- .../scribblings/reference/sandbox.scrbl | 4 + .../racket-test/tests/racket/sandbox.rkt | 42 ++++++++++ .../racket-test/tests/racket/sandbox.rktl | 48 +++++++---- pkgs/sandbox-lib/racket/sandbox.rkt | 81 +++++++++++++------ 4 files changed, 136 insertions(+), 39 deletions(-) create mode 100644 pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rkt diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/sandbox.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/sandbox.scrbl index 2d318e3fe2..80c9f45805 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/sandbox.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/sandbox.scrbl @@ -1007,6 +1007,10 @@ 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?]) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rkt new file mode 100644 index 0000000000..ecd61d2d8a --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rkt @@ -0,0 +1,42 @@ +#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))))))))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rktl index 29c3ac99af..89dbf7e2a8 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rktl @@ -64,23 +64,39 @@ (or (regexp-match? re m) (list 'bad-exception-message: m))) x))) (define-syntax thunk (syntax-rules () [(thunk b ...) (lambda () b ...)])) - (define-syntax t - (syntax-rules (--eval-- --top-- => <= =err> 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 R more ...)] + (define-syntax (t stx) + (syntax-case stx (--eval-- --top-- => <= =err> 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 R more ...))] ;; last so it doesn't match the above - [(t -?- E more ...) (begin (t -?- E) (t -?- more ...))])) + [(t -?- E more ...) + (syntax/loc #'E (begin (t -?- E) (t -?- more ...)))])) (define (make-prog . lines) (apply string-append (map (lambda (l) (string-append l "\n")) lines))) diff --git a/pkgs/sandbox-lib/racket/sandbox.rkt b/pkgs/sandbox-lib/racket/sandbox.rkt index 4fe31764ad..a563dbd271 100644 --- a/pkgs/sandbox-lib/racket/sandbox.rkt +++ b/pkgs/sandbox-lib/racket/sandbox.rkt @@ -52,6 +52,7 @@ call-in-nested-thread* call-with-limits with-limits + with-timeout call-with-custodian-shutdown call-with-killing-threads exn:fail:sandbox-terminated? @@ -369,39 +370,71 @@ (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-values [cust cust-box] + (define parent-cust + (if (and mb memory-accounting?) + (make-custodian (current-custodian)) + (current-custodian))) + (define cust (make-custodian parent-cust)) + (define 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 - (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))) + (begin + (custodian-limit-memory + parent-cust + (inexact->exact (round (* mb 1024 1024))) + parent-cust) + (make-custodian-box parent-cust #t)) + #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]) - (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)))) + (nested thunk))) + (when timeout-t + (thread-wait timeout-t)) (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) @@ -410,10 +443,11 @@ (apply (car r) (cdr r)) (error 'call-with-limits "internal error in nested: ~e" r))])) -(define-syntax with-limits - (syntax-rules () - [(with-limits sec mb body ...) - (call-with-limits sec mb (lambda () body ...))])) +(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 ...)) ;; other resource utilities @@ -1026,7 +1060,8 @@ (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))))