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

cs: reliable GC callbacks on major GCs

Browse Source 
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.
This commit is contained in:
Matthew Flatt 2020-03-23 17:33:48 -06:00
parent 4a62408b71
commit 9222a135c3
5 changed files with 50 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -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]))

2
racket/src/cs/compile-file.ss
View File

@ -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

34
racket/src/cs/rumble/async-callback.ss
View File

@ -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)])))))

38
racket/src/cs/rumble/memory.ss
View File

@ -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:

2
racket/src/racket/src/schvers.h
View File

@ -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