From 50402756cfe555d104c9cef6affc876f25a95b58 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 26 Nov 2013 10:39:42 -0700 Subject: [PATCH] Revert "Ensure that threads created within call-with-limits are accounted during the time/space limits" This reverts commit 79f8636e1e1d7c141ab3d658b41d7e85964097c8. --- .../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, 39 insertions(+), 136 deletions(-) delete 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 80c9f45805..2d318e3fe2 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/sandbox.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/sandbox.scrbl @@ -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?]) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rkt deleted file mode 100644 index ecd61d2d8a..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rkt +++ /dev/null @@ -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))))))))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rktl index 89dbf7e2a8..29c3ac99af 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rktl @@ -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> 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 ...))] + (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 ...)] ;; 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))) diff --git a/pkgs/sandbox-lib/racket/sandbox.rkt b/pkgs/sandbox-lib/racket/sandbox.rkt index a563dbd271..4fe31764ad 100644 --- a/pkgs/sandbox-lib/racket/sandbox.rkt +++ b/pkgs/sandbox-lib/racket/sandbox.rkt @@ -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))))