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

This reverts commit 79f8636e1e.

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?])

pkgs/racket-pkgs/racket-test/tests/racket/sandbox.rkt

@@ -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)))))))))

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)
+  (define-syntax t
-    (syntax-case stx (--eval-- --top-- => <= =err> <err=)
+    (syntax-rules (--eval-- --top-- => <= =err> <err=)
-      [(t -?-) 
+      [(t -?-) (void)]
-       (syntax/loc stx (void))]
+      [(t -?- --eval-- more ...) (t --eval-- more ...)]
-      [(t -?- --eval-- more ...)
+      [(t -?- --top--  more ...) (t --top--  more ...)]
-       (syntax/loc #'--eval-- (t --eval-- more ...))]
+      [(t --eval-- E)         (test #t            run* (thunk (ev `E)))]
-      [(t -?- --top--  more ...)
+      [(t --top--  E)         (test #t            run* (thunk E))]
-       (syntax/loc #'--top-- (t --top--  more ...))]
+      [(t --eval-- E => R)    (test `(vals: ,R)   run  (thunk (ev `E)))]
-      [(t --eval-- E)
+      [(t --top--  E => R)    (test `(vals: ,R)   run  (thunk E))]
-       (syntax/loc #'E (test #t            run* (thunk (ev `E))))]
+      [(t --eval-- E =err> R) (test #t e-match? R run  (thunk (ev `E)))]
-      [(t --top--  E)         
+      [(t --top--  E =err> R) (test #t e-match? R run  (thunk E))]
-       (syntax/loc #'E (test #t            run* (thunk E)))]
+      [(t -?- E => R more ...)    (begin (t -?- E => R) (t -?- more ...))]
-      [(t --eval-- E => R)
+      [(t -?- E =err> R more ...) (begin (t -?- E =err> R) (t -?- more ...))]
-       (syntax/loc #'E (test `(vals: ,R)   run  (thunk (ev `E))))]
+      [(t -?- R <= E more ...)    (t -?- E => R more ...)]
-      [(t --top--  E => R)
+      [(t -?- R <err= E more ...) (t E =err> R more ...)]
-       (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 ...))]
       ;; last so it doesn't match the above
-      [(t -?- E more ...)
+      [(t -?- E more ...) (begin (t -?- E) (t -?- more ...))]))
-       (syntax/loc #'E (begin (t -?- E) (t -?- more ...)))]))
   (define (make-prog . lines)
     (apply string-append (map (lambda (l) (string-append l "\n")) lines)))
 

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
+  (define-values [cust cust-box]
-    (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
-      (begin
+      (let ([c (make-custodian (current-custodian))])
-        (custodian-limit-memory 
+        (custodian-limit-memory c (inexact->exact (round (* mb 1024 1024))) c)
-         parent-cust 
+        (values c (make-custodian-box c #t)))
-         (inexact->exact (round (* mb 1024 1024)))
+      (values (current-custodian) #f)))
-         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])
-      (nested thunk)))
+      (if sec
-  (when timeout-t
+        (nested
-    (thread-wait timeout-t))
+         (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) (kill-thread (current-thread))]
-     (kill-thread (current-thread))]
+    [(shut) (custodian-shutdown-all (current-custodian))]
-    [(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 ...)
+(define-syntax with-limits
-  (call-with-limits sec mb (lambda () body ...)))
+  (syntax-rules ()
-
+    [(with-limits sec mb body ...)
-(define-syntax-rule (with-timeout sec body ...)
+     (call-with-limits sec mb (lambda () body ...))]))
-  (with-limits sec #f 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)
+                                 ((mz/mr void eventspace-handler-thread) (current-eventspace)))
-                                  (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))))