From f0c39b1f81e1b04bacb2734b960890311d6c9979 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sat, 25 May 2019 17:26:41 -0600
Subject: [PATCH] cs & threads: fix weak reference from custodian

Using a will executor to turn a reference from weak to strong still
seems like an ok idea, but it needs to be a regular will executor,
because a custodian-registered value is likely to involve have a
nested self-reference.
---
 racket/collects/setup/setup-core.rkt  |  9 +++++++++
 racket/src/cs/rumble/memory.ss        |  9 ++++-----
 racket/src/cs/rumble/will-executor.ss | 11 +++++++----
 racket/src/thread/custodian.rkt       |  6 ++++--
 4 files changed, 24 insertions(+), 11 deletions(-)

diff --git a/racket/collects/setup/setup-core.rkt b/racket/collects/setup/setup-core.rkt
index 3dd954dd9c..3286341c57 100644
--- a/racket/collects/setup/setup-core.rkt
+++ b/racket/collects/setup/setup-core.rkt
@@ -149,6 +149,12 @@
                      'path->main-lib-relative
                      'main-lib-relative->path))
 
+  ;; For checking and debugging memory leaks; set `PLT_SETUP_DMS_ARGS`
+  ;; to an S-expression list and use `-j 1` to run a non-parallel setup:
+  (define post-collection-dms-args
+    (let ([v (getenv "PLT_SETUP_DMS_ARGS")])
+      (and v (read (open-input-string v)))))
+
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;                   Errors                      ;;
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -1087,6 +1093,9 @@
                                   #:managed-compile-zo caching-managed-compile-zo
                                   #:skip-path (and (avoid-main-installation) main-collects-dir)
                                   #:skip-doc-sources? (not make-docs?))))))
+    (when post-collection-dms-args
+      (collect-garbage)
+      (apply dump-memory-stats post-collection-dms-args))
     (if (eq? 0 gcs)
         0
         (begin (collect-garbage) (sub1 gcs))))
diff --git a/racket/src/cs/rumble/memory.ss b/racket/src/cs/rumble/memory.ss
index 72611f464e..a8b6854489 100644
--- a/racket/src/cs/rumble/memory.ss
+++ b/racket/src/cs/rumble/memory.ss
@@ -293,12 +293,11 @@
     [(eq? 'metacontinuation-frame (car args))
      metacontinuation-frame?]
     [(symbol? (car args))
-     #f
-     ;; This is disaterously slow, so don't try it:
-     #;
-     (let ([type (car args)])
+     (let ([name (car args)])
        (lambda (o)
-         (eq? ((inspect/object o) 'type) type)))]
+         (and (#%record? o)
+              (let ([rtd (#%record-rtd o)])
+                (eq? name (#%record-type-name rtd))))))]
     [else #f])
    ;; 'new mode for backtrace?
    (and (pair? args)
diff --git a/racket/src/cs/rumble/will-executor.ss b/racket/src/cs/rumble/will-executor.ss
index 1af11e87c8..fb4f7d39ad 100644
--- a/racket/src/cs/rumble/will-executor.ss
+++ b/racket/src/cs/rumble/will-executor.ss
@@ -9,7 +9,7 @@
 ;; lifo. The `will-stacks` tables map a finalized value to a list
 ;; of finalizers, where each finalizer is an ephemeron pairing a will
 ;; executor with a will function (so that the function is not retained
-;; if the will executor is dropped)
+;; if the will executor is dropped).
 (define-thread-local the-will-stacks (make-weak-eq-hashtable))
 (define-thread-local the-late-will-stacks (make-weak-eq-hashtable))
 
@@ -36,7 +36,7 @@
   (check who (procedure-arity-includes/c 1) proc)
   (disable-interrupts)
   (let ([l (hashtable-ref (will-executor-will-stacks executor) v '())]
-        ;; By using an ephemeron pair, if the excutor becomes
+        ;; By using an ephemeron pair, if the executor becomes
         ;; unreachable, then we can drop the finalizer procedure. That
         ;; pattern prevents unbreakable cycles by an untrusted process
         ;; that has no access to a will executor that outlives the
@@ -79,7 +79,8 @@
     (let ([v (guardian)])
       (when v
         (let we-loop ([l (hashtable-ref will-stacks v '())])
-          (when (pair? l)
+          (cond
+           [(pair? l)
             (let* ([e+proc (car l)]
                    [e (car e+proc)]
                    [proc (cdr e+proc)]
@@ -101,7 +102,9 @@
                 (when (will-executor-keep? e)
                   ;; Ensure that a late will executor stays live
                   ;; in this place as long as there are wills to execute
-                  (hashtable-set! late-will-executors-with-pending e #t))]))))
+                  (hashtable-set! late-will-executors-with-pending e #t))]))]
+           [else
+            (hashtable-delete! will-stacks v)]))
         (loop)))))
 
 (define (poll-will-executors)
diff --git a/racket/src/thread/custodian.rkt b/racket/src/thread/custodian.rkt
index a5b009274b..7465a3d236 100644
--- a/racket/src/thread/custodian.rkt
+++ b/racket/src/thread/custodian.rkt
@@ -112,7 +112,7 @@
      [(custodian-shut-down? cust) #f]
      [else
       (define we (and (not weak?)
-                      (host:make-late-will-executor void #f)))
+                      (host:make-will-executor void)))
       (hash-set! (custodian-children cust)
                  obj
                  (cond
@@ -123,7 +123,9 @@
         ;; 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:
+        ;; into a strong one when there are no other references;
+        ;; we're assuming that no wills were previously registered
+        ;; so that this one is last on the stack of wills:
         (host:will-register we obj void))
       (when gc-root?
         (host:disable-interrupts)