I'm trying to make a program that print arrows until the user press enter (see code bellow).
The problem is that when I press enter, I see the "stop" string in the console, but it doesn't change the value of m in the outputArrows function.
How can I share the state?
import Control.Concurrent
import Control.Concurrent.Async
import Control.Monad
waitForInput m = do
getLine
putStrLn "stop"
putMVar m True
outputArrows m = do
stop <- readMVar m
unless stop $ do
threadDelay 1000000
putStr ">"
outputArrows m
main = do
m <- newMVar False
th1 <- async (waitForInput m)
th2 <- async (outputArrows m)
wait th1
wait th2
Your putMVar doesn't actually put a new value in the MVar but blocks indefinitely. MVars are like boxes that can hold only a single value. If you want to replace the value, you need to take out the old value first.
If you don't need the blocking behavior of MVar, you should just use a regular IORef or possibly a TVar if you need to ensure that more complex operations run atomically.
You should use swapMVar instead of putMVar. As mentioned by #shang, putMVar blocks until the MVar is empty, so the putMVar never finishes:
waitForInput m = do
getLine
putStrLn "stop"
swapMVar m True
Alternatively, you could just use an empty MVar () as a boolean flag:
waitForInput :: MVar () -> IO ()
waitForInput m = do
getLine
putStrLn "stop"
putMVar m ()
outputArrows :: MVar () -> IO ()
outputArrows m = do
running <- isEmptyMVar m
when running $ do
threadDelay 1000000
putStr ">"
outputArrows m
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
m <- newEmptyMVar
th1 <- async (waitForInput m)
th2 <- async (outputArrows m)
wait th1
wait th2
Related
When I test some simple cases about threaded codes,
I found some loop hang without hFlush stdout even it does not use any print things.
import Control.Concurrent
import System.IO
import Data.IORef
delay :: Int -> IO ()
delay = threadDelay . (* 1000000)
wait sw = loop
where
loop = do
v <- readIORef sw
--hFlush stdout -- without this, hang
if v
then return()
else loop
monitor sw = forkIO $ loop
where
loop = do
v <- readIORef sw
print v
delay 1
loop
main = do
sw <- newIORef False
forkIO $ do
delay 4
writeIORef sw True
monitor sw
wait sw
--putStrLn "End"
This code hangs whether monitor sw and putStrLn "End" exist or not.
However, just uncomment hFlush stdout in wait, it works properly and ends.
This also happens with a code using MVar.
import Control.Concurrent
import Control.Concurrent.MVar
import System.IO
delay :: Int -> IO ()
delay = threadDelay . (* 1000000)
wait :: MVar Bool -> IO ()
wait sw = loop
where loop = do
v <- readMVar sw
hFlush stdout -- without this, hangs
if v
then return ()
else loop
main :: IO ()
main = do
sw <- newMVar False
forkIO $ do
delay 4
modifyMVar_ sw (\_ -> return True)
wait sw
These two codes will run properly when running by runghc.
However, the codes below are not hanging without hFlush stdout.
import Control.Concurrent
import Control.Concurrent.MVar
import System.IO
delay :: Int -> IO ()
delay = threadDelay . (* 1000000)
wait :: MVar Bool -> IO ()
wait sw = loop
where loop = do
v <- readMVar sw
if v
then return ()
else loop
main :: IO ()
main = do
sw <- newEmptyMVar
forkIO $ do
delay 4
putMVar sw True
wait sw
import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.STM.TVar
import System.IO
delay :: Int -> IO ()
delay = threadDelay . (* 1000000)
wait :: TVar Bool -> IO ()
wait sw = atomically $ do
v <- readTVar sw
unless v retry
main :: IO ()
main = do
sw <- newTVarIO False
forkIO $ do
delay 4
atomically $ writeTVar sw True
wait sw
I know that there are difference. But I couldn't find out why some codes hang.
Is stdout is related with handling thread?
Could you explain why the loops are hanging or not without hFlush stdout?
Additional:
1. I've tested this codes with GHC 7.10.2 {OS X, Windows}
Most likely the compiler optimized the wait into non-allocating busy loop. Runtime system just doesn't have a chance to interrupt it to let the child thread to run. You can "fix" by adding any action that allocates or yields, e.g. hFlush or threadDelay. Also you can compile the code with -fno-omit-yields.
See also: https://ghc.haskell.org/trac/ghc/ticket/367 and https://ghc.haskell.org/trac/ghc/ticket/10639
http://pastebin.com/2CS1k1Zq
In this game i need to get step the game forward every half a second or so while occasionally getting input to change direction. These too things seem impossible to do with haskell is there a way to do it? Currently I am having an mv tread stall exception.
Update: Found the hWaitForInput function in System.IO which is essentially the same as waitFor.
Here is some code largely based on this answer.
The main difference I made is that the thread waiting for a key press does not perform the getChar directly. The result communicated in the MVar is an indication of timeout or that a key press has occurred. It is the responsibility of the main thread to actually get the character. This prevents a possible race condition in case the char reading thread is killed between getting the character and putting it into the MVar.
import Control.Concurrent
import Control.Monad
import Data.Maybe
import System.IO
import Control.Exception
data Event = CharReady | TimedOut
withRawStdin :: IO a -> IO a
withRawStdin = bracket uncook restore . const
where
uncook = do
oldBuffering <- hGetBuffering stdin
oldEcho <- hGetEcho stdin
hSetBuffering stdin NoBuffering
hSetEcho stdin False
return (oldBuffering, oldEcho)
restore (oldBuffering, oldEcho) = do
hSetBuffering stdin oldBuffering
hSetEcho stdin oldEcho
waitFor :: Int -> IO Event
waitFor delay = do
done <- newEmptyMVar
withRawStdin . bracket (start done) cleanUp $ \_ -> takeMVar done
where
start done = do
t1 <- forkIO $ hLookAhead stdin >> putMVar done CharReady
t2 <- forkIO $ threadDelay delay >> putMVar done TimedOut
return (t1, t2)
cleanUp (t1, t2) = do
killThread t1
killThread t2
loop state = do
if state <= 0
then putStrLn "Game over."
else do putStrLn $ "Rounds to go: " ++ show state
e <- waitFor 3000000
case e of
TimedOut -> do putStrLn "Too late!"; loop state
CharReady -> do c <- getChar -- should not block
if c == 'x'
then do putStrLn "Good job!"; loop (state-1)
else do putStrLn "Wrong key"; loop state
main = loop 3
Let's consider this simple Haskell program:
module Main where
import Control.Concurrent.STM
import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.Maybe
import Data.Monoid
import Control.Applicative
terminator :: Either SomeException () -> IO ()
terminator r = print $ "Dying with " <> show r
doStuff :: TMVar () -> TChan () -> Int -> IO ()
doStuff writeToken barrier w = void $ flip forkFinally terminator $ do
hasWriteToken <- isJust <$> atomically (tryTakeTMVar writeToken)
case hasWriteToken of
True -> do
print $ show w <> "I'm the lead.."
threadDelay (5 * 10^6)
print "Done heavy work"
atomically $ writeTChan barrier ()
False -> do
print $ show w <> " I'm the worker, waiting for the barrier..."
myChan <- atomically $ dupTChan barrier
_ <- atomically $ readTChan myChan
print "Unlocked!"
main :: IO ()
main = do
writeToken <- newTMVarIO ()
barrier <- newBroadcastTChanIO
_ <- forM [1..20] (doStuff writeToken barrier)
threadDelay (20 * 10^6)
return ()
It essentially model a concurrency scenario where a "lead" acquire the write token, do something and the workers will sync on a barrier and way for the "green light" from the lead. This works, but if we replace worker "atomically" block with this:
_ <- atomically $ do
myChan <- dupTChan barrier
readTChan myChan
All the workers remains blocked indefinitely inside a STM transaction:
"Done heavy work"
"Dying with Right ()"
"Dying with Left thread blocked indefinitely in an STM transaction"
"Dying with Left thread blocked indefinitely in an STM transaction"
"Dying with Left thread blocked indefinitely in an STM transaction"
...
I suspect the key lies inside the semantic of atomically. Any idea?
Thanks!
Alfredo
I think this behavior comes from the definition of dupTChan. Copied here for readability, along with readTChan
dupTChan :: TChan a -> STM (TChan a)
dupTChan (TChan _read write) = do
hole <- readTVar write
new_read <- newTVar hole
return (TChan new_read write)
readTChan :: TChan a -> STM a
readTChan (TChan read _write) = do
listhead <- readTVar read
head <- readTVar listhead
case head of
TNil -> retry
TCons a tail -> do
writeTVar read tail
return a
inlining those functions, we get this STM block:
worker_block (TChan _read write) = do
hole <- readTVar write
new_read <- newTVar hole
listhead <- readTVar new_read
head <- readTVar listhead
case head of
TNil -> retry
...
When you try to run this block atomically, we make a new read_end from the tail of the channel, then call readTVar on it. The tail is of course empty, so this readTVar will retry. However, when the lead writes to the channel, the act of writing to the channel invalidates this transaction! So every follower transaction will always have to retry.
In fact, I don't think there is any case where dupTChan >>= readTChan will ever result in anything other than the thread being blocked indefinitely on an STM transaction. You can reason this out from the documentation as well. dupTChan begins empty, so within a single atomic transaction it will never have any items unless that same transaction adds them.
I have a timer function that takes a time to wait for and a starting time and returns the current UTCTime when it ends:
runTimer :: NominalDiffTime -> UTCTime -> IO UTCTime
I'd like to run this timer function in a separate thread, because I want to simultaneously be able to capture input from the user. In this main loop I also use a WriterT monad transformer to log events. I also want to log an event when the timer ends normally, so I've tried using forkFinally:
type Log = [Entry]
data Entry = Entry {
_etype :: EntryType
, _etime :: UTCTime
} deriving Show
data EntryType = Start | End | Pause | Quit deriving Show
type Program = WriterT Log IO
loop :: Maybe ThreadId -> Program ()
loop timerId = do
liftIO $ putStr ">"
x <- liftIO $ getChar
now <- liftIO $ getCurrentTime
case x of
'q' -> do
liftIO $ putStrLn "\n Quitting..."
tell [Entry Quit now]
-- Kill the timer thread if there is one.
maybe (return ()) (liftIO . killThread) timerId
liftIO $ putStrLn "\n Quit."
's' -> case timerId of
Just _ -> do
liftIO $ putStrLn "Timer already started!"
loop timerId
Nothing -> do
-- Start a timer in a new thread.
tell [Entry Start now]
timerId' <- liftIO $ forkFinally (runTimer 5 now) eHandler
-- Call the main loop with the timer thread id.
loop (Just timerId')
_ -> do
liftIO $ putChar x
loop timerId
eHandler :: (Show a, Exception e) => Either e a -> IO ()
eHandler (Left x) = throw x
eHandler (Right x) = do
putStrLn $ show x
eHandler' :: (Exception t) => Either t UTCTime -> WriterT Log IO ()
eHandler' (Left x) = throw x
eHandler' (Right t) = do
tell [Entry End t]
This code works when using forkFinally with eHandler. But how can I get it to work with eHandler', so that I can log when the timer finishes?
You need to convert a WriterT monad to an IO monad, something like this:
wrapWriterT::WriterT a IO c->IO c
wrapWriterT writer = do
(result, log) <- runWriterT writer
<do something with the log, like send it to a file>
return result
and then use it like this:
timerId' <- liftIO $ forkFinally (runTimer 5 now) (wrapWriterT . eHandler')
What is happening here? Remember, the Writer monad is used to pass an extra string around, that can be appended to, like a log. The IO monad is used for, well.... IO. forkFinally needs type IO(), but the WriterT is for both IO and also returns a log. forkFinally doesn't know what to do with this log, but if you wrap it in a function to extract the log and do something with it, then you are left with simply an IO monad, which forkFinally knows how to handle.
I do want to ask though.... The standard timer functions in Control.Concurrent are nonblocking (you hand it a function of type IO(), and it returns, with the understanding that it will be done later). What are you doing that needs explicit threads?
The function below wants to either receive and ack or wait until its duetime has come and return.
Now, it works when it receives and ack. It works correctly when no ack is received and waits until duetime.
When the duetime is reached it freezes. It seems that it is not exiting my self constructed loop correctly. I have also tried with if-then-else, but same result. I do not want to use whileM.
How do I correctly exit the loop?
import Network.Socket hiding (send, sendTo, recv, recvFrom)
import Network.Socket.ByteString
waitAck s duetime' = do
print ("in")
(a, _) <- recvFrom s 4711
now' <- getPOSIXTime
unless (B.unpack a == "ack") (when (now' < duetime') (waitAck s duetime'))
print (B.unpack a)
return ()
The correct solution is to race two threads, one that waits for the ack, and one that waits for the time. Kill the one that loses the race. Perhaps this (untested) code will give you a hint about how:
import Control.Concurrency.MVar
withTimeout :: Int -> IO a -> IO (Maybe a)
withTimeout n io = do
mvar <- newEmptyMVar
timeout <- forkIO (threadDelay n >> putMVar mvar Nothing)
action <- forkIO (io >>= putMVar mvar . Just)
result <- takeMVar mvar
killThread timeout
killThread action
return result
waitAck s timeout = withTimeout timeout go where
go = do
(a, _) <- recvFrom s 4711
if B.unpack a == "ack" then print (B.unpack a) else go
edit: It seems that base provides System.Timeout.timeout for exactly this purpose. Its implementation is more likely to be correct than this one, too.
That's not an iterative loop. You don't place any conditions on the stuff after the recursive call, so when the conditions finally fail, the whole thing will unwind, printing once for every recursive call. I suspect that might be enough to make it appear frozen.
Try something like this:
waitAck s duetime' = do
print ("in")
(a, _) <- recvFrom s 4711
now' <- getPOSIXTime
if B.unpack a == "ack" || now' >= duetime'
then print (B.unpack a)
else waitAck s duetime'