From 151b5755c5173bae2c2716f74be8789e353eb4e7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 3 May 2019 18:19:28 -0600 Subject: [PATCH] cs: repairs for inaccessible custodians and custodian boxes Allows an inaccessible custodian to be GCed, promoting any values that it manages to its parent custodian. Also repair memory accounting for custodian boxes. For values referenced by a custodian, the nature of the custodian's weak references is slightly different on Racket CS. The reference is weak enough that the value can be finalized via will (e.g., to close an unused port), but it's not weak enough to allow weak boxes, weak hash table keys, or ephemeron keys to be cleared. That's a consequence of using ordered finalization instead of finalization/weakness levels. This difference could be avoided at the cost of an extra wrapper for any finalized value and a discipline of using such wrappers as the user-visible reference for all custodian-managed values, but semi-weak references so far appear to be practical and a better compromise. --- .../scribblings/foreign/unexported.scrbl | 13 ++- .../scribblings/reference/eval-model.scrbl | 9 +- pkgs/racket-test-core/tests/racket/will.rktl | 25 ++++- racket/src/cs/rumble/memory.ss | 4 + racket/src/thread/bootstrap.rkt | 8 +- racket/src/thread/custodian-object.rkt | 6 +- racket/src/thread/custodian.rkt | 106 ++++++++++++++---- racket/src/thread/place.rkt | 2 +- racket/src/thread/schedule.rkt | 1 + 9 files changed, 131 insertions(+), 43 deletions(-) diff --git a/pkgs/racket-doc/scribblings/foreign/unexported.scrbl b/pkgs/racket-doc/scribblings/foreign/unexported.scrbl index 622e61f167..d71758c814 100644 --- a/pkgs/racket-doc/scribblings/foreign/unexported.scrbl +++ b/pkgs/racket-doc/scribblings/foreign/unexported.scrbl @@ -97,14 +97,15 @@ A predicate for callback values that are created by @racket[ffi-callback]. Creates a ``late'' will executor that readies a will for a value @scheme[_v] only if no normal will executor has a will registered for -@scheme[_v]. In addition, weak references to @scheme[_v] are cleared -before a will for @racket[_v] is readied by the late will -executor. +@scheme[_v]. In addition, for the @3m[] and @CGC[] variants of Racket, +normal weak references to @scheme[_v] are cleared before a will for +@racket[_v] is readied by the late will executor, but late weak +references created by @racket[make-late-weak-box] and +@racket[make-late-weak-hasheq] are not. Unlike a normal will executor, if a late will executor becomes inaccessible, the values for which it has pending wills are retained within the late will executor's place. -A late will executor is intended for use only in the implementation of -@racket[register-finalizer]. See also @racket[make-late-weak-box] and -@racket[make-late-weak-hasheq].} +A late will executor is intended for use in the implementation of +@racket[register-finalizer].} diff --git a/pkgs/racket-doc/scribblings/reference/eval-model.scrbl b/pkgs/racket-doc/scribblings/reference/eval-model.scrbl index 8002874680..0928ce6949 100644 --- a/pkgs/racket-doc/scribblings/reference/eval-model.scrbl +++ b/pkgs/racket-doc/scribblings/reference/eval-model.scrbl @@ -1069,9 +1069,12 @@ has multiple custodians, it is not necessarily killed by a from the thread's managing custodian set, and the thread is killed when its managing set becomes empty. -The values managed by a custodian are only weakly held by the -custodian. As a result, a @techlink{will} can be executed for a value that -is managed by a custodian. In addition, a custodian only weakly +The values managed by a custodian are semi-weakly held by the +custodian: a @techlink{will} can be executed for a value that is +managed by a custodian; in addition, weak references via weak +@tech{hash tables}, @tech{ephemerons}, or @tech{weak box}es can be +dropped on the 3m or CGC variants of Racket, but not on the CS +variant. For all variants, a custodian only weakly references its subordinate custodians; if a subordinate custodian is unreferenced but has its own subordinates, then the custodian may be garbage collected, at which point its subordinates become immediately diff --git a/pkgs/racket-test-core/tests/racket/will.rktl b/pkgs/racket-test-core/tests/racket/will.rktl index 847e0a42a3..b7d5c6ebfb 100644 --- a/pkgs/racket-test-core/tests/racket/will.rktl +++ b/pkgs/racket-test-core/tests/racket/will.rktl @@ -125,9 +125,9 @@ c)]) ;; Each custodian must be charged at least 100000 bytes: (collect-garbage) - (test #t andmap (lambda (c) - ((current-memory-use c) . >= . 100000)) - c))) + (test #t andmap (lambda (v) + (v . >= . 100000)) + (map current-memory-use c)))) (let () (define c1 (make-custodian (current-custodian))) @@ -146,6 +146,25 @@ (custodian-shutdown-all c) (test #f ormap (lambda (b) (number? (custodian-box-value b))) l)))) +;; Check chain of unreachable custodians: +(let () + (define start-c (make-custodian)) + (define wbs+cbs + (let loop ([i 20] [parent start-c]) + (if (zero? i) + null + (let ([c (make-custodian parent)]) + (cons (cons (make-weak-box c) + (make-custodian-box c 'on)) + (loop (sub1 i) c)))))) + (collect-garbage) + (test #t < 10 (for/sum ([wb+cb (in-list wbs+cbs)]) + (if (weak-box-value (car wb+cb)) 1 0))) + (custodian-shutdown-all start-c) + (test #t andmap + (lambda (wb+cb) (not (custodian-box-value (cdr wb+cb)))) + wbs+cbs)) + ;; check synchronization again: (let () (define done #f) diff --git a/racket/src/cs/rumble/memory.ss b/racket/src/cs/rumble/memory.ss index f5cb1fdeaa..b4145d54b8 100644 --- a/racket/src/cs/rumble/memory.ss +++ b/racket/src/cs/rumble/memory.ss @@ -286,6 +286,10 @@ #%procedure?] [(eq? 'ephemeron (car args)) ephemeron-pair?] + [(eq? ' (car args)) + ffi-lib?] + [(eq? ' (car args)) + will-executor?] [(eq? 'metacontinuation-frame (car args)) metacontinuation-frame?] [(symbol? (car args)) diff --git a/racket/src/thread/bootstrap.rkt b/racket/src/thread/bootstrap.rkt index b0fc281110..61aff7cf1a 100644 --- a/racket/src/thread/bootstrap.rkt +++ b/racket/src/thread/bootstrap.rkt @@ -1,7 +1,7 @@ #lang racket/base (require '#%linklet (only-in '#%foreign - make-stubborn-will-executor) + make-late-will-executor) "../common/queue.rkt") ;; Simulate engines by using the host system's threads. @@ -122,8 +122,8 @@ (define (make-will-executor/notify notify) (do-make-will-executor/notify make-will-executor notify)) -(define (make-stubborn-will-executor/notify notify) - (do-make-will-executor/notify make-stubborn-will-executor notify)) +(define (make-late-will-executor/notify notify [keep? #t]) + (do-make-will-executor/notify make-late-will-executor notify)) (define (will-register/notify we/n v proc) (will-register (will-executor/notify-we we/n) @@ -239,7 +239,7 @@ 'continuation-marks continuation-marks ; doesn't work on engines 'poll-will-executors poll-will-executors 'make-will-executor make-will-executor/notify - 'make-stubborn-will-executor make-stubborn-will-executor/notify + 'make-late-will-executor make-late-will-executor/notify 'will-executor? will-executor/notify? 'will-register will-register/notify 'will-try-execute will-try-execute/notify diff --git a/racket/src/thread/custodian-object.rkt b/racket/src/thread/custodian-object.rkt index 71496304c7..8e316c4da2 100644 --- a/racket/src/thread/custodian-object.rkt +++ b/racket/src/thread/custodian-object.rkt @@ -11,6 +11,7 @@ [shutdown-sema #:mutable] [need-shutdown #:mutable] ; queued asynchronous shutdown: #f, 'needed, or 'needed/sent-wakeup [parent-reference #:mutable] + [self-reference #:mutable] [place #:mutable] ; place containing the custodian [memory-use #:mutable] ; set after a major GC [gc-roots #:mutable] ; weak references to charge to custodian; access without interrupts @@ -18,18 +19,19 @@ [immediate-limit #:mutable]) ; limit on immediate allocation #:authentic) -(define (create-custodian) +(define (create-custodian parent) (custodian (make-weak-hasheq) #f ; shut-down? #f ; shutdown semaphore #f ; need shutdown? #f ; parent reference + #f ; self reference #f ; place 0 ; memory use #f ; GC roots null ; memory limits #f)) ; immediate limit -(define initial-place-root-custodian (create-custodian)) +(define initial-place-root-custodian (create-custodian #f)) (define-place-local root-custodian initial-place-root-custodian) diff --git a/racket/src/thread/custodian.rkt b/racket/src/thread/custodian.rkt index 97b4701115..a5b009274b 100644 --- a/racket/src/thread/custodian.rkt +++ b/racket/src/thread/custodian.rkt @@ -1,6 +1,7 @@ #lang racket/base (require "custodian-object.rkt" "place-object.rkt" + "place-local.rkt" "check.rkt" "atomic.rkt" "host.rkt" @@ -39,7 +40,8 @@ (module+ scheduling (provide do-custodian-shutdown-all set-root-custodian! - create-custodian)) + create-custodian + poll-custodian-will-executor)) ;; For `(struct custodian ...)`, see "custodian-object.rkt" @@ -57,11 +59,13 @@ ;; Reporting registration in a custodian through this indirection ;; enables GCing custodians that aren't directly referenced, merging -;; the managed objects into the parent, although that posisbility is -;; not currently implemented -(struct custodian-reference (c) +;; the managed objects into the parent. To support multiple moves, +;; `c` can be another reference +(struct custodian-reference ([c #:mutable]) #:authentic) +(define-place-local custodian-will-executor (host:make-late-will-executor void #f)) + (define/who current-custodian (make-parameter root-custodian (lambda (v) @@ -71,11 +75,12 @@ ;; To initialize a new place: (define (set-root-custodian! c) (set! root-custodian c) - (current-custodian c)) + (current-custodian c) + (set! custodian-will-executor (host:make-late-will-executor void #f))) (define/who (make-custodian [parent (current-custodian)]) (check who custodian? parent) - (define c (create-custodian)) + (define c (create-custodian parent)) (set-custodian-place! c (custodian-place parent)) (define cref (do-custodian-register parent c ;; Retain children procs as long as proc for `c` @@ -83,9 +88,11 @@ (lambda (c) (reference-sink children) (do-custodian-shutdown-all c))) - #f #f #t)) + #:at-exit? #t + #:gc-root? #t)) (set-custodian-parent-reference! c cref) (unless cref (raise-custodian-is-shut-down who parent)) + (host:will-register custodian-will-executor c merge-custodian-into-parent) c) (define (unsafe-make-custodian-at-root) @@ -93,10 +100,13 @@ ;; The given `callback` will be run in atomic mode. ;; Unless `weak?` is true, the given `obj` is registered with an ordered -;; finalizer, so don't supply an `obj` that is exposed to safe code -;; that might see `obj` after finalization through a weak reference -;; (and detect that `obj` is thereafter retained strongly). -(define (do-custodian-register cust obj callback at-exit? weak? gc-root?) +;; finalizer; in that case, if `obj` is exposed to safe code, it can +;; have its own finalizers, but weak boxes or hashtable references will +;; not be cleared until the value is explicitly shut down. +(define (do-custodian-register cust obj callback + #:at-exit? [at-exit? #f] + #:weak? [weak? #f] + #:gc-root? [gc-root? #f]) (atomically (cond [(custodian-shut-down? cust) #f] @@ -110,9 +120,10 @@ [at-exit? (at-exit-callback callback we)] [else (willed-callback callback we)])) (when we - ;; Registering with a will executor that we never poll has the - ;; effect of turning a weak reference into a strong one when - ;; there are no other references: + ;; Registering with a will executor that we retain but never + ;; poll has the effect of turning a semi-weak reference + ;; (allows other finalizers, but doesn't clear weak boxes) + ;; into a strong one when there are no other references: (host:will-register we obj void)) (when gc-root? (host:disable-interrupts) @@ -120,21 +131,24 @@ (set-custodian-gc-roots! cust (make-weak-hasheq))) (hash-set! (custodian-gc-roots cust) obj #t) (host:enable-interrupts)) - (custodian-reference cust)]))) + (or (custodian-self-reference cust) + (let ([cref (custodian-reference cust)]) + (set-custodian-self-reference! cust cref) + cref))]))) (define (unsafe-custodian-register cust obj callback at-exit? weak?) - (do-custodian-register cust obj callback at-exit? weak? #f)) + (do-custodian-register cust obj callback #:at-exit? at-exit? #:weak? weak?)) (define (custodian-register-thread cust obj callback) - (do-custodian-register cust obj callback #f #t #t)) + (do-custodian-register cust obj callback #:weak? #t #:gc-root? #t)) (define (custodian-register-place cust obj callback) - (do-custodian-register cust obj callback #f #t #t)) + (do-custodian-register cust obj callback #:weak? #t #:gc-root? #t)) (define (unsafe-custodian-unregister obj cref) (when cref (atomically - (define c (custodian-reference-c cref)) + (define c (custodian-reference->custodian cref)) (unless (custodian-shut-down? c) (hash-remove! (custodian-children c) obj)) (host:disable-interrupts) @@ -144,6 +158,37 @@ (host:enable-interrupts)) (void))) +;; Called by scheduler (so atomic) when `c` is unreachable +(define (merge-custodian-into-parent c) + (unless (custodian-shut-down? c) + (define p-cref (custodian-parent-reference c)) + (define parent (custodian-reference->custodian p-cref)) + (define gc-roots (custodian-gc-roots c)) + (unsafe-custodian-unregister c p-cref) + (for ([(child callback) (in-hash (custodian-children c))]) + (define gc-root? (and gc-roots (hash-ref gc-roots child #f) #t)) + (cond + [(willed-callback? callback) + (do-custodian-register parent child (willed-callback-proc callback) + #:at-exit? (at-exit-callback? callback) + #:gc-root? gc-root?)] + [else + (do-custodian-register parent child callback + #:gc-root? gc-root?)])) + (define self-ref (custodian-self-reference c)) + (when self-ref + (set-custodian-reference-c! self-ref (custodian-self-reference parent))) + (hash-clear! (custodian-children c)) + (when gc-roots (hash-clear! gc-roots)))) + +;; Called in scheduler thread: +(define (poll-custodian-will-executor) + (cond + [(host:will-try-execute custodian-will-executor) + => (lambda (p) + ((car p) (cdr p)) + (poll-custodian-will-executor))])) + ;; Hook for thread scheduling: (define post-shutdown-action void) (define (set-post-shutdown-action! proc) @@ -219,7 +264,10 @@ (hash-clear! (custodian-children c)) (let ([sema (custodian-shutdown-sema c)]) (when sema - (semaphore-post-all sema))))) + (semaphore-post-all sema))) + (define p-cref (custodian-parent-reference c)) + (when p-cref + (unsafe-custodian-unregister c p-cref)))) (define (custodian-get-shutdown-sema c) (atomically @@ -232,19 +280,29 @@ (define (custodian-subordinate? c super-c) (let loop ([p-cref (custodian-parent-reference c)]) - (define p (and p-cref (custodian-reference-c p-cref))) + (define p (and p-cref (custodian-reference->custodian p-cref))) (cond [(eq? p super-c) #t] [(not p) #f] [else (loop (custodian-parent-reference p))]))) (define (custodian-manages-reference? c cref) - (define ref-c (custodian-reference-c cref)) + (define ref-c (custodian-reference->custodian cref)) (or (eq? c ref-c) (custodian-subordinate? ref-c c))) (define (custodian-reference->custodian cref) - (custodian-reference-c cref)) + (define c (custodian-reference-c cref)) + (cond + [(custodian-reference? c) + (define next-c (custodian-reference-c c)) + (cond + [(custodian-reference? next-c) + ;; shrink the chain + (set-custodian-reference-c! cref next-c) + (custodian-reference->custodian cref)] + [else next-c])] + [else c])) (define/who (custodian-managed-list c super-c) (check who custodian? c) @@ -288,7 +346,7 @@ (define/who (make-custodian-box c v) (check who custodian? c) (define b (custodian-box v (custodian-get-shutdown-sema c))) - (unless (unsafe-custodian-register c b (lambda (b) (set-custodian-box-v! b #f)) #f #t) + (unless (do-custodian-register c b (lambda (b) (set-custodian-box-v! b #f)) #:weak? #t #:gc-root? #t) (raise-custodian-is-shut-down who c)) b) diff --git a/racket/src/thread/place.rkt b/racket/src/thread/place.rkt index 0bc2eb737e..94f2cd00a8 100644 --- a/racket/src/thread/place.rkt +++ b/racket/src/thread/place.rkt @@ -43,7 +43,7 @@ (when (eq? initial-place current-place) ;; needed by custodian GC callback for memory limits: (atomically (ensure-wakeup-handle!))) - (define orig-cust (create-custodian)) + (define orig-cust (create-custodian #f)) (define lock (host:make-mutex)) (define started (host:make-condition)) (define-values (place-pch child-pch) (place-channel)) diff --git a/racket/src/thread/schedule.rkt b/racket/src/thread/schedule.rkt index 24b1811834..f18c7c7744 100644 --- a/racket/src/thread/schedule.rkt +++ b/racket/src/thread/schedule.rkt @@ -60,6 +60,7 @@ (host:poll-async-callbacks) pending-callbacks)) (host:poll-will-executors) + (poll-custodian-will-executor) (check-external-events 'fast) (call-pre-poll-external-callbacks) (check-place-activity)