diff --git a/pkgs/racket-test/tests/racket/place-channel-limits.rkt b/pkgs/racket-test/tests/racket/place-channel-limits.rkt index 7bbe38e714..4c87d94c8f 100644 --- a/pkgs/racket-test/tests/racket/place-channel-limits.rkt +++ b/pkgs/racket-test/tests/racket/place-channel-limits.rkt @@ -5,9 +5,10 @@ ;; * allocating shared arrays, and ;; * putting messages into an channel with no receiver -(define (check shared?) +(define (check mode) (for ([i 20]) (printf "iter ~a\n" i) + (collect-garbage) (let ([c (make-custodian)]) (custodian-limit-memory c (* 1024 1024 10) c) (parameterize ([current-custodian c]) @@ -15,10 +16,21 @@ (thread (lambda () (define-values (a b) (place-channel)) - (for/fold ([v 0]) ([i (in-range 999999999)]) - (if shared? - (cons (make-shared-bytes 1024) v) - (place-channel-put b (list 1 2 3 4))))))))))) + (list + (for/fold ([v 0]) ([i (in-range 999999999)]) + (case mode + [(bytes) + ;; Not really about places or channels, but worth checking, too + (cons (make-bytes 1024) v)] + [(shared-bytes) + (cons (make-shared-bytes 1024) v)] + [(messages) + (place-channel-put b (list 1 2 3 4 (make-vector 500)))])) + (log-error "shouldn't get done") + ;; Remember `a`, just in case the runtime system is smart + ;; enough to discard messages that have no destination + a)))))))) -(check #t) -(check #t) +(check 'bytes) +(check 'shared-bytes) +(check 'messages) diff --git a/racket/src/racket/src/thread.c b/racket/src/racket/src/thread.c index c605116bcb..500e49132c 100644 --- a/racket/src/racket/src/thread.c +++ b/racket/src/racket/src/thread.c @@ -2039,6 +2039,8 @@ void scheme_schedule_custodian_close(Scheme_Custodian *c) static void check_scheduled_kills() { + int force_gc = 0; + if (scheme_no_stack_overflow) { /* don't shutdown something that may be in an atomic callback */ return; @@ -2049,6 +2051,16 @@ static void check_scheduled_kills() k = SCHEME_CAR(scheduled_kills); scheduled_kills = SCHEME_CDR(scheduled_kills); do_close_managed((Scheme_Custodian *)k); + force_gc = 1; + } + + if (force_gc) { + /* A shutdown in response to a memory limit merits another major + GC to clean up and reset the expected heap size. Otherwise, if + another limit is put in place, it will be checked (on a major + GC) even later, which will set the major-GC trigger even + higher, and so on. */ + scheme_collect_garbage(); } } diff --git a/racket/src/thread/custodian.rkt b/racket/src/thread/custodian.rkt index ed31f76af5..ed68a49f3e 100644 --- a/racket/src/thread/custodian.rkt +++ b/racket/src/thread/custodian.rkt @@ -256,6 +256,12 @@ (for ([c (in-list queued)] #:when (custodian-this-place? c)) (do-custodian-shutdown-all c)) + ;; A shutdown in response to a memory limit merits another + ;; major GC to clean up and reset the expected heap size. + ;; Otherwise, if another limit is put in place, it will be + ;; checked (on a major GC) even later, which will set the + ;; major-GC trigger even higher, and so on. + (collect-garbage) #t])) (define place-ensure-wakeup! (lambda () #f)) ; call before enabling shutdowns