threadWaitReadSTM does not provide a way to unregister action.

In non-threaded RTS or on windows RTS does not return meaningful unregister action:

threadWaitWriteSTM :: Fd -> IO (Sync.STM (), IO ())
threadWaitWriteSTM fd 
#ifndef mingw32_HOST_OS
  | threaded  = Event.threadWaitWriteSTM fd
#endif
  | otherwise = do
      m <- Sync.newTVarIO False
      _ <- 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 ()
      return (waitAction, killAction)

As a result in case if data will never arrive, helper thread will never be deallocated. This may lead to a memory leaks in some cases, see https://github.com/lpeterse/haskell-socket/issues/27 for details.

Minimal testcase is:

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

Expected output will be True, True, True, but non-threaded runtime gives True, False, True

Trac metadata

Trac field	Value
Version	8.0.1
Type	Bug
TypeOfFailure	OtherFailure
Priority	normal
Resolution	Unresolved
Component	Core Libraries
Test case
Differential revisions
BlockedBy
Related
Blocking
CC	ekmett
Operating system
Architecture