From 9222a135c38494ec3eca12a89689e7016aec99c9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 23 Mar 2020 17:33:48 -0600 Subject: [PATCH] cs: reliable GC callbacks on major GCs A Chez Scheme garbage collection involves a rendezvous among threads that are used to implement places and futures (and potentially other things that create Chez-level threads). The thread that is used to drive the garbage collection was not formerly specified, and callbacks like the GC icon in DrRacket can only be run in the initial thread. When a major collection was run in a non-initial thread, the callback was simply skipped. The Racket branch of Chez Scheme now drives a collection in the initial thread whenever that thread is active. In Racket CS, the initial thread can be inactive if it's waiting for external events, and a place can meanwhile trigger a GC. Now, when the Racket CS GC callback is called for a major collection in any thread other than the initial one, it defers the major collection to an asynchornous callback in the main thread (and meanwhile performs a minor collection). So, a major collection might now be delayed by just a little while if the main thread is inactive, such as when it's waiting for external events, but callbacks like the GC icon in DrRacket will be reliably invoked for major collections. --- pkgs/base/info.rkt | 2 +- racket/src/cs/compile-file.ss | 2 +- racket/src/cs/rumble/async-callback.ss | 34 ++++++++++++++++------- racket/src/cs/rumble/memory.ss | 38 ++++++++++++++++---------- racket/src/racket/src/schvers.h | 2 +- 5 files changed, 50 insertions(+), 28 deletions(-) diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index dfeb9a4562..84ed5963a0 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "7.6.0.17") +(define version "7.6.0.18") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/racket/src/cs/compile-file.ss b/racket/src/cs/compile-file.ss index 1e695afe4e..4bbc59a803 100644 --- a/racket/src/cs/compile-file.ss +++ b/racket/src/cs/compile-file.ss @@ -2,7 +2,7 @@ ;; Check to make we're using a build of Chez Scheme ;; that has all the features we need. (define-values (need-maj need-min need-sub need-dev) - (values 9 5 3 23)) + (values 9 5 3 24)) (unless (guard (x [else #f]) (eval 'scheme-fork-version-number)) (error 'compile-file diff --git a/racket/src/cs/rumble/async-callback.ss b/racket/src/cs/rumble/async-callback.ss index 1d14b6fdc8..59466513e8 100644 --- a/racket/src/cs/rumble/async-callback.ss +++ b/racket/src/cs/rumble/async-callback.ss @@ -1,5 +1,5 @@ -(define-record async-callback-queue (lock condition in wakeup)) +(define-record async-callback-queue (lock condition in gc? wakeup)) (define (current-async-callback-queue) (place-async-callback-queue)) @@ -8,6 +8,7 @@ (place-async-callback-queue (make-async-callback-queue (make-mutex) ; ordered *before* `interrupts-disable`-as-lock (make-condition) '() + #f ;; Reset by `reset-async-callback-poll-wakeup!`: void))) @@ -46,6 +47,12 @@ (when interrupts-disabled? (enable-interrupts)) result)) +;; Called with all threads all stopped: +(define (async-callback-queue-major-gc!) + (let ([q orig-place-async-callback-queue]) + (set-async-callback-queue-gc?! q #t) + ((async-callback-queue-wakeup q)))) + (define make-async-callback-poll-wakeup (lambda () void)) (define (set-make-async-callback-poll-wakeup! make-wakeup) (set! make-async-callback-poll-wakeup make-wakeup) @@ -58,12 +65,19 @@ (define (poll-async-callbacks) (let ([q (current-async-callback-queue)]) (mutex-acquire (async-callback-queue-lock q)) - (let ([in (async-callback-queue-in q)]) - (cond - [(null? in) - (mutex-release (async-callback-queue-lock q)) - '()] - [else - (set-async-callback-queue-in! q '()) - (mutex-release (async-callback-queue-lock q)) - (reverse in)])))) + (let ([in (async-callback-queue-in q)] + [gc? (async-callback-queue-gc? q)]) + (append + (cond + [gc? + (set-async-callback-queue-gc?! q #f) + (list collect-garbage)] + [else '()]) + (cond + [(null? in) + (mutex-release (async-callback-queue-lock q)) + '()] + [else + (set-async-callback-queue-in! q '()) + (mutex-release (async-callback-queue-lock q)) + (reverse in)]))))) diff --git a/racket/src/cs/rumble/memory.ss b/racket/src/cs/rumble/memory.ss index d598f0bb36..c4678f10f6 100644 --- a/racket/src/cs/rumble/memory.ss +++ b/racket/src/cs/rumble/memory.ss @@ -61,20 +61,28 @@ (if (> (add1 this-counter) (bitwise-arithmetic-shift-left 1 (* log-collect-generation-radix (sub1 (collect-maximum-generation))))) (set! gc-counter 1) (set! gc-counter (add1 this-counter))) - (let ([gen (cond - [(and (not g) - (or (>= pre-allocated trigger-major-gc-allocated) - (>= pre-allocated+overhead trigger-major-gc-allocated+overhead) - (>= non-full-gc-counter 10000))) - ;; Force a major collection if memory use has doubled - (collect-maximum-generation)] - [else - ;; Find the minor generation implied by the counter - (let loop ([c this-counter] [gen 0]) - (cond - [(zero? (bitwise-and c collect-generation-radix-mask)) - (loop (bitwise-arithmetic-shift-right c log-collect-generation-radix) (add1 gen))] - [else gen]))])]) + (let* ([req-gen (cond + [(and (not g) + (or (>= pre-allocated trigger-major-gc-allocated) + (>= pre-allocated+overhead trigger-major-gc-allocated+overhead) + (>= non-full-gc-counter 10000))) + ;; Force a major collection if memory use has doubled + (collect-maximum-generation)] + [else + ;; Find the minor generation implied by the counter + (let loop ([c this-counter] [gen 0]) + (cond + [(zero? (bitwise-and c collect-generation-radix-mask)) + (loop (bitwise-arithmetic-shift-right c log-collect-generation-radix) (add1 gen))] + [else gen]))])] + [gen (cond + [(and (= req-gen (collect-maximum-generation)) + (not (in-original-host-thread?)) + (fxpositive? (hashtable-size collect-callbacks))) + ;; Defer a major collection to the main thread + (async-callback-queue-major-gc!) + 0] + [else req-gen])]) (run-collect-callbacks car) (collect gen) (let ([post-allocated (bytes-allocated)] @@ -100,7 +108,7 @@ pre-allocated pre-allocated+overhead pre-time pre-cpu-time post-allocated post-allocated+overhead post-time post-cpu-time (real-time) (cpu-time))) - (when (and (= gen (collect-maximum-generation)) + (when (and (= req-gen (collect-maximum-generation)) (currently-in-engine?)) ;; This `set-timer` doesn't necessarily penalize the right thread, ;; but it's likely to penalize a thread that is allocating quickly: diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index d5b1f0eb11..824f77f176 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -16,7 +16,7 @@ #define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_Y 6 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 17 +#define MZSCHEME_VERSION_W 18 /* A level of indirection makes `#` work as needed: */ #define AS_a_STR_HELPER(x) #x