Story with MVar

§Weird behavior

Encountered one weird problem while reading Parallel and Concurrent Programming in Haskell.

import Control.Concurrent
import Control.Exception
import qualified Data.Map as Map
import Text.Printf
import Control.Monad
import System.IO
import qualified Data.ByteString as B

import Network.HTTP
import Network.Browser
import Network.URI
import Data.ByteString (ByteString)

getURL :: String -> IO ByteString
getURL url = do
  Network.Browser.browse $ do
    setCheckForProxy True
    setDebugLog Nothing
    setOutHandler (const (return ()))
    (_, rsp) <- request (getRequest' (escapeURIString isUnescapedInURI url))
    return (rspBody rsp)
  where
    getRequest' :: String -> Request ByteString
    getRequest' urlString =
      case parseURI urlString of
        Nothing -> error ("getRequest: Not a valid URL - " ++ urlString)
        Just u -> mkRequest GET u

type Async a = MVar (Either SomeException a)

async :: IO a -> IO (Async a)
async action = do
  var <- newEmptyMVar
  forkIO $ do
    r <- try action
    putMVar var r
  return var

wait :: Async a -> IO a
wait a = do
  -- r <- takeMVar a
  r <- readMVar a
  case r of
    Left e -> throwIO e
    Right a -> return a

waitCountDown :: Async a -> Integer -> IO a
waitCountDown m 1 = do wait m
waitCountDown m count = do
  r <- takeMVar m
  case r of
    Left e -> waitCountDown m (count-1)
    Right a -> return a


waitAny :: [Async a] -> IO a
waitAny as = do
  m <- newEmptyMVar
  let waitFork a = forkIO $ do r <- readMVar a; putMVar m r
  mapM_ waitFork as
  -- waitCountDown m $ fromIntegral $ length as
  wait m

-- sites = ["http://googlegoogle.com/"]
sites = reverse ["http://www.googlegoogle.com/",
  "http://auportal.herokuapp.com",
  "http://auportal.herokuapp.com",
  "http://www.google.se/"]

download url = do
  r <- getURL url
  return (url, r)

main = do
  as <- mapM (async . download) sites
  (url, r) <- waitAny as
  printf "%s was first (%d bytes)\n" url (B.length r)

The code is actual correct, but it sometimes is blocked, as shown in my console output. The weird thing is that runghc seems to work fine. I even suspected that there’s some magic in runghc, so I checked the source of runghc, and the it more or less equivalent to ghc -e Main.main test.hs.

concurrent » ghc test.hs ; repeat 10 ./test
[1 of 1] Compiling Main             ( test.hs, test.o )
Linking test ...
test: thread blocked indefinitely in an MVar operation
test: thread blocked indefinitely in an MVar operation
test: thread blocked indefinitely in an MVar operation
test: thread blocked indefinitely in an MVar operation
test: thread blocked indefinitely in an MVar operation
test: thread blocked indefinitely in an MVar operation
test: thread blocked indefinitely in an MVar operation
test: user error (openTCPConnection: host lookup failure for "www.googlegoogle.com")
test: thread blocked indefinitely in an MVar operation
test: thread blocked indefinitely in an MVar operation

concurrent » repeat 10 runghc test.hs
http://www.google.se/ was first (17942 bytes)
http://www.google.se/ was first (17926 bytes)
http://www.google.se/ was first (17950 bytes)
http://auportal.herokuapp.com was first (3190 bytes)
http://auportal.herokuapp.com was first (3190 bytes)
http://www.google.se/ was first (17942 bytes)
http://www.google.se/ was first (17956 bytes)
http://www.google.se/ was first (17893 bytes)
http://www.google.se/ was first (17901 bytes)
http://www.google.se/ was first (17941 bytes)

With no luck on runghc, I switched to the doc for Control.Concurrent, hoping to find something helpful. All of the sudden, I stumbled upon readMVar, and the incompatible note is what I am after. Replacing readMVar with takeMVar resolves the blocking issue immediately. Running the original code in GHC 7.8 doesn’t have this “blocked indefinitely” exception as well. Then, I could say that I am luck (unluck) enough to be caught by one bug in GHC.

§Why the interpreter works

How come runghc succeeds? My postulation would be contention inside the interpreter is not so high, so this error is not exposed.