I want a small operation where one thread adds to a shared state some value, while another thread takes the value out and prints it. Here are two versions using TMVar and MVar respectively. The TMVar version is not working somehow, it keeps printing out the first value. What is the problem in the STM first version? How to fix the first TMVar version to make it work?
import Control.Concurrent (forkIO, takeMVar,newEmptyMVar,putMVar)
import Control.Monad (forM_, replicateM_)
import Control.Concurrent.STM (atomically, readTMVar, putTMVar, newEmptyTMVarIO)
n=10
main = do
mvar<- newEmptyTMVarIO
forkIO $ do
forM_ [1..n] $ \x-> atomically $ do
putTMVar mvar $! x
replicateM_ n $ do
a<- atomically $ readTMVar mvar
print $ show a
main2 = do
mvar<- newEmptyMVar
forkIO $ do
mapM_ (\x-> putMVar mvar x) [1..n]
replicateM_ n $ do
a<- takeMVar mvar
print $ show a
You're using readTMVar, which just looks at what's in the TMVar. I imagine you mean to use takeTMVar to give the other thread a chance to put something new in it.
Related
I'm trying to use hinotify and STM to make a simple concept:
Block the thread of execution until the watched file stops being modified
Continue once modifications stop, or their interval is larger than some time threshold (debounces)
Currently, I'm trying to use a TSem to get this working correctly, but I keep running into either of these problems:
the thread doesn't block at all, and I end up removing the hinotify watcher before it even starts, throwing an exception
the thread blocks indefinitely, causing STM to throw an exception
the program prints 3 times (3 concurrent notifications), but only lasts for 1 second and not 10
The code I've written is below, and can be checked out on github to see for yourself.
module Main where
import System.INotify
import System.Environment (getArgs)
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM
import Control.Concurrent.STM.TSem
import Control.Concurrent.STM.TVar
import Control.Monad (forM_)
main :: IO ()
main = do
[file] <- getArgs
-- make changes every 1/10th of a second for 10 seconds
forkIO $ forM_ [0..100] $ \s -> do
appendFile file $ show s
threadDelay (second `div` 10)
debouncer <- atomically $ newTSem 0
notif <- initINotify
expectation <- newTVarIO (0 :: Int)
watcher <- addWatch notif [Modify] file $ \e -> do
e' <- atomically $ do
modifyTVar expectation (+1)
readTVar expectation
print e
threadDelay second
e'' <- readTVarIO expectation
if e' == e''
then atomically $ signalTSem debouncer
else pure ()
atomically $ waitTSem debouncer
removeWatch watcher
killINotify notif
second = 1000000
Do you see anything immediately wrong with what I'm trying to do?
Does it have to be STM? You can achieve you goal with ordinary MVars:
#!/usr/bin/env stack
{- stack
--resolver lts-7.9
--install-ghc runghc
--package hinotify
--package stm
-}
import System.INotify
import System.Environment (getArgs)
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.MVar (newMVar, newEmptyMVar, readMVar, swapMVar, putMVar, takeMVar, modifyMVar_)
import Control.Monad (forM_, forever)
main :: IO ()
main = do
[file] <- getArgs
mainBlocker <- newEmptyMVar
tickCounter <- newMVar 0
-- make changes every 1/10th of a second for 10 seconds
forkIO $ forM_ [0..100] $ \s -> do
appendFile file $ show s
threadDelay (second `div` 10)
-- set up file watches
notif <- initINotify
watcher <- addWatch notif [Modify] file $ \e -> do
swapMVar tickCounter 10
print "file has been modified; reset ticks to 10"
-- 'decreaser' thread
forkIO $ forever $ do
threadDelay second
ticks <- readMVar tickCounter
print $ "current ticks in decreaser thread: " ++ show ticks
if ticks <= 0
then putMVar mainBlocker ()
else modifyMVar_ tickCounter (\v -> return (v-1))
takeMVar mainBlocker
print "exiting..."
removeWatch watcher
killINotify notif
second = 1000000
The idea is a 'tick' counter that gets set to 10 whenever the file has been modified. A separate thread tries to count down to 0 and, when it succeeds, releases the block of the main thread.
If you use stack you can execute the code as a script like this:
stack theCode.hs fileToBeWatched
The following program creates two threads running concurrently, that each sleep for a random amount of time, before printing a line of text to stdout.
import Control.Concurrent
import Control.Monad
import System.Random
randomDelay t = randomRIO (0, t) >>= threadDelay
printer str = forkIO . forever $ do
randomDelay 1000000 -- μs
putStrLn str
main = do
printer "Hello"
printer "World"
return ()
The output generally looks something like
>> main
Hello
World
World
Hello
WoHrelld
o
World
Hello
*Interrupted
>>
How do you ensure that only one thread can write to stdout at a time? This seems like the kind of thing that STM should be good at, but all STM transactions must have the type STM a for some a, and an action that prints to the screen has type IO a, and there doesn't seem to be a way to embed IO into STM.
The way to handle output with STM is to have an output queue that is shared between all threads and which is processed by a single thread.
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
import System.Random
randomDelay t = randomRIO (0, t) >>= threadDelay
printer queue str = forkIO . forever $ do
randomDelay 1000000 -- μs
atomically $ writeTChan queue str
prepareOutputQueue = do
queue <- newTChanIO
forkIO . forever $ atomically (readTChan queue) >>= putStrLn
return queue
main = do
queue <- prepareOutputQueue
printer queue "Hello"
printer queue "World"
return ()
Locking in the way you're describing isn't possible usingSTM. This is because STM is based on optimistic locking and so every transaction must be restartable at any point. If you embedded an IO operation into STM, it could be executed multiple times.
Probably the easiest solution for this problem is to use a MVar as a lock:
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad
import System.Random
randomDelay t = randomRIO (0, t) >>= threadDelay
printer lock str = forkIO . forever $ do
randomDelay 1000000
withMVar lock (\_ -> putStrLn str)
main = do
lock <- newMVar ()
printer lock "Hello"
printer lock "World"
return ()
In this solution the lock is passed as an argument to printer.
Some people prefer to declare the lock as a top-level global variable, but currently this requires unsafePerformIO and relies on properties of GHC that AFAIK aren't part of the Haskell Language Report (in particular, it relies on the fact that a global variable with non-polymorphic type is evaluated at most once during the execution of a program).
A bit of research, based on Petr Pudlák's answer shows that there is a module Control.Concurrent.Lock in the concurrent-extra package that provides an abstraction around MVar ()-based locks.
The solution using that library is
import Control.Concurrent
import qualified Control.Concurrent.Lock as Lock
import Control.Monad
import System.Random
randomDelay t = randomRIO (0, t) >>= threadDelay
printer lock str = forkIO . forever $ do
randomDelay 1000
Lock.with lock (putStrLn str)
main = do
lock <- Lock.new
printer lock "Hello"
printer lock "World"
return ()
This is the example using global lock as mentioned by Petr.
import Control.Concurrent
import Control.Monad
import System.Random
import Control.Concurrent.MVar (newMVar, takeMVar, putMVar, MVar)
import System.IO.Unsafe (unsafePerformIO)
{-# NOINLINE lock #-}
lock :: MVar ()
lock = unsafePerformIO $ newMVar ()
printer x = forkIO . forever $ do
randomDelay 100000
() <- takeMVar lock
let atomicPutStrLn str = putStrLn str >> putMVar lock ()
atomicPutStrLn x
randomDelay t = randomRIO (0, t) >>= threadDelay
main = do
printer "Hello"
printer "World"
return ()
You can actually implement a lock using STM if you want, though an MVar will almost certainly perform better.
newtype Lock = Lock (TVar Status)
data Status = Locked | Unlocked
newLocked :: IO Lock
newLocked = Lock <$> newTVarIO Locked
newUnlocked :: IO Lock
newUnlocked = Lock <$> newTVarIO Unlocked
-- | Acquire a lock.
acquire :: Lock -> IO ()
acquire (Lock tv) = atomically $
readTVar tv >>= \case
Locked -> retry
Unlocked -> writeTVar tv Locked
-- | Try to acquire a lock. If the operation succeeds,
-- return `True`.
tryAcquire :: Lock -> IO Bool
tryAcquire (Lock tv) = atomically $
readTVar tv >>= \case
Locked -> pure False
Unlocked -> True <$ writeTVar tv Locked
-- | Release a lock. This version throws an exception
-- if the lock is unlocked.
release :: Lock -> IO ()
release (Lock tv) = atomically $
readTVar tv >>= \case
Unlocked -> throwSTM DoubleRelease
Locked -> writeTVar tv Unlocked
data DoubleRelease = DoubleRelease deriving Show
instance Exception DoubleRelease where
displayException ~DoubleRelease = "Attempted to release an unlocked lock."
-- | Release a lock. This version does nothing if
-- the lock is unlocked.
releaseIdempotent :: Lock -> IO ()
releaseIdempotent (Lock tv) = atomically $ writeTVar tv Unlocked
-- | Get the status of a lock.
isLocked :: Lock -> IO Status
isLocked (Lock tv) = readTVarIO tv
acquire/release pairs need careful masking and exception handling, much like primitive MVar operations. The documentation suggests, but does not actually state, that STM operations are interruptible when they retry; assuming this is true, the same approach used for withMVar will work here. Note: I've opened a GHC ticket to document retry interruptibility.
AFAIK TChan acts as a hub, every message sent is seen by others right ?!
i want a TChan that acts as a switch to send a message to specific thread, and also support broadcasting.
is there such thing ?
Edit: I re-read your question. This answer doesn't quite address "selective send", though it clarifies what a TChan can do.
The "broadcast" approach described below will wake up all listeners (though on the bright side, it won't make 1000 copies of each item). To avoid this, use the Map approach as #Mikhail suggested. I did this in my chat server example.
A TChan is a FIFO queue:
writeTChan adds an item to the end.
readTChan reads an item from the beginning.
For example, the following example forks 10 threads which fight over a single channel:
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
main = do
chan <- newTChanIO
forM_ [1..10] $ \i ->
forkIO $
forever $ do
x <- atomically $ readTChan chan
putStrLn $ "Thread " ++ show i ++ ": " ++ show x
mapM_ (atomically . writeTChan chan) [1..1000]
-- Wait for channel to empty out
atomically $ do
empty <- isEmptyTChan chan
when (not empty) retry
Here, each item is read by exactly one thread.
In contrast, the following example "broadcasts" a stream of items to 10 threads, by making ten copies of the channel using dupTChan:
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
main = do
master <- newTChanIO
forM_ [1..10] $ \i -> do
chan <- atomically $ dupTChan master
forkIO $
forever $ do
x <- atomically $ readTChan chan
putStrLn $ "Thread " ++ show i ++ ": " ++ show x
mapM_ (atomically . writeTChan master) [1..100]
-- Give threads time to complete
threadDelay 1000000
Now each thread gets all of the items written to the channel.
A couple subtleties to note:
Items written to a channel prior to dupTChan will not appear in the new channel. If we called dupTChan from the child threads rather than the main thread, some writeTChans could happen first, meaning the children might not see all the items.
Since nobody is reading the master channel, items written to it will pile up and will likely not be garbage collected. To avoid this caveat, use newBroadcastTChan to create the master channel.
I'm writing a simple script to run bunch of tasks in parallel using the Shelly library but I want to limit the max number of tasks running at any one time. The script takes a file with an input on each line and runs a task for that input. There are a few hundred inputs in the file and I want to limit to around 16 processes at a time.
The current script actually limits to 1 (well tries to) using a QSem with an initial count of 1. I seem to be missing something though because when I run on a test file with 4 inputs I see this:
Starting
Starting
Starting
Starting
Done
Done
Done
Done
So the threads are not blocking on the QSem as I would expect, they're all running simultaneously. I've even gone so far as to implement my own semaphores both on MVar and TVar and neither worked the way I expected. I'm obviously missing something fundamental but what? I've also tried compiling the code and running it as a binary.
#!/usr/bin/env runhaskell
{-# LANGUAGE TemplateHaskell, QuasiQuotes, DeriveDataTypeable, OverloadedStrings #-}
import Shelly
import Prelude hiding (FilePath)
import Text.Shakespeare.Text (lt)
import qualified Data.Text.Lazy as LT
import Control.Monad (forM)
import System.Environment (getArgs)
import qualified Control.Concurrent.QSem as QSem
import Control.Concurrent (forkIO, MVar, putMVar, newEmptyMVar, takeMVar)
-- Define max number of simultaneous processes
maxProcesses :: IO QSem.QSem
maxProcesses = QSem.newQSem 1
bkGrnd :: ShIO a -> ShIO (MVar a)
bkGrnd proc = do
mvar <- liftIO newEmptyMVar
_ <- liftIO $ forkIO $ do
-- Block until there are free processes
sem <- maxProcesses
QSem.waitQSem sem
putStrLn "Starting"
-- Run the shell command
result <- shelly $ silently proc
liftIO $ putMVar mvar result
putStrLn "Done"
-- Signal that this process is done and another can run.
QSem.signalQSem sem
return mvar
main :: IO ()
main = shelly $ silently $ do
[img, file] <- liftIO $ getArgs
contents <- readfile $ fromText $ LT.pack file
-- Run a backgrounded process for each line of input.
results <- forM (LT.lines contents) $ \line -> bkGrnd $ do
runStdin <command> <arguments>
liftIO $ mapM_ takeMVar results
As I said in my comment, each call to bkGrnd creates its own semaphonre, allowing every thread to continue without waiting. I would try something like this instead, where the semaphore is created in the main and passed each time to bkGrnd.
bkGrnd :: QSem.QSem -> ShIO a -> ShIO (MVar a)
bkGrnd sem proc = do
mvar <- liftIO newEmptyMVar
_ <- liftIO $ forkIO $ do
-- Block until there are free processes
QSem.waitQSem sem
--
-- code continues as before
--
main :: IO ()
main = shelly $ silently $ do
[img, file] <- liftIO $ getArgs
contents <- readfile $ fromText $ LT.pack file
sem <- maxProcesses
-- Run a backgrounded process for each line of input.
results <- forM (LT.lines contents) $ \line -> bkGrnd sem $ do
runStdin <command> <arguments>
liftIO $ mapM_ takeMVar results
You have an answer, but I need to add: QSem and QSemN are not thread safe if killThread or asynchronous thread death is possible.
My bug report and patch are GHC trac ticket #3160. The fixed code is available as a new library called SafeSemaphore with module Control.Concurrent.MSem, MSemN, MSampleVar, and a bonus FairRWLock.
Isn't it better
bkGrnd sem proc = do
QSem.waitQSem sem
mvar <- liftIO newEmptyMVar
_ <- liftIO $ forkIO $ do
...
so not even forkIO until you get the semaphore?
I'm using
import Control.Concurrent.ParallelIO.Global
main = parallel_ (map processI [1..(sdNumber runParameters)]) >> stopGlobalPool
where
processI :: Int -> IO ()
is some function, which reads data from file, processes it and writes it to another file. No output to terminal. The problem is when I run the program with +RTS -N8 the terminal is flooded with random text like
piptufuht teata thtsieieo ocnsno e nscsdeoe qnqvuduee ernvnstetiirioasanlil lolwynya. .s
w
a s s uY Ysosopuuue's'nvpvdeeee n dpdp rerdodoub beada
bub lel y
What is happening? Without +RTS there is no clutter. I couldn't reproduce the behavior with a more simple (suitable to post here) program.
GHC 7.0.3 if that matters
Buffering is probably preventing you from constructing a simple test case. I was able to reproduce it with this (only when run with +RTS -Nsomething):
import Control.Concurrent
import System.IO
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
forkIO $ putStrLn "foo"
forkIO $ putStrLn "bar"
forkIO $ putStrLn "baz"
threadDelay 1000 -- Allow things to print
As Thomas mentioned, you'll probably need to sequence this somehow, though I'm not sure how writing straight to files would change this. Here's a simple example how you can sequence this with a Chan. I'm sure there's a better way to do this, this is just an example of how I got this to not garble the output.
import Control.Concurrent
import Control.Concurrent.Chan
import System.IO
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
ch <- newChan -- Things written here are picked up by stuffWriter
forkIO $ stuffWriter ch -- Fire up concurrent stuffWriter
forkIO $ writeChan ch "foo"
forkIO $ writeChan ch "bar"
forkIO $ writeChan ch "baz"
threadDelay 1000 -- Allow things to print
-- | Write all the things!
stuffWriter :: Chan String -> IO ()
stuffWriter ch = do
readChan ch >>= putStrLn -- Block, then write once I've got something
stuffWriter ch -- loop... looking for more things to write
Now your writes to somewhere are now synchronous (stuffWriter writes things, one at a time), and you should have no more garbling.