If an STM transaction fails and retries, does the call to writeTChan get re-executed so that you end up with two writes, or does the STM only actually perform the write if the transaction commits? i.e., is this solution to the sleeping barber problem valid, or might a customer get two haircuts if the transaction in enterShop fails the first time?
import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM
import System.Random
import Text.Printf
runBarber :: TChan Int -> TVar Int -> IO ()
runBarber haircutRequestChan seatsLeftVar = forever $ do
customerId <- atomically $ readTChan haircutRequestChan
atomically $ do
seatsLeft <- readTVar seatsLeftVar
writeTVar seatsLeftVar $ seatsLeft + 1
putStrLn $ printf "%d started cutting" customerId
delay <- randomRIO (1,700)
threadDelay delay
putStrLn $ printf "%d finished cutting" customerId
enterShop :: TChan Int -> TVar Int -> Int -> IO ()
enterShop haircutRequestChan seatsLeftVar customerId = do
putStrLn $ printf "%d entering shop" customerId
hasEmptySeat <- atomically $ do
seatsLeft <- readTVar seatsLeftVar
let hasEmptySeat = seatsLeft > 0
when hasEmptySeat $ do
writeTVar seatsLeftVar $ seatsLeft - 1
writeTChan haircutRequestChan customerId
return hasEmptySeat
when (not hasEmptySeat) $ do
putStrLn $ printf "%d turned away" customerId
main = do
seatsLeftVar <- newTVarIO 3
haircutRequestChan <- newTChanIO
forkIO $ runBarber haircutRequestChan seatsLeftVar
forM_ [1..20] $ \customerId -> do
delay <- randomRIO (1,3)
threadDelay delay
forkIO $ enterShop haircutRequestChan seatsLeftVar customerId
UPDATE
I didn't notice until after the fact that the above hairRequestChan doesn't have to be part of the transaction anyway. I can use a regular Chan and do the writeChan in an if statement after the atomically block in enterShop. But making that improvement destroys the whole reason for asking the question, so I'll leave it as-is here.
TChan operations are performed when a transaction is committed, just like other STM operations, so you'll always end up with a single write, no matter how many times your transaction is retried. They'd be kind of useless otherwise.
To convince yourself, try this example:
import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.STM.TChan
main = do
ch <- atomically newTChan
forkIO $ reader ch >>= putStrLn
writer ch
reader = atomically . readTChan
writer ch = atomically $ writeTChan ch "hi!" >> retry
This will throw a exception complaining that the transaction is blocked indefinitely. If writeTChan caused a write to happen before the transaction was committed, the program would print "hi!" before throwing that exception.
Related
What I'd like to do is something like this where every time one of these print actions occurs it updates the counter to ensure that the next subsequent occurrence of a print action will always have the correct order in which it occurred among any of the possible print actions that may occur across multiple threads shown by the counter. The problem in my example is that if the IORef is read at the same time between threads then two or more print actions will have the same counter value. From what I've read it seems that using the Data.Atomics.Counter library would solve this problem but i am having a really hard time understanding how to use it do so. Can anyone show me an example or try to explain it to me please?
main = do
myref <- newIORef 1 :: IO (IORef Int)
void(forkIO (forever $ do ref <- readIORef myref
print ("hi " ++ show (ref))
modifyIORef myref (+1) ))
void(forkIO (forever $ do ref <- readIORef myref
print ("hey " ++ show (ref))
modifyIORef myref (+1) ))
forever $ do ref <- readIORef myref
print ("hello " ++ show (ref))
modifyIORef myref (+1)
I would use an MVar for this.
inc mvar = forever $ do
v <- takeMVar mvar
print v
putMVar mvar (v+1)
main = do
mvar <- newMVar 1
forkIO (inc mvar)
forkIO (inc mvar)
inc mvar
It is important that the print occur between takeMVar and putMVar, while the MVar is empty; otherwise another thread may empty the MVar and execute its print.
You could use atomicModifyIORef'. It would look something like:
increment ref = forever do
val <- atomicModifyIORef' ref \old -> (old + 1, old)
print val
main = do
ref <- newIORef 0
forkIO $ increment ref
forkIO $ increment ref
increment ref
Im trying to learn MVar and i'm trying to make this text game that is:
The hunt begins at 100 life points and level 1 then
1.One function would do damage to life points in a range of (15,30)
2.Another function would heal life points in a range of (5,10)
3.Adds one level because the player survived
4.Repeats until life point reachs 0
Life points would be a MVar Integer so one function has to wait for the other to finish to change its value (synchronized mutable variable)
I want to repeat theses 2 functions until life points reaches 0 and then shows the level the player reached
This is what i got so far:
import Control.Monad
import Data.Char
import Control.Concurrent
import System.Random
lifePoints :: Integer
lifePoints = 100
damageCalculation :: StdGen -> MVar Integer -> IO Int
damageCalculation gen life = do
let (randDano, newGen) = randomR (15,30) gen :: (Int, StdGen)
a <- readMVar life
let newLife = life - randDano
a <- swapMVar newLife
return a
main :: IO ()
main = do
putStr "Welcome to Hunter of Monsters\n"
putStr "Whats your name? \n"
l <- getLine
putStr "Character\n"
putStrLn ("Name: " ++ l)
let life = lifePoints
putStrLn $ "Life Points: " ++ show life
putStr "The hunt begins\n"
a <- newEmptyMVar
forkIO $ do
putStr "Damage calculation\n"
lifeMVar <- newMVar life
gen <- getStdGen
let rest = damageCalculation gen lifeMVar
putStrLn $ " " ++ show rest
putMVar a ()
takeMVar a
putStrLn "Game over!"
Im having trouble getting a new random number, just repeats one value.
The damage function is simple but i get error trying to change the value of life.
Also how can i repeat these functions until life points reachs 0?
Does the player level needs to be a MVar as well?
There are a number of problems with your code before it'll even compile:
damageCalculation tries to use life as both an MVar Integer (i.e., a "token" for a storage location containing an Integer) and the Integer value itself
you've provided only one argument to swapMVar where it expects two
you've mixed Int and Integer types
in main, you've treated damageCalculation as a pure function instead of an I/O action
Fixing all of these bugs will allow the program to type-check (see Listing #1 below).
However, there are still a number bugs. First, the code:
a <- readMVar life
let newLife = a - randDano
a <- swapMVar life newLife
is subject to a race condition if multiple threads are trying to update the damage. The first line reads the value of the MVar but doesn't perform any kind of locking or synchronization, and the third line then unconditionally writes the new life (while grabbing a copy of the old value).
For example, if two threads try to deduct 10 points of damage each in the following, interleaved fashion, you'll run into a problem:
Thread 1 Thread 2
-------- --------
a <- readMVar life -- fetch 100 life
a <- readMVar life -- fetch 100 life again
let newLife = ... -- deduct 10 to get 90
a <- swapMVar life newLife -- save 90 in the MVar
let newLife = ... -- deduct 10 to get 90
a <- swapMVar life newLife -- save 90 in the MVar
Instead, you want to use the pair of functions takeMVar and putMVar which are designed to provide automatic synchronization:
Thread 1 Thread 2
-------- --------
a <- takeMVar life -- fetch 100 life
a <- takeMVar life -- nothing there, so block...
let newLife = ... -- BLOCKING -- deduct 10 to get 90
a <- putMVar life newLife -- BLOCKING -- save 90 in the MVar
-- WAKE UP -- fetch 90 from MVar
let newLife = ... -- deduct 10 to get 80
a <- putMVar life newLife -- save 80 in the MVar
In my answer to your other question, I had recommended using readMVar and swapMVar, but if you look at that code, you can see that the situation was very different -- one thread only needed to read the current value of the MVar (e.g., reading wHeld to see if "W" was being pressed), and another thread needed to unconditionally write a new value (e.g., writing wHeld to update the current state of the "W" key). No locking was needed, because you just had two threads, one always writing, and one always reading whatever was most recently written.
The second problem with damageCalculation is that I think you want to return the final life value, but you're returning the result of the swapMVar call which will be the old life value before deducting damage. In other words, you probably want return newLife as the last line of your do-block.
The third problem is the way you're using your StdGen. When you write:
let (randDano, newGen) = randomR (15,30) gen :: (Int, StdGen)
the value of gen is used to create a random randDano value, and then an updated value for the generator newGen is returned. If you toss this newGen away and try reusing gen again, you'll always generate the same randDano value. You can either make newGen part of the return value of damageCalculation and use it for the next call, or you can make the generator itself an MVar that gets updated by the damageCalculation function. Since you want practice using MVars, the latter seems like the way to go. So, your damageCalculation function should look like:
damageCalculation :: MVar StdGen -> MVar Int -> IO Int
damageCalculation v_gen v_life = do
gen <- takeMVar v_gen
let (randDano, gen') = randomR (15,30) gen
putMVar v_gen gen'
life <- takeMVar v_life
let life' = life - randDano
putMVar v_life life'
return life'
Note the use of the takeMVar / modify value / putMVar pattern.
In the main function, you probably want to create all the relevant MVars up front before forking, so something like:
main :: IO ()
main = do
putStrLn "Welcome to Hunter of Monsters"
putStrLn "Whats your name?"
l <- getLine
putStrLn "Character"
putStrLn ("Name: " ++ l)
gen <- getStdGen
v_gen <- newMVar gen
putStrLn $ "Life Points: " ++ show lifePoints
v_life <- newMVar lifePoints
done <- newEmptyMVar
putStrLn "The hunt begins"
-- damage stuff here --
takeMVar done
putStrLn "Game over!"
For the damage calculation, if you want to keep doing damage until the life points run out, define a looping function like so and then forkIO it:
let doDamage = do
putStrLn "Damage calculation"
rest <- damageCalculation v_gen v_life
putStrLn $ " " ++ show rest
if rest > 0
then doDamage
else putMVar done ()
forkIO doDamage
The full program is in Listing #2 below.
Listing #1: Getting the program to type-check
import Control.Concurrent
import System.Random
lifePoints :: Int -- use Int throughout
lifePoints = 100
damageCalculation :: StdGen -> MVar Int -> IO Int -- use Int throughout
damageCalculation gen life = do
let (randDano, newGen) = randomR (15,30) gen :: (Int, StdGen)
a <- readMVar life
let newLife = a - randDano -- Use "a" (the value), not "life" (the MVar)
a <- swapMVar life newLife -- "swapMVar" needs an MVar ("life"), not just a value
return a
main :: IO ()
main = do
putStr "Welcome to Hunter of Monsters\n"
putStr "Whats your name? \n"
l <- getLine
putStr "Character\n"
putStrLn ("Name: " ++ l)
let life = lifePoints
putStrLn $ "Life Points: " ++ show life
putStr "The hunt begins\n"
a <- newEmptyMVar
forkIO $ do
putStr "Damage calculation\n"
lifeMVar <- newMVar life
gen <- getStdGen
rest <- damageCalculation gen lifeMVar -- IO action, so use '<-' not 'let'
putStrLn $ " " ++ show rest
putMVar a ()
takeMVar a
putStrLn "Game over!"
Listing #2: Final program with a damage loop
import Control.Concurrent
import System.Random
lifePoints :: Int
lifePoints = 100
damageCalculation :: MVar StdGen -> MVar Int -> IO Int
damageCalculation v_gen v_life = do
gen <- takeMVar v_gen
let (randDano, gen') = randomR (15,30) gen
putMVar v_gen gen'
life <- takeMVar v_life
let life' = life - randDano
putMVar v_life life'
return life'
main :: IO ()
main = do
putStrLn "Welcome to Hunter of Monsters"
putStrLn "Whats your name?"
l <- getLine
putStrLn "Character"
putStrLn ("Name: " ++ l)
gen <- getStdGen
v_gen <- newMVar gen
putStrLn $ "Life Points: " ++ show lifePoints
v_life <- newMVar lifePoints
done <- newEmptyMVar
putStrLn "The hunt begins"
let doDamage = do
putStrLn "Damage calculation"
rest <- damageCalculation v_gen v_life
putStrLn $ " " ++ show rest
if rest > 0
then doDamage
else putMVar done ()
forkIO doDamage
takeMVar done
putStrLn "Game over!"
I was playing around with Haskell lightweight threads (forkIO) with the following code:
import Control.Concurrent
beginTest :: IO ()
beginTest = go
where
go = do
putStrLn "Very interesting string"
go
return ()
main = do
threadID1 <- forkIO $ beginTest
threadID2 <- forkIO $ beginTest
threadID3 <- forkIO $ beginTest
threadID4 <- forkIO $ beginTest
threadID5 <- forkIO $ beginTest
let tID1 = show threadID1
let tID2 = show threadID2
let tID3 = show threadID3
let tID4 = show threadID4
let tID5 = show threadID5
putStrLn "Main Thread"
putStrLn $ tID1 ++ ", " ++ tID2 ++ ", " ++ tID3 ++ ", " ++ tID4 ++ ", " ++ tID5
getLine
putStrLn "Done"
Now the expected output to this would be a whole bunch of these:
Very interesting string
Very interesting string
Very interesting string
Very interesting string
with one of these somewhere in there:
Main Thread
However, the output (or first several lines anyway) turned out to be this:
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very interesting string
Very VVVViMeeeenarrrrtiyyyyen r iiiieTnnnnshtttttreeeeierrrrnaeeeegdssss
ttttsiiiitTnnnnrhggggir nessssgatttt
drrrrIiiiiVdnnnne ggggr5
y1 ,VVVVi eeeenTrrrrthyyyyer reiiiieannnnsdtttttIeeeeidrrrrn eeeeg5ssss 2tttts,iiiit nnnnrTggggih nrssssgetttt
arrrrdiiiiVInnnnedggggr
y5 3VVVVi,eeeen rrrrtTyyyyeh rriiiieennnnsatttttdeeeeiIrrrrndeeeeg ssss 5tttts4iiiit,nnnnr ggggiT nhssssgrtttt
errrraiiiiVdnnnneIggggrd
y 5VVVVi5eeeen
rrrrtyyyye riiiiennnnsttttteeeeirrrrneeeegssss ttttsiiiitnnnnrggggi nssssgtttt
rrrriiiiVnnnneggggr
y VVVVieeeenrrrrtyyyye riiiiennnnsttttteeeeirrrrneeeegssss ttttsiiiitnnnnrggggi nssssgtttt
rrrriiiiVnnnneggggr
Every few lines the text would shift, though it's pretty clear that the Very interesting strings ended up on top of each other, because somehow the threads using putStrLn at the same time ended up writing to stdout on top of each other. Why is this, and how (without resorting to message passing, timing, or some other overcomplicated and convoluted solution) can it be overcome?
Simply put, putStrLn is not an atomic operation. Every character may be interleaved with any other from a different thread.
(I am also not sure about whether in multi-byte encodings such as UTF8 it is guaranteed that a multi-byte character is atomically handled.)
If you want atomicity, you can use a shared mutex e.g.
do lock <- newMVar ()
let atomicPutStrLn str = takeMVar lock >> putStrLn str >> putMVar lock ()
forkIO $ forever (atomicPutStrLn "hello")
forkIO $ forever (atomicPutStrLn "world")
As suggested in the comments below, we can also simplify and make the above exception-safe as follows:
do lock <- newMVar ()
let atomicPutStrLn str = withMVar lock (\_ -> putStrLn str)
forkIO $ forever (atomicPutStrLn "hello")
forkIO $ forever (atomicPutStrLn "world")
A version using global lock.
import Control.Concurrent.MVar (newMVar, takeMVar, putMVar, MVar)
import System.IO.Unsafe (unsafePerformIO)
{-# NOINLINE lock #-}
lock :: MVar ()
lock = unsafePerformIO $ newMVar ()
printer :: String -> IO ()
printer x= do
() <- takeMVar lock
let atomicPutStrLn str = putStrLn str >> putMVar lock ()
atomicPutStrLn x
In the following Haskell code, how to force main thread to wait till all its child threads finish.
I could not able to use forkFinally as given in the section "Terminating the Program" here in this link: (http://hackage.haskell.org/package/base-4.7.0.2/docs/Control-Concurrent.html).
I get desired result when using TMVar. But I want to do this with TVar.
Please help.
module Main
where
import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM
type TInt = TVar Int
transTest :: TInt -> Int -> IO ()
transTest n t = do
atomically $ do
t1 <- readTVar n
doSomeJob t
t2 <- readTVar n
writeTVar n t
doSomeJob :: Int -> STM ()
doSomeJob t = do
x <- newTVar 0
let l = 10^6*t
forM_ [1..l] (\i -> do
writeTVar x i )
main :: IO ()
main = do
n <- newTVarIO 0
let v = 5
forkIO (transTest n v)
let v = 3
forkIO (transTest n v)
let v = 7
forkIO (transTest n v)
let v = 1
forkIO (transTest n v)
r <- atomically $ readTVar n
putStrLn("Last updated value = " ++ (show r))
What I did in the past was to create a little MVar for each forked thread and then use forkFinally to fork the threads such that at the very end, each thread would put a dummy value into the MVar (i.e. I used the MVar as a synchronisation primitive). I could then call takeMVar on those MVars to wait.
I wrapped it into a little helper function:
forkThread :: IO () -> IO (MVar ())
forkThread proc = do
handle <- newEmptyMVar
_ <- forkFinally proc (\_ -> putMVar handle ())
return handle
Using this, your code could be changed to something like
-- Fork four threads
threads <- forM [5, 3, 7, 1] (\v -> forkThread (transTest n v))
-- Wait for all of them
mapM_ takeMVar threads
However, that was before I read the (most excellent) book "Parallel and Concurrent Programming in Haskell" by Simon Marlow, which made me aware of the async package. The package provides an abstraction which not only takes care of all these things, so you can write just
-- Runs 'transTest n {5,3,7,1}' in parallel and waits for all threads
_ <- mapConcurrently (transTest n) [5, 3, 7, 1]
...it also takes care of things such as (asynchronous) exceptions.
I would like to optionally abort a getChar action.
I need the following function:
getChar' :: (Char -> IO ()) -> IO (IO ())
In case of abort <- getChar' callback , a character is read from standard input, unless abort is called before a character is available.
If a character is read, callback is called with it.
I have the following prototype implementation:
import Control.Monad
import Control.Concurrent
getChar' :: (Char -> IO ()) -> IO (IO ())
getChar' callback = do
v <- newEmptyMVar
tid <- forkIO $ do
c <- getChar
b <- tryPutMVar v ()
when b $ callback c
return $ do
b <- tryPutMVar v ()
when b $ killThread tid
The problem is that killThread may abort the thread after reading the char but before putting () into the MVar.
I have no idea how to solve this problem, is it possible at all with the base package?
If not, have you seen a similar function implemented in other packages?
I think the easiest way to achieve this is to perform your own buffering. Here's a simple prototype. It assumes that you call launchIOThread exactly once in your program. It doesn't handle EOF or other IO exceptions, but that should be easy.
import Control.Concurrent
import Control.Concurrent.STM
import Data.Maybe
import Control.Monad
type Buffer = TVar (Maybe Char)
launchIOThread :: IO Buffer
launchIOThread = do
buf <- atomically $ newTVar Nothing
_ <- forkIO $ ioThread buf
return buf
ioThread :: Buffer -> IO ()
ioThread buf = loop where
loop =
join $ atomically $ do
contents <- readTVar buf
if isJust contents -- no-one has taken the character yet
then retry -- relax
else return $ do
c <- getChar
atomically $ writeTVar buf (Just c)
loop
getChar' :: Buffer -> (Char -> IO ()) -> IO (IO ())
getChar' buf callback = do
abortFlag <- atomically $ newTVar False
_ <- forkIO $ doGetChar abortFlag
return $ atomically $ writeTVar abortFlag True
where
doGetChar abortFlag = join $ atomically $ do
mbC <- readTVar buf
abort <- readTVar abortFlag
case mbC of
Just c ->
do writeTVar buf Nothing; return $ callback c
Nothing | abort -> return $ return ()
_ -> retry
What you want to do is use exception-handling constructs such that regardless of exceptions, the MVar is always left in a safe state. In particular, you probably want withMVar.