[GHC] #14621: GHC 8.2 GCed too early

[GHC]

#14621: GHC 8.2 GCed too early
-------------------------------------+-------------------------------------
           Reporter:  kazu-yamamoto  |             Owner:  (none)
               Type:  bug            |            Status:  new
           Priority:  normal         |         Milestone:
          Component:  Compiler       |           Version:  8.2.2
           Keywords:                 |  Operating System:  Unknown/Multiple
       Architecture:                 |   Type of failure:  None/Unknown
  Unknown/Multiple                   |
          Test Case:                 |        Blocked By:
           Blocking:                 |   Related Tickets:
Differential Rev(s):                 |         Wiki Page:
-------------------------------------+-------------------------------------
 The network package uses mkWeakVar so that unreachable Sockets can be
 GCed. See the master branch of https://github.com/haskell/network

 {{{
 mkSocket :: CInt
          -> Family
          -> SocketType
          -> ProtocolNumber
          -> SocketStatus
          -> IO Socket
 mkSocket fd fam sType pNum stat = do
    mStat <- newMVar stat
    withSocketsDo $ return ()
    let sock = Socket fd fam sType pNum mStat
 ##if MIN_VERSION_base(4,6,0)
    _ <- mkWeakMVar mStat $ close sock
 ##endif
    return sock
 }}}

 The following code cause "threadWait: invalid argument (Bad file
 descriptor)" in accept:

 {{{
 module Main where

 import Control.Concurrent (forkIO)
 import Control.Monad (void, forever)
 import Network.Socket hiding (recv)
 import Network.Socket.ByteString (recv, sendAll)

 main :: IO ()
 main = do
     let localhost = "localhost"
         listenPort = "9876"
         connectPort = "6789"
     proxy localhost listenPort connectPort

 proxy :: HostName -> ServiceName -> ServiceName -> IO ()
 proxy localhost listenPort connectPort = do
     fromClient <- serverSocket localhost listenPort
     toServer <- clientSocket localhost connectPort
     void $ forkIO $ relay toServer fromClient
     relay fromClient toServer

 relay :: Socket -> Socket -> IO ()
 relay s1 s2 = forever $ do
     payload <- recv s1 4096
     sendAll s2 payload

 serverSocket :: HostName -> ServiceName -> IO Socket
 serverSocket host port = do
     let hints = defaultHints {
                 addrFlags = [AI_PASSIVE]
               , addrSocketType = Stream
               }
     addr:_ <- getAddrInfo (Just hints) (Just host) (Just port)
     sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol
 addr)
     bind sock (addrAddress addr)
     listen sock 1
     fst <$> accept sock

 clientSocket :: HostName -> ServiceName -> IO Socket
 clientSocket host port = do
     let hints = defaultHints { addrSocketType = Stream }
     addr:_ <- getAddrInfo (Just hints) (Just host) (Just port)
     sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol
 addr)
     connect sock (addrAddress addr)
     return sock
 }}}

 GC frees sock while accepting. This occurs with GHC 8.2 or higher.

-- 
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/14621>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler