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

svn: r7123

collects/mzlib/sandbox.ss

@@ -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)]
+    (let ([r #f]
-          [ch   (make-channel)]
+          [c (make-custodian)]
-          ;; use this to copy parameter changes from the sub-thread
+          ;; 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))
+        (custodian-limit-memory c (* mb 1024 1024) c))
-      (let* ([work (parameterize ([current-custodian cust])
+      (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 ()
-                               (channel-put ch
+                         (sleep sec)
-                                 (with-handlers ([void (lambda (e)
+                         ;; even in this case there are no parameters
-                                                         (list (p) raise e))])
+                         ;; to copy, since it is on a different thread
-                                   (call-with-values thunk
+                         (set! r (cons #f 'time))
-                                       (lambda vs (list* (p) values vs))))))))]
+                         (kill-thread this))))
-             [watch (thread (lambda ()
+             (set! r
-                              (channel-put ch
+               (with-handlers ([void (lambda (e) (list (p) raise e))])
-                                (if (sync/timeout sec work) 'memory 'time))))]
+                 (call-with-values thunk (lambda vs (list* (p) values vs)))))
-             [r (channel-get ch)])
+             (kill-thread timer))))
-        (custodian-shutdown-all cust)
+        (custodian-shutdown-all c)
-        (kill-thread watch)
+        (unless r (error 'call-with-limits "internal error"))
-        (if (list? r)
         ;; apply parameter changes first
-          (begin (p (car r)) (apply (cadr r) (cddr r)))
+        (when (car r) (p (car r)))
-          (raise (make-exn:fail:resource (format "with-limit: out of ~a" 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)]

collects/tests/mzscheme/sandbox.ss

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