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.

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
+@scheme[_v]. In addition, for the @3m[] and @CGC[] variants of Racket,
-before a will for @racket[_v] is readied by the late will
+normal weak references to @scheme[_v] are cleared before a will for
-executor.
+@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
+A late will executor is intended for use in the implementation of
-@racket[register-finalizer]. See also @racket[make-late-weak-box] and
+@racket[register-finalizer].}
-@racket[make-late-weak-hasheq].}

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
+The values managed by a custodian are semi-weakly held by the
-custodian. As a result, a @techlink{will} can be executed for a value that
+custodian: a @techlink{will} can be executed for a value that is
-is managed by a custodian. In addition, a custodian only weakly
+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

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)
+    (test #t andmap (lambda (v)
-                      ((current-memory-use c) . >= . 100000))
+                      (v . >= . 100000))
-          c)))
+          (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)

racket/src/cs/rumble/memory.ss

@@ -286,6 +286,10 @@
      #%procedure?]
     [(eq? 'ephemeron (car args))
      ephemeron-pair?]
+    [(eq? '<ffi-lib> (car args))
+     ffi-lib?]
+    [(eq? '<will-executor> (car args))
+     will-executor?]
     [(eq? 'metacontinuation-frame (car args))
      metacontinuation-frame?]
     [(symbol? (car args))

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)
+(define (make-late-will-executor/notify notify [keep? #t])
-  (do-make-will-executor/notify make-stubborn-will-executor notify))
+  (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

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)

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
+;; the managed objects into the parent. To support multiple moves,
-;; not currently implemented
+;; `c` can be another reference
-(struct custodian-reference (c)
+(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
+;; finalizer; in that case, if `obj` is exposed to safe code, it can
-;; that might see `obj` after finalization through a weak reference
+;; have its own finalizers, but weak boxes or hashtable references will
-;; (and detect that `obj` is thereafter retained strongly).
+;; not be cleared until the value is explicitly shut down.
-(define (do-custodian-register cust obj callback at-exit? weak? gc-root?)
+(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
+        ;; Registering with a will executor that we retain but never
-        ;; effect of turning a weak reference into a strong one when
+        ;; poll has the effect of turning a semi-weak reference
-        ;; there are no other references:
+        ;; (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)
   

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

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)