Allow to unregister threadWaitReadSTM action.

Allow to unregister threadWaitReadSTM/threadWaitWriteSTM on
a non-threaded runtime. Previosly noop action was returned,
as a result it was not possible to unregister action, unless
data arrives to Fd or it's closed.

Fixes #12852.

Reviewers: simonmar, hvr, austin, bgamari, trofi

Reviewed By: bgamari, trofi

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2729

GHC Trac Issues: #12852

4 files changed, 30 insertions, 6 deletions

diff --git a/libraries/base/GHC/Conc/IO.hs b/libraries/base/GHC/Conc/IO.hs
index 1e9ffd58f0..be773132ee 100644
--- a/libraries/base/GHC/Conc/IO.hs
+++ b/libraries/base/GHC/Conc/IO.hs
@@ -119,18 +119,18 @@ threadWaitWrite fd
 -- is an IO action that can be used to deregister interest
 -- in the file descriptor.
 threadWaitReadSTM :: Fd -> IO (Sync.STM (), IO ())
-threadWaitReadSTM fd 
+threadWaitReadSTM fd
 #ifndef mingw32_HOST_OS
   | threaded  = Event.threadWaitReadSTM fd
 #endif
   | otherwise = do
       m <- Sync.newTVarIO False
-      _ <- Sync.forkIO $ do
+      t <- Sync.forkIO $ do
         threadWaitRead fd
         Sync.atomically $ Sync.writeTVar m True
       let waitAction = do b <- Sync.readTVar m
                           if b then return () else retry
-      let killAction = return ()
+      let killAction = Sync.killThread t
       return (waitAction, killAction)
 
 -- | Returns an STM action that can be used to wait until data
@@ -138,18 +138,18 @@ threadWaitReadSTM fd
 -- is an IO action that can be used to deregister interest
 -- in the file descriptor.
 threadWaitWriteSTM :: Fd -> IO (Sync.STM (), IO ())
-threadWaitWriteSTM fd 
+threadWaitWriteSTM fd
 #ifndef mingw32_HOST_OS
   | threaded  = Event.threadWaitWriteSTM fd
 #endif
   | otherwise = do
       m <- Sync.newTVarIO False
-      _ <- Sync.forkIO $ do
+      t <- Sync.forkIO $ do
         threadWaitWrite fd
         Sync.atomically $ Sync.writeTVar m True
       let waitAction = do b <- Sync.readTVar m
                           if b then return () else retry
-      let killAction = return ()
+      let killAction = Sync.killThread t
       return (waitAction, killAction)
 
 -- | Close a file descriptor in a concurrency-safe way (GHC only).  If
diff --git a/libraries/base/tests/T12852.hs b/libraries/base/tests/T12852.hs
new file mode 100644
index 0000000000..5bf80d5218
--- /dev/null
+++ b/libraries/base/tests/T12852.hs
@@ -0,0 +1,20 @@
+import GHC.Conc
+import GHC.IO
+import GHC.IO.FD as FD
+import System.Posix.IO
+import System.Posix.Types
+
+main = do
+  (rfd,wfd) <- createPipe
+  (waitread, unregister) <- threadWaitReadSTM rfd
+  unregister
+  result0 <- atomically $ (fmap (const False) waitread) `orElse` return True
+  print result0
+  fdWrite wfd "test"
+  threadDelay 20000
+  result1 <- atomically $ (fmap (const False) waitread) `orElse` return True
+  print result1
+  (waitread1, _) <- threadWaitReadSTM rfd
+  threadDelay 20000
+  result2 <- atomically $ (fmap (const True) waitread1) `orElse` return False
+  print result2
diff --git a/libraries/base/tests/T12852.stdout b/libraries/base/tests/T12852.stdout
new file mode 100644
index 0000000000..b8ca7e7ef0
--- /dev/null
+++ b/libraries/base/tests/T12852.stdout
@@ -0,0 +1,3 @@
+True
+True
+True
diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T
index 64ecc88ce8..a9aee1ed76 100644
--- a/libraries/base/tests/all.T
+++ b/libraries/base/tests/all.T
@@ -205,3 +205,4 @@ test('T9848',
 test('T10149', normal, compile_and_run, [''])
 test('T11334a', normal, compile_and_run, [''])
 test('T11555', normal, compile_and_run, [''])
+test('T12852', when(opsys('mingw32'), skip), compile_and_run, [''])