diff --git a/collects/typed-racket/optimizer/tool/report.rkt b/collects/typed-racket/optimizer/tool/report.rkt index 0fcae2626f..907421f507 100644 --- a/collects/typed-racket/optimizer/tool/report.rkt +++ b/collects/typed-racket/optimizer/tool/report.rkt @@ -32,18 +32,44 @@ (generate-log this)))) +(define (log-output in done-chan) + (let loop () + (sync (handle-evt + (read-line-evt in 'linefeed) + (lambda (line) + (cond [(eof-object? line) (channel-put done-chan 'done)] + [else + (log-warning + (format "Optimization Coach Program Output: ~a" line)) + (loop)])))))) + (define (run-inside-optimization-coach-sandbox this thunk) (call-with-trusted-sandbox-configuration (lambda () - (define port-name (send this get-port-name)) - (parameterize ([current-namespace (make-base-namespace)] - [current-load-relative-directory - (if (path-string? port-name) - (let-values ([(base name _) (split-path port-name)]) - base) - (current-load-relative-directory))] - [read-accept-reader #t]) - (thunk))))) + (define port-name (send this get-port-name)) + ;; If the sandboxed program produces any output, log it as `warning'. + ;; Mimics what check-syntax does. + (define log-output? (log-level? (current-logger) 'warning)) + (define-values (log-in log-out) + (if log-output? (make-pipe) (values #f (open-output-nowhere)))) + (define log-done-chan (make-channel)) + (when log-output? (thread (lambda () (log-output log-in log-done-chan)))) + ;; Set up the environment. + (begin0 + (parameterize + ([current-namespace (make-base-namespace)] + [current-load-relative-directory + (if (path-string? port-name) + (let-values ([(base name _) (split-path port-name)]) + base) + (current-load-relative-directory))] + [read-accept-reader #t] + [current-output-port log-out] + [current-error-port log-out]) + (thunk)) + (when log-output? + (close-output-port log-out) + (sync log-done-chan)))))) (define (generate-log this) (define portname (send this get-port-name))