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

better organization for running resource limited code

Browse Source 
svn: r12666
This commit is contained in:
Eli Barzilay 2008-12-01 21:28:28 +00:00
parent 0c2410739a
commit 12467b4ecd
1 changed files with 21 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
collects/scheme/sandbox.ss
View File

@ -382,16 +382,14 @@
(lambda (x) (abort-current-continuation deftag x))) (lambda (x) (abort-current-continuation deftag x)))
(loop (car exprs) (cdr exprs)))))))))) (loop (car exprs) (cdr exprs))))))))))
(define (evaluate-program program limits uncovered!) (define (evaluate-program program limit-thunk uncovered!)
(when uncovered! (when uncovered!
(eval `(,#'#%require scheme/private/sandbox-coverage))) (eval `(,#'#%require scheme/private/sandbox-coverage)))
;; the actual evaluation happens under specified limits, if given ;; the actual evaluation happens under the specified limits
(let ([run (if (and (pair? program) (eq? 'begin (car program))) ((limit-thunk (lambda ()
(lambda () (eval* (cdr program))) (if (and (pair? program) (eq? 'begin (car program)))
(lambda () (eval program)))] (eval* (cdr program))
[sec (and limits (car limits))] (eval program)))))
[mb (and limits (cadr limits))])
(if (or sec mb) (call-with-limits sec mb run) (run)))
(let ([ns (syntax-case* program (module) literal-identifier=? (let ([ns (syntax-case* program (module) literal-identifier=?
[(module mod . body) [(module mod . body)
(identifier? #'mod) (identifier? #'mod)
@ -453,7 +451,11 @@
(define error-output #f) (define error-output #f)
(define limits (sandbox-eval-limits)) (define limits (sandbox-eval-limits))
(define user-thread #t) ; set later to the thread (define user-thread #t) ; set later to the thread
(define orig-cust (current-custodian)) (define orig-cust (current-custodian))
(define (limit-thunk thunk)
(let* ([sec (and limits (car limits))]
[mb (and limits (cadr limits))])
(if (or sec mb) (lambda () (call-with-limits sec mb thunk)) thunk)))
(define (user-kill) (define (user-kill)
(when user-thread (when user-thread
(let ([t user-thread]) (let ([t user-thread])
@ -471,7 +473,7 @@
;; now read and evaluate the input program ;; now read and evaluate the input program
(evaluate-program (evaluate-program
(if (procedure? program-maker) (program-maker) program-maker) (if (procedure? program-maker) (program-maker) program-maker)
limits limit-thunk
(and coverage? (lambda (es+get) (set! uncovered es+get)))) (and coverage? (lambda (es+get) (set! uncovered es+get))))
(channel-put result-ch 'ok)) (channel-put result-ch 'ok))
;; finally wait for interaction expressions ;; finally wait for interaction expressions
@ -481,20 +483,15 @@
(when (eof-object? expr) (channel-put result-ch expr) (user-kill)) (when (eof-object? expr) (channel-put result-ch expr) (user-kill))
(with-handlers ([void (lambda (exn) (with-handlers ([void (lambda (exn)
(channel-put result-ch (cons 'exn exn)))]) (channel-put result-ch (cons 'exn exn)))])
(let* ([run (if (evaluator-message? expr) (define run
(lambda () (limit-thunk (if (evaluator-message? expr)
(apply (evaluator-message-msg expr) (lambda ()
(evaluator-message-args expr))) (apply (evaluator-message-msg expr)
(lambda () (evaluator-message-args expr)))
(set! n (add1 n)) (lambda ()
(eval* (input->code (list expr) 'eval n))))] (set! n (add1 n))
[sec (and limits (car limits))] (eval* (input->code (list expr) 'eval n))))))
[mb (and limits (cadr limits))] (channel-put result-ch (cons 'vals (call-with-values run list))))
[run (if (or sec mb)
(lambda () (with-limits sec mb (run)))
run)])
(channel-put result-ch
(cons 'vals (call-with-values run list)))))
(loop))))) (loop)))))
(define (user-eval expr) (define (user-eval expr)
(let ([r (if user-thread (let ([r (if user-thread