cs: repair retention of a custodian with a memory limit

pkgs/racket-test-core/tests/racket/thread.rktl

@@ -176,6 +176,24 @@
 (err/rt-test (parameterize ([current-custodian cm]) (kill-thread (current-thread)))
 	     exn:application:mismatch?)
 
+;; Make sure a custodian is not retained just because there's
+;; a limit when it has no managed objects that can contribute
+;; to that limit
+(unless (eq? 'cgc (system-type 'gc))
+  (define c (make-custodian))
+  (define b (make-weak-box c))
+  (define c2 (make-custodian c))
+  (define cb (make-custodian-box c 'ok))
+  (define bb (make-weak-box cb))
+  (custodian-limit-memory c 10000000 c)
+  (set! c #f)
+  (set! c2 #f)
+  (set! cb #f)
+  (for ([i 3])
+    (collect-garbage))
+  (test #f weak-box-value b)
+  (test #f weak-box-value bb))
+
 (test #t custodian? cm)
 (test #f custodian? 1)
 (arity-test custodian? 1 1)

racket/src/thread/custodian-object.rkt

@@ -20,7 +20,7 @@
                    [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
-                   [memory-limits #:mutable]   ; list of (cons limit cust)
+                   [memory-limits #:mutable]   ; list of (cons limit #f-or-cust) where #f means "self"
                    [immediate-limit #:mutable] ; limit on immediate allocation
                    [sync-futures? #:mutable]   ; whether a sync with future threads is needed on shutdown
                    [post-shutdown #:mutable])  ; callbacks to run in atomic mode after shutdown

racket/src/thread/custodian.rkt

@@ -3,6 +3,7 @@
          "place-object.rkt"
          "place-local.rkt"
          "check.rkt"
+         "internal-error.rkt"
          "atomic.rkt"
          "host.rkt"
          "evt.rkt"
@@ -139,6 +140,7 @@
         (unless (custodian-gc-roots cust)
           (set-custodian-gc-roots! cust (make-weak-hasheq)))
         (hash-set! (custodian-gc-roots cust) obj #t)
+        (check-limit-custodian cust)
         (host:enable-interrupts))
       (or (custodian-self-reference cust)
           (let ([cref (custodian-reference (make-weak-box cust))])
@@ -164,7 +166,8 @@
        (host:disable-interrupts)
        (define gc-roots (custodian-gc-roots c))
        (when gc-roots
-         (hash-remove! gc-roots obj))
+         (hash-remove! gc-roots obj)
+         (check-limit-custodian c))
        (host:enable-interrupts)))
     (void)))
 
@@ -194,7 +197,8 @@
                                   (append (custodian-post-shutdown c)
                                           (custodian-post-shutdown parent)))
     (set-custodian-post-shutdown! c null)
-    (when gc-roots (hash-clear! gc-roots))))
+    (when gc-roots (hash-clear! gc-roots))
+    (check-limit-custodian parent)))
 
 ;; Called in scheduler thread:
 (define (poll-custodian-will-executor)
@@ -298,6 +302,8 @@
             (callback child c)
             (callback child))))
     (hash-clear! (custodian-children c))
+    (when (custodian-gc-roots c)
+      (hash-clear! (custodian-gc-roots c)))
     (for ([proc (in-list (custodian-post-shutdown c))])
       (proc))
     (set-custodian-post-shutdown! c null)
@@ -307,8 +313,8 @@
     (define p-cref (custodian-parent-reference c))
     (when p-cref
       (unsafe-custodian-unregister c p-cref))
-    (set-custodian-memory-limits! c null)
-    (remove-limit-custodian! c)))
+    (remove-limit-custodian! c)
+    (set-custodian-memory-limits! c null)))
 
 (define (custodian-get-shutdown-sema c)
   (atomically
@@ -380,31 +386,46 @@
   (check who custodian? stop-cust)
   (place-ensure-wakeup!)
   (atomically/no-interrupts
-   (set-custodian-memory-limits! limit-cust
-                                 (cons (cons need-amt stop-cust)
-                                       (custodian-memory-limits limit-cust)))
-   (when (eq? stop-cust limit-cust)
-     (define old-limit (custodian-immediate-limit limit-cust))
-     (when (or (not old-limit) (old-limit . > . need-amt))
-       (set-custodian-immediate-limit! limit-cust need-amt)))
-   (host:disable-interrupts)
-   (host:mutex-acquire memory-limit-lock)
-   (hash-set! custodians-with-limits limit-cust #t)
-   (set! compute-memory-sizes (max compute-memory-sizes 1))
-   (host:mutex-release memory-limit-lock)
-   (host:enable-interrupts)))
-
-;; Ensures that custodians with memory limits are not treated as
-;; inaccessible and merged; use only while holding the memory-limit
-;; lock and with interrupts disabled (or be in a GC)
+   (unless (or (custodian-shut-down? limit-cust)
+               (custodian-shut-down? stop-cust))
+     (set-custodian-memory-limits! limit-cust
+                                   (cons (cons need-amt (if (eq? limit-cust stop-cust)
+                                                            #f ; => self
+                                                            stop-cust))
+                                         (custodian-memory-limits limit-cust)))
+     (when (eq? stop-cust limit-cust)
+       (define old-limit (custodian-immediate-limit limit-cust))
+       (when (or (not old-limit) (old-limit . > . need-amt))
+         (set-custodian-immediate-limit! limit-cust need-amt)))
+     (check-limit-custodian limit-cust)))
+  (void))
+
+;; Ensures that custodians with memory limits and children are not
+;; treated as inaccessible and merged; use only while holding the
+;; memory-limit lock and with interrupts disabled (or be in a GC)
 (define custodians-with-limits (make-hasheq))
 
+;; In atomic mode
+(define (check-limit-custodian limit-cust)
+  (when (pair? (custodian-memory-limits limit-cust))
+    (host:disable-interrupts)
+    (host:mutex-acquire memory-limit-lock)
+    (cond
+      [(and (custodian-gc-roots limit-cust)
+            (positive? (hash-count (custodian-gc-roots limit-cust))))
+       (hash-set! custodians-with-limits limit-cust #t)
+       (set! compute-memory-sizes (max compute-memory-sizes 1))]
+      [else
+       (hash-remove! custodians-with-limits limit-cust)])
+    (host:mutex-release memory-limit-lock)
+    (host:enable-interrupts)))
+
+;; In atomic mode
 (define (remove-limit-custodian! c)
-  (host:disable-interrupts)
-  (host:mutex-acquire memory-limit-lock)
-  (hash-remove! custodians-with-limits c)
-  (host:mutex-release memory-limit-lock)
-  (host:enable-interrupts))
+  (when (and (custodian-gc-roots c)
+             (positive? (hash-count (custodian-gc-roots c))))
+    (internal-error "remove-limit-custodian!: roots table is not empty"))
+  (check-limit-custodian c))
 
 ;; ----------------------------------------
 
@@ -542,13 +563,14 @@
                          (for/list ([limit (in-list old-limits)]
                                     #:when (cond
                                              [((car limit) . <= . use)
-                                              (queue-custodian-shutdown! (cdr limit))
+                                              (queue-custodian-shutdown! (or (cdr limit) c))
                                               #f]
                                              [else #t]))
                            limit))
                        (set-custodian-memory-limits! c new-limits)
                        (when (and (pair? old-limits)
-                                  (null? new-limits))
+                                  (or (null? new-limits)
+                                      (zero? (hash-count (custodian-gc-roots c)))))
                          (hash-remove! custodians-with-limits c))
                        (or any-limits? (pair? new-limits))))
                    ;; If no limits are installed, decay demand for memory counts: