From 93492c90b62286cf5ec1eb3e2a7b653f74ff4f35 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 23 Apr 2007 23:36:30 +0000 Subject: [PATCH] added a memory limit option svn: r6027 --- collects/drscheme/private/main.ss | 4 +++ collects/drscheme/private/rep.ss | 45 +++++++++++++---------- collects/drscheme/private/unit.ss | 59 ++++++++++++++++++++++++++++++- 3 files changed, 88 insertions(+), 20 deletions(-) diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss index 9320651af1..1c299dc65f 100644 --- a/collects/drscheme/private/main.ss +++ b/collects/drscheme/private/main.ss @@ -58,6 +58,10 @@ (finder:default-filters))) (application:current-app-name (string-constant drscheme)) + (preferences:set-default 'drscheme:limit-memory #f + (λ (x) (or (boolean? x) + (integer? x) + (x . >= . (* 1024 1024 100))))) (preferences:set-default 'drscheme:recent-language-names null diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index ac784ad53d..cc389f75b7 100644 --- a/collects/drscheme/private/rep.ss +++ b/collects/drscheme/private/rep.ss @@ -896,6 +896,14 @@ TODO (field (user-language-settings #f) (user-teachpack-cache (preferences:get 'drscheme:teachpacks)) (user-custodian #f) + (custodian-limit (and (with-handlers ([exn:fail:unsupported? (λ (x) #f)]) + (let ([c (make-custodian)]) + (custodian-limit-memory + c + 100 + c)) + #t) + (preferences:get 'drscheme:limit-memory))) (user-eventspace-box (make-weak-box #f)) (user-namespace-box (make-weak-box #f)) (user-eventspace-main-thread #f) @@ -913,9 +921,9 @@ TODO (define/public (get-user-thread) user-eventspace-main-thread) (define/public (get-user-namespace) (weak-box-value user-namespace-box)) (define/pubment (get-user-break-parameterization) user-break-parameterization) ;; final method - + (define/pubment (get-custodian-limit) custodian-limit) + (define/pubment (set-custodian-limit c) (set! custodian-limit c)) (field (in-evaluation? #f) - (should-collect-garbage? #f) (ask-about-kill? #f)) (define/public (get-in-evaluation?) in-evaluation?) @@ -1033,9 +1041,6 @@ TODO (send context reset-offer-kill) (send context set-breakables (get-user-thread) (get-user-custodian)) (reset-pretty-print-width) - (when should-collect-garbage? - (set! should-collect-garbage? #f) - (collect-garbage)) (set! in-evaluation? #t) (update-running #t) (set! need-interaction-cleanup? #t) @@ -1140,7 +1145,8 @@ TODO (set! user-language-settings (send definitions-text get-next-settings)) (set! user-custodian (make-custodian)) - ; (custodian-limit-memory user-custodian 10000000 user-custodian) + (when custodian-limit + (custodian-limit-memory user-custodian custodian-limit user-custodian)) (let ([user-eventspace (parameterize ([current-custodian user-custodian]) (make-eventspace))]) (set! user-eventspace-box (make-weak-box user-eventspace)) @@ -1168,18 +1174,20 @@ TODO (let ([drscheme-exit-handler (λ (x) - (let ([s (make-semaphore)]) - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (λ () - (set! user-exit-code - (if (and (integer? x) - (<= 0 x 255)) - x - 0)) - (semaphore-post s)))) - (semaphore-wait s) - (custodian-shutdown-all user-custodian)))]) + (parameterize-break + #f + (let ([s (make-semaphore)]) + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () + (set! user-exit-code + (if (and (integer? x) + (<= 0 x 255)) + x + 0)) + (semaphore-post s)))) + (semaphore-wait s) + (custodian-shutdown-all user-custodian))))]) (exit-handler drscheme-exit-handler)) (initialize-parameters snip-classes)))) @@ -1411,7 +1419,6 @@ TODO (clear-box-input-port) (clear-output-ports) (set-allow-edits #t) - (set! should-collect-garbage? #t) ;; in case the last evaluation thread was killed, clean up some state. (lock #f) diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index ca523a0e64..645f253b90 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -1630,9 +1630,63 @@ module browser threading seems wrong. (preferences:get 'framework:print-output-mode))))) (super file-menu:between-print-and-close file-menu)) + (define limit-memory-menu-item #f) + (define/override (edit-menu:between-find-and-preferences edit-menu) (super edit-menu:between-find-and-preferences edit-menu) - (add-modes-submenu edit-menu)) + (add-modes-submenu edit-menu) + (when (with-handlers ([exn:fail:unsupported? (λ (x) #f)]) + (let ([c (make-custodian)]) + (custodian-limit-memory + c + 100 + c)) + #t) + (set! limit-memory-menu-item + (new menu-item% + [label ""] + [parent edit-menu] + [callback + (λ (item b) + (let ([current-limit (send interactions-text get-custodian-limit)]) + (cond + [current-limit + (preferences:set 'drscheme:limit-memory #f) + (send interactions-text set-custodian-limit #f)] + [else + (let ([num-str + (get-text-from-user + (string-constant drscheme) + (string-append + "Please choose a limit, in megabytes\n" + "The limit will take effect on the next Run of the program.") + this + (format "~a" (* 1/2 1024)))]) + (when num-str + (let ([num (string->number num-str)]) + (cond + [(and num + (integer? num) + (num . >= . 100)) + (preferences:set 'drscheme:limit-memory (* 1024 1024 num)) + (send interactions-text set-custodian-limit (* 1024 1024 num))] + [else + (message-box (string-constant drscheme) + "Expected a positive integer (as a series of digits without commas) that is greater than 100" + this)]))))]) + (update-limit-memory-menu-item-label + (send interactions-text get-custodian-limit))))]))) + + (update-limit-memory-menu-item-label (preferences:get 'drscheme:limit-memory))) + + (define/private (update-limit-memory-menu-item-label limit) + (when limit-memory-menu-item + (send limit-memory-menu-item set-label + (if limit + (format "Disable memory limit (currently ~a megabytes)" + (floor (/ limit 1024 1024))) + "Limit memory...")))) + ; @@ -2227,6 +2281,9 @@ module browser threading seems wrong. (send from-defs set-delegate #f) (send to-defs set-delegate delegate))) + (update-limit-memory-menu-item-label + (send interactions-text get-custodian-limit)) + (inner (void) on-tab-change from-tab to-tab)) (define/public (next-tab) (change-to-delta-tab +1))