[commit: ghc] master: Allow to unregister threadWaitReadSTM action. (f430253)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/f43025340d05d3c6085c41e441d278745f34a317/ghc

>---------------------------------------------------------------

commit f43025340d05d3c6085c41e441d278745f34a317
Author: Alexander Vershilov <alexander.vershilov at gmail.com>
Date:   Tue Nov 22 20:57:08 2016 -0500

    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


>---------------------------------------------------------------

f43025340d05d3c6085c41e441d278745f34a317
 libraries/base/GHC/Conc/IO.hs                        |  8 ++++----
 libraries/base/tests/T12852.hs                       | 20 ++++++++++++++++++++
 .../base/tests/T12852.stdout                         |  1 +
 libraries/base/tests/all.T                           |  1 +
 4 files changed, 26 insertions(+), 4 deletions(-)

diff --git a/libraries/base/GHC/Conc/IO.hs b/libraries/base/GHC/Conc/IO.hs
index 1e9ffd5..be77313 100644
--- a/libraries/base/GHC/Conc/IO.hs
+++ b/libraries/base/GHC/Conc/IO.hs
@@ -125,12 +125,12 @@ 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
@@ -144,12 +144,12 @@ 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 0000000..5bf80d5
--- /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/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun03.stdout b/libraries/base/tests/T12852.stdout
similarity index 66%
copy from testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun03.stdout
copy to libraries/base/tests/T12852.stdout
index dbde422..b8ca7e7 100644
--- a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun03.stdout
+++ b/libraries/base/tests/T12852.stdout
@@ -1,2 +1,3 @@
 True
 True
+True
diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T
index 64ecc88..a9aee1e 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, [''])