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

nice memory printout

Browse Source 
svn: r12052
This commit is contained in:
Eli Barzilay 2008-10-17 08:36:29 +00:00
parent c1d1405150
commit 33bfa42df4
1 changed files with 38 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
collects/handin-server/main.ss
View File

@ -546,35 +546,42 @@
(define session-channel (make-channel)) (define session-channel (make-channel))
(define timeout #f) (define timeout #f)
(define status-box (box #f)) (define status-box (box #f))
(define (watch-loop timed-out?) (define (mem m)
(cond [(sync/timeout 3 session-thread) (let loop ([m m] [q 'B] [qs '(KB MB GB TB)])
(let* ([status (unbox status-box)] (if (and (>= m 1024) (pair? qs))
[status (if status (format " while ~a" status) "")]) (loop (round (/ m 1024)) (car qs) (cdr qs))
(log-line "session killed ~a~a" (format "~a~a" m q))))
(if timed-out? "(timeout) " "(memory)") (define (watch-loop)
status) (define session-thread (channel-get session-channel))
(write+flush (let loop ([timed-out? #f])
w (format "handin terminated due to ~a ~a~a" (cond [(sync/timeout 3 session-thread)
(if timed-out? "time limit" "excessive memory use") (let* ([status (unbox status-box)]
"(program doesn't terminate?)" [status (if status (format " while ~a" status) "")])
status)) (log-line "session killed ~a~a"
(close-output-port w) (if timed-out? "(timeout) " "(memory)")
(channel-put session-channel 'done))] status)
[(let ([t timeout]) ; grab value to avoid races (write+flush
(and t ((current-inexact-milliseconds) . > . t))) w (format "handin terminated due to ~a ~a~a"
;; Shutdown here to get the handin-terminated error (if timed-out? "time limit" "excessive memory use")
;; message, instead of relying on a timeout at the "(program doesn't terminate?)"
;; run-server level status))
(custodian-shutdown-all session-cust) (close-output-port w)
(watch-loop #t)] (channel-put session-channel 'done))]
[else (collect-garbage) [(let ([t timeout]) ; grab value to avoid races
(log-line "running ~a ~a" (and t ((current-inexact-milliseconds) . > . t)))
(current-memory-use session-cust) ;; Shutdown here to get the handin-terminated error
(if no-limit-warning? ;; message, instead of relying on a timeout at the
"(total)" ;; run-server level
(list (current-memory-use orig-custodian) (custodian-shutdown-all session-cust)
(current-memory-use)))) (loop #t)]
(watch-loop #f)])) [else (collect-garbage)
(log-line "running ~a ~a"
(mem (current-memory-use session-cust))
(if no-limit-warning?
"(total)"
(list (mem (current-memory-use orig-custodian))
(mem (current-memory-use)))))
(loop #f)])))
(define (timeout-control msg) (define (timeout-control msg)
(if (rational? msg) (if (rational? msg)
(set! timeout (+ (current-inexact-milliseconds) (* 1000 msg))) (set! timeout (+ (current-inexact-milliseconds) (* 1000 msg)))
@ -592,12 +599,8 @@
"not supported by MrEd"))]) "not supported by MrEd"))])
(custodian-limit-memory (custodian-limit-memory
session-cust (get-conf 'session-memory-limit) session-cust))) session-cust (get-conf 'session-memory-limit) session-cust)))
(let ([watcher (let ([watcher (parameterize ([current-custodian orig-custodian])
(parameterize ([current-custodian orig-custodian]) (thread watch-loop))])
(thread
(lambda ()
(let ([session-thread (channel-get session-channel)])
(watch-loop #f)))))])
;; Run proc in a thread under session-cust: ;; Run proc in a thread under session-cust:
(let ([session-thread (let ([session-thread
(parameterize ([current-custodian session-cust] (parameterize ([current-custodian session-cust]