From fb968db7a559d53b5b3ef4c47eb61fcd5242f91c Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 1 May 2019 13:46:46 -0600
Subject: [PATCH] cs & thread: detect plumber-flush errors on place exit

---
 racket/src/thread/place.rkt   | 20 +++++++++++++++-----
 racket/src/thread/plumber.rkt |  8 ++++++--
 2 files changed, 21 insertions(+), 7 deletions(-)

diff --git a/racket/src/thread/place.rkt b/racket/src/thread/place.rkt
index cfc254e642..0bc2eb737e 100644
--- a/racket/src/thread/place.rkt
+++ b/racket/src/thread/place.rkt
@@ -54,10 +54,20 @@
   (set-custodian-place! orig-cust new-place)
   (define done-waiting (place-done-waiting new-place))
   (define (default-exit v)
-    (plumber-flush-all orig-plumber)
+    (define flush-failed? #f)
+    (plumber-flush-all/wrap orig-plumber
+                            ;; detect whether there's an error on a flush
+                            (lambda (proc h)
+                              (call-with-continuation-prompt
+                               (lambda ()
+                                 (proc h))
+                               (default-continuation-prompt-tag)
+                               (lambda (thunk)
+                                 (set! flush-failed? #t)
+                                 (call-with-continuation-prompt thunk)))))
     (atomically
      (host:mutex-acquire lock)
-     (set-place-queued-result! new-place (if (byte? v) v 0))
+     (set-place-queued-result! new-place (if flush-failed? 1 (if (byte? v) v 0)))
      (place-has-activity! new-place)
      (unsafe-custodian-unregister new-place (place-custodian-ref new-place))
      (host:mutex-release lock))
@@ -98,13 +108,13 @@
              (set-place-wakeup-handle! new-place (sandman-get-wakeup-handle))
              (host:condition-signal started) ; place is sufficiently started
              (host:mutex-release lock)
-             (finish))
+             (finish)
+             (default-exit 0))
            (default-continuation-prompt-tag)
            (lambda (thunk)
              ;; Thread ended with escape => exit with status 1
              (call-with-continuation-prompt thunk)
-             (default-exit 1)))
-          (default-exit 0))))
+             (default-exit 1))))))
      (lambda (result)
        ;; Place is done, so save the result and alert anyone waiting on
        ;; the place
diff --git a/racket/src/thread/plumber.rkt b/racket/src/thread/plumber.rkt
index 4a869a404c..3269b3dc08 100644
--- a/racket/src/thread/plumber.rkt
+++ b/racket/src/thread/plumber.rkt
@@ -5,6 +5,7 @@
          make-plumber
          plumber?
          plumber-flush-all
+         plumber-flush-all/wrap
          plumber-add-flush!
          plumber-flush-handle?
          plumber-flush-handle-remove!
@@ -39,10 +40,13 @@
 
 (define/who (plumber-flush-all p)
   (check who plumber? p)
+  (plumber-flush-all/wrap p (lambda (proc h) (proc h))))
+
+(define (plumber-flush-all/wrap p app)
   (for ([(h proc) (in-hash (plumber-callbacks p))])
-    (proc h))
+    (app proc h))
   (for ([(h proc) (in-hash (plumber-weak-callbacks p))])
-    (proc h)))
+    (app proc h)))
 
 (define/who (plumber-flush-handle-remove! h)
   (check who plumber-flush-handle? h)