This question already has an answer here:
Haskell computationally intensive thread blocks all other threads
(1 answer)
Closed 11 months ago.
I am having hard time to understand Haskell's memory model. I got stuck implementing a simple lock-free hash map and while trying to reproduce the error on a smaller example I realized I have no idea what is going on.
I am only targeting x86_64
data TicketLock = TicketLock {cur :: !(IORef Int), next :: !(IORef Int)}
testTicket = do
l <- TicketLock <$> newIORef 0 <*> newIORef 0
mapConcurrently_ (\x -> replicateM_ 500000 (lockunlock l)) [0 .. 3]
print "finished"
lockunlock :: TicketLock -> IO ()
lockunlock (TicketLock {..}) = do
myticket <- atomicModifyIORef' next (\a -> (a + 1, a))
let wait = do
x <- readIORef cur -- atomicModifyIORef' cur (\a -> (a, a)) works correctly
unless (x == myticket) wait
wait
print "lock acquired" -- to observe it gets stuck
atomicModifyIORef' cur (\a -> (a + 1, ())) -- unlock
The test gets stuck after a couple of thousand iterations.
What is going wrong with this code? I kind of expect it to fail because I guess iorefs can be reordered by compiler but i can't figure out what exactly is going on. Is it observable in generated STG code or cmm code?
My real question is why adding barriers does not fix the problem? I tried adding barriers (from atomics-primops package) after every line of the lockunlock function and problem still continues.
I also tried using AtomicCounter from atomic-primops package, the problem is the same, even though incrCounter is implemented by fetch-add instruction the test somehow gets stuck after couple of thousand iterations, even with barriers all over the code.
data BetterTicketLock = BetterTicketLock {curb :: !(AtomicCounter), nextb :: !(AtomicCounter)}
testTicketb = do
l <- BetterTicketLock <$> newCounter 1 <*> newCounter 0
mapConcurrently_ (\x -> replicateM_ 500000 (lockunlockb l)) [0 .. 3]
print "finished"
lockunlockb :: BetterTicketLock -> IO ()
lockunlockb (BetterTicketLock {..}) = do
myticket <- incrCounter 1 nextb -- it returns new value not old value
let wait = do
x <- incrCounter 0 curb -- I am not even using readCounter which is similar to readIOref
unless (x == myticket) wait
wait
print "lock acquired"
void $ incrCounter 1 curb
Ideally i want a way to reason about haskell programs like in rust using acquire-release semantics how is the following can be converted to Haskell?
struct TicketLock { current: AtomicUsize, next: AtomicUsize}
impl TicketLock {
fn new() -> Self{
TicketLock {current: AtomicUsize::new(0),next: AtomicUsize::new(0)}
}
fn lockunlock(&self) {
let ticket = self.next.fetch_add(1, Ordering::Relaxed);
while self.current.load(Ordering::Acquire) != ticket { }
// critical section
let _ = self.current.fetch_add(1, Ordering::Release);
}
}
Edit: For some reason this works as expected without any performance penalty. Is it because of barriers being ignored in tight loops?
lockunlock (TicketLock {..}) s = do
myticket <- atomicModifyIORef' next (\a -> (a + 1, a))
let wait = do
x <- readIORef cur
unless (x == myticket) $ threadDelay 0 >> wait
wait
modifyIORef' s (+ 1)
atomicModifyIORef' cur (\a -> (a + 1, ())) -- unlock
You're running into a pathological case with the implementation of pre-emptive multitasking in GHC. See the documentation of the Control.Concurrent module:
GHC implements pre-emptive multitasking: the execution of threads are interleaved in a random fashion. More specifically, a thread may be pre-empted whenever it allocates some memory, which unfortunately means that tight loops which do no allocation tend to lock out other threads (this only seems to happen with pathological benchmark-style code, however).
Your wait loop seems to not allocate anything, so it cannot be pre-empted. You can solve this issue by inserting a manual yield:
lockunlock :: TicketLock -> IO ()
lockunlock (TicketLock{..}) = do
myticket <- atomicModifyIORef' next (\a -> (a + 1, a))
let wait = do
x <- readIORef cur
unless (x == myticket) (yield *> wait)
wait
print "lock acquired"
atomicModifyIORef' cur (\a -> (a + 1, ()))
Alternatively, you can compile with -fno-omit-yields.
I haven't been able to figure anything more out by trying to debug using the eventlog, because even that seems to be blocked. As K.A. Buhr remarks below he has written a better answer:
Less obviously, the same thing can happen even if you compile with -threaded and use +RTS -N options. The problem is that an uncooperative thread can starve out the runtime scheduler itself. If at some point the uncooperative thread is the only thread currently scheduled to run, it will become uninterruptible, and the scheduler will never be re-run to consider scheduling additional threads, even if they could run on other O/S threads.
Related
I've read in multiple places that the writer monad of a list keeps that full list in memory, and therefore shouldn't be used in anything other than small samples (no logging, for instance).
For instance, read here
However, to test the claim, I wrote the following program, and actually showed that it successfully outputs an infinite list lazily!
import Control.Monad.Writer
createInfiniteList :: Int -> Writer [Int] ()
createInfiniteList i = do
tell [i]
createInfiniteList (i+1)
main :: IO ()
main = do
let x = execWriter $ createInfiniteList 1
print x
I've watched this program output over 1 billion items (it runs very fast), and monitored that the memory usage never went past 0.1% on my machine.
Has the writer monad been rewritten to fix the original problem? Can I count on it continuing to work this way in the future?
note- I am aware that better logging monads exist (I use those elsewhere)... My desired use case is not logging (but it is similar)
There are two factors at play here. The way the <>/mappend calls are nested, and whether the entire log is kept in memory.
How are the <> calls nested?
This depends on how you write your code using Writer, not on Writer's implementation. To see why, lets cheat.
data Tree a = Nil | Leaf a | Node (Tree a) (Tree a)
deriving (Show)
instance Semigroup (Tree a)
where x <> y = Node x y
instance Monoid (Tree a)
where mempty = Nil
This is not a proper monoid, since <> is not associative. x <> (y <> z) gives Node x (Node y z) whereas (x <> y) <> z) gives Node (Node x y) z. It allows us to tell after the fact whether the Writer's "log" was reduced left-nested or right nested.
go :: Int -> Writer (Tree Int) ()
go i
| i < 5
= do tell (Leaf i)
go (i+1)
| otherwise
= pure ()
main :: IO ()
main = do
let (result, log) = runWriter $ go 1
putStrLn (render log)
render Nil = "Nil"
render (Leaf x) = show x
render (Node x y) = "(" ++ render x ++ ") <> (" ++ render y ++ ")"
With this, you get: (1) <> ((2) <> ((3) <> ((4) <> (Nil))))
Clearly right-nested. Hence how you could generate an infinite list as the "log" of a Writer and consume it as it was generated in a relatively small amount of space.
But swap the order of the tell and the recursion, so that it looks like this:
go :: Int -> Writer (Tree Int) ()
go i
| i < 5
= do go (i+1)
tell (Leaf i)
| otherwise
= pure ()
And you get this: ((((Nil) <> (4)) <> (3)) <> (2)) <> (1). Now it's left-nested, infinite recursion does not work:
import Control.Monad.Writer
createInfiniteList :: Int -> Writer [Int] ()
createInfiniteList i = do
createInfiniteList (i+1)
tell [i]
main :: IO ()
main = do
let x = execWriter $ createInfiniteList 1
print x
This never prints anything, and consumes an ever-growing amount of memory.
Basically the structure of the <> calls is similar to the structure of your Writer expressions. Everywhere you bind in a call to another function (including the equivalent in a do-block), all of the <> calls resulting from that call will be "inside parentheses". So tell _ >> recurse results in right-nested <>s, while recurse >> tell _ results in left-nested <>s, and more complex call-graphs result in similarly-structured nesting of <>s.
Forcing the result builds the entire log
Another particular thing about your test program is that it doesn't use the "result" of the Writer at all, only the "log". Obviously if the recursion is infinite there's never any final result at all, but if we change your program like so:
import Control.Monad.Writer
createLargeList :: Int -> Writer [Int] ()
createLargeList i
| i < 50000000
= do tell [i]
createLargeList (i+1)
| otherwise
= pure ()
main :: IO ()
main = do
let (result, log) = runWriter $ createLargeList 1
print $ length log
print result
Then it behaves similarly; length consumes the list as it is produced and completes in short order (and relatively low memory usage). After that the () is readily available and is printed immediately.
But if we change it to print the result first:
import Control.Monad.Writer
createLargeList :: Int -> Writer [Int] ()
createLargeList i
| i < 50000000
= do tell [i]
createLargeList (i+1)
| otherwise
= pure ()
main :: IO ()
main = do
let (result, log) = runWriter $ createLargeList 1
print result
print $ length log
Then on my system this takes much longer, and consumes nearly 15 GB of RAM1. It does have to materialise the log fully in RAM just to get at the final result, even when the <>s are right-nested and the log can be consumed lazily.
Technically I believe it is not building the list in memory, but rather a chain of thunks applying <> to singleton lists, which is just as long as the final list and probably uses more memory per link in the chain. The resulting list is still consumed by length as it is generated by forcing those thunks, but that doesn't really help since the entire thunk chain had to be generated to get at the final () result, instead of having the thunk chain itself generates as length demands more of the list.
1 That's compiling like ghc foo.hs; if I compile with -O2 then it behaves similarly to printing the length of the log first. This is a fairly simple case for GHC to inline everything and figure out a better way of computing the same result; I wouldn't assume its optimisations could address this problem if the program were more complicated.
The program below works if run with runhaskell or if compiled but not with -O2. If compiled with -O2 it seems to hang.
I'm using GHC 7.10.2.
I've changed the min/max iterations to 10 and 20 respectively. It will
generate anywhere from 20 to 100 MB of output into the file test.out.
Run time is about 15 - 60 secs.
Program Explanation
Below is a multi-threaded program that has a pool of workers and a manager. The workers generate traces to be used in plotting a Buddhabrot, put it in a queue, and a manager periodically empties the queue and writes the data to disk. When a certain amount of data has been generated, the program stops.
But when the program runs the manager thread only does one check, and then it gets stuck (the worker threads are still running). However, if I remove the part where the manager thread writes to file, then everything seems to work. I just don't understand why...
import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Monad
( forever
, unless
)
import Control.Monad.Loops
import System.IO
import System.Random
import qualified Data.Binary as B
import qualified Data.ByteString.Lazy as BS
type Coord = (Double, Double)
type Trace = [Coord]
-- | Represents a rectangle in the complex plane, bounded by a lower left
-- coordinate and an upper right coordinate.
data Plane
= Plane { ll :: Coord, ur :: Coord }
deriving (Show)
-- | Adds two coordinates.
(+.) :: Coord -> Coord -> Coord
(r1, i1) +. (r2, i2) = (r1 + r2, i1 + i2)
-- | Multiplies two coordinates.
(*.) :: Coord -> Coord -> Coord
(r1, i1) *. (r2, i2) = (r1*r2 - i1*i2, r1*i2 + r2*i1)
-- | Computes the square of a coordinate.
square :: Coord -> Coord
square (r, i) = (r*r - i*i, 2*r*i)
-- | Distance from origin to a given coordinate.
distFromOrigin :: Coord -> Double
distFromOrigin (r, i) = r*r + i*i
-- | A structure for passing data to the worker threads.
data WorkerData
= WorkerData { wdMinIt :: Int
, wdMaxIt :: Int
, wdTraceQueue :: TQueue Trace
-- ^ A queue of traces to be written to disk.
}
-- | A structure for passing data to the manager thread.
data ManagerData
= ManagerData { mdOutHandle :: Handle
-- ^ Handle to the output file.
, mdNumTraces :: Integer
-- ^ Number of traces to gather.
, mdTraceQueue :: TQueue Trace
-- ^ A queue of traces to be written to disk.
}
-- | Encodes an entity to binary bytestring.
encode :: B.Binary a => a -> BS.ByteString
encode = B.encode
-- | Writes a lazy bytestring to file.
writeToFile :: Handle -> BS.ByteString -> IO ()
writeToFile = BS.hPut
mkManagerData :: TQueue Trace -> IO ManagerData
mkManagerData t_queue =
do let out_f = "test.out"
out_h <- openBinaryFile out_f WriteMode
let num_t = 1000
return $ ManagerData { mdOutHandle = out_h
, mdNumTraces = num_t
, mdTraceQueue = t_queue
}
mkWorkerData :: TQueue Trace -> IO WorkerData
mkWorkerData t_queue =
do let min_it = 10 -- 1000
max_it = 20 -- 10000
return $ WorkerData { wdMinIt = min_it
, wdMaxIt = max_it
, wdTraceQueue = t_queue
}
-- | The actions to be performed by the manager thread.
runManager :: ManagerData -> IO ()
runManager m_data =
do execute 0
return ()
where execute count =
do new_traces <- purgeTQueue $ mdTraceQueue m_data
let new_count = count + (toInteger $ length new_traces)
putStrLn $ "Found " ++ (show $ new_count) ++ " traces so far. "
if length new_traces > 0
then do putStrLn $ "Writing new traces to file..."
_ <- mapM (writeToFile (mdOutHandle m_data))
(map encode new_traces)
putStr "Done"
else return ()
putStrLn ""
unless (new_count >= mdNumTraces m_data) $
do threadDelay (1000 * 1000) -- Sleep 1s
execute new_count
-- | The actions to be performed by a worker thread.
runWorker :: WorkerData -> IO ()
runWorker w_data =
forever $
do c <- randomCoord
case computeTrace c (wdMinIt w_data) (wdMaxIt w_data) of
Just t -> atomically $ writeTQueue (wdTraceQueue w_data) t
Nothing -> return ()
-- | Reads all values from a given 'TQueue'. If any other thread reads from the
-- same 'TQueue' during the execution of this function, then this function may
-- deadlock.
purgeTQueue :: Show a => TQueue a -> IO [a]
purgeTQueue q =
whileJust (atomically $ tryReadTQueue q)
(return . id)
-- | Generates a random coordinate to trace.
randomCoord :: IO Coord
randomCoord =
do x <- randomRIO (-2.102613, 1.200613)
y <- randomRIO (-1.237710, 1.239710)
return (x, y)
-- | Computes a trace, using the classical Mandelbrot function, for a given
-- coordinate and minimum and maximum iteration count. If the length of the
-- trace is less than the minimum iteration count, or exceeds the maximum
-- iteration count, 'Nothing' is returned.
computeTrace
:: Coord
-> Int
-- ^ Minimum iteration count.
-> Int
-- ^ Maximum iteration count.
-> Maybe Trace
computeTrace c0 min_it max_it =
if isUsefulCoord c0
then let step c = square c +. c0
computeIt c it = if it < max_it
then computeIt (step c) (it + 1)
else it
computeTr [] = error "computeTr: empty list"
computeTr (c:cs) = if length cs < max_it
then computeTr (step c:(c:cs))
else (c:cs)
num_it = computeIt c0 0
in if num_it >= min_it && num_it <= max_it
then Just $ reverse $ computeTr [c0]
else Nothing
else Nothing
-- | Checks if a given coordinate is useful by checking if it belongs in the
-- cardioid or period-2 bulb of the Mandelbrot.
isUsefulCoord :: Coord -> Bool
isUsefulCoord (x, y) =
let t1 = x - 1/4
p = sqrt (t1*t1 + y*y)
is_in_cardioid = x < p - 2*p*p + 1/4
t2 = x + 1
is_in_bulb = t2*t2 + y*y < 1/16
in not is_in_cardioid && not is_in_bulb
main :: IO ()
main =
do t_queue <- newTQueueIO
m_data <- mkManagerData t_queue
w_data <- mkWorkerData t_queue
let num_workers = 1
workers <- mapM async (replicate num_workers (runWorker w_data))
runManager m_data
_ <- mapM cancel workers
_ <- mapM waitCatch workers
putStrLn "Tracing finished"
Why It Fails
After reviewing the answers below, I finally realized why it doesn't work as intended. The program does not hang, but the time it takes for the manager thread to encode a single trace is in the order of tens of seconds (and when encoded it consumes several megabytes)! This means that even if there are some tens of traces in the queue when exhausted -- on my machine the workers manage to produce about 250 traces before the queue is exhausted by the manger thread -- it will take forever before the next exhaust.
Hence it matters little what solution I choose unless the work of the manager thread is greatly reduced. For that, I will have to abandon my idea of dumping each individual trace to file and instead process it once generated.
The problem is two-fold:
(1) The manager thread doesn't process any
Traces until it has exhausted the queue.
(2) The worker thread can add elements to the queue very, very quickly.
This results in a race that the manager thread rarely wins. [ This also explains the observed behavior with -O2 - the optimization just made the worker thread faster. ]
Adding some debugging code shows that the worker can add
items to the queue in excess of 100K Traces per second.
Moreover, even though the manager is only interested in
writing out the first 1000 Traces, the worker doesn't
stop at this limit. So, under certain circumstances,
the manager is never able to exit this loop:
purgeTQueue q =
whileJust (atomically $ tryReadTQueue q)
(return . id)
The simplest way to fix the code is to have the
manager thread use readTQueue to read and process just one
item off the queue at a time. This will also block
the manager thread when the queue us empty obviating
the need to the manager thread to periodically sleep.
Changing purgeTQueue to:
purgeTQueue = do item <- atomically $ readTQueue (mdTraceQueue m_data)
return [item]
and removing the threadDelay from runManager fixes the problem.
Example code available in the Lib4.hs module at: https://github.com/erantapaa/mandel
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'm trying to create a simple counter which increases by 1 indefinitely, using IO.
I've been scratching my head ever since...
Ideally, I would like to do something along the lines of
tick = do putStr (counter)
counter + 1
where counter = 0
Then repeat the process. Then repeat the first 2 expressions. Or something along the lines of:
tick = tick'
where
counter = 1
tick' counter | counter > 0 = do putStrLn (show counter)
tick' (counter + 1)
| otherwise = tick
Which gives me errors :/
Any help is appreciated :)
There are a couple ways to do this without using a mutable cell. You already did it with your second attempt, there's just a little error. You need to pass an initial value to the tick' function, not "set it" (haskell does not have an idea of assigning variables -- only definitions. If the line x = y appears, x will be y for its entire lifetime).
tick = tick' 0
where ...
The counter = 0 line is not doing anything; it is defining a name that is never used. The counter used in the tick' function is bound as one of its arguments (and shadows the one defined to be 0). Take some time to stare at it with that in mind, see if that makes sense.
There is a nice "higher order" way we can do this too. Essentially we want to run the infinitely long block of code:
do
print 0
print 1
print 2
...
There is a function called sequence :: [IO a] -> IO [a] (see caveat below) that will take a list of actions and construct an action. So if we can construct the list [print 0, print 1, print 2, ...] then we can pass it to sequence to build the infinitely long block we are looking for.
Take note here, this is a very important concept in Haskell: [print 0, print 1, print 2] does not print those three numbers then construct the list [0,1,2]. Instead it is itself a list of actions, whose type is [IO ()]. Making the list does nothing; it is only when you bind an action to main that it will be executed. For example, we might say:
main = do
let xs = [putStrLn "hello", getLine >> putStrLn "world"]
xs !! 0
xs !! 0
xs !! 1
xs !! 1
xs !! 0
This would twice print hello, twice get a line and print world after each, then once print hello again.
With that concept, it is easy to build the list of actions [print 0, print 1, ...] with a list comprehension:
main = sequence [ print x | x <- [0..] ]
We can simplify a bit:
main = sequence (map (\x -> print x) [0..])
main = sequence (map print [0..])
So map print [0..] is the list of actions [print 0, print 1, ...] we were looking for, then we just pass that to sequence which chains them together.
This pattern of sequence is common, and has its own mapM:
mapM :: (a -> IO b) -> [a] -> IO [b]
mapM f xs = sequence (map f xs)
Thus:
main = mapM print [0..]
About as simple as you could want.
One note about performance: since we are not using the output of these functions, we should be using sequence_ and mapM_, with trailing underscores, which are optimized for that purpose. Usually this wouldn't matter in a Haskell program because of garbage collection, but in this particular use case is kind of a special case because of various subtleties. You'll find that without the _s, the memory usage of your program gradually grows as the list of results (in this case [(),(),(),...]) is constructed but never used.
Caveat: I have given the type signatures of sequence and mapM specialized to IO, not a general monad, so that the reader does not have to learn about the orthogonal concepts of actions having types and typeclasses at the same time.
Well, let's go back to basics. What you want appears to be an IO action that when bound, prints and increments a counter? I'm going to work from that assumption.
The first thing you need is some mutable cell, since you're using the same action each time. It needs to have something mutable inside it to do something different each time it's used. I'd go with an IORef for this case.
But keeping that IORef hidden is a bit tricky. Especially since globals are bad. The best way to do it is create the IO action from inside another IO action, and then close over the IORef. Doing so gives you something like this:
import Data.IORef
mkCounter :: IO (IO ())
mkCounter = do
ref <- newIORef 0
return $ do
counter <- readIORef ref
print counter
writeIORef ref $ counter + 1
This can be used by doing something like this:
main = do
tick <- mkCounter
tick
tick
tick
Your second implementation is really close!
tick = tick'
where
counter = 1
tick' counter | counter > 0 = do putStrLn (show counter)
tick' (counter + 1)
| otherwise = tick
Let's look at the errors for this:
Couldn't match expected type `IO b0' with actual type `a0 -> IO b0'
In the expression: tick'
Let's add some types to make sure we're getting what we want.
tick is an IO action. We don't care what value the action encapsulates, since the whole
point of it is to run forever.
tick :: IO a
Now our error is:
Couldn't match expected type `IO a' with actual type `a0 -> IO b0'
In the expression: tick'
Well, that's pretty much the same, no help there. Let's keep going.
tick' is a function that takes some integer and returns an IO action
that prints the integer and repeats tick' on the next value. Again, we don't care what
value the action encapsulates, since it runs forever.
tick' :: Int -> IO b
Wait, now that error makes sense! We defined tick = tick', but the two things have fundamentally different types. One is an action (tick) one is a function that returns an action (tick'). All we need to do is give tick' some value to get the action, so let's do that.
You'd tried to do that by saying where counter = 1 but all that did is define counter as 1 within the statement tick = tick', and since counter isn't mentioned there, it wasn't used.
When you said tick' counter | ... =, you weren't referring to the same counter as on the line above. There, you were defining another variable called counter that was only in scope within the definition of tick'.
So now our code looks like:
tick :: IO a
tick = tick' 1
where
tick' :: Int -> IO b
tick' counter | counter > 0 = do putStrLn (show counter)
tick' (counter + 1)
| otherwise = tick
If we try to compile it, ghc doesn't complain, and if we try it out in ghci it runs as desired:
% ghci
ghci> :l Tick.hs
Ok, modules loaded: Tick.
ghci> tick
1
2
3
...
25244
^C
Interrupted
ghci>
For a simple infinite counter just use recursion:
counter n = do print n
counter (n+1)
main = counter 1
Yet another way to implement tick functionality without using mutable state is to mix State and IO monad using monad transformers:
import Control.Monad.State
type Ticking a = StateT Int IO a
tick :: Ticking ()
tick = do
modify succ
get >>= liftIO . print
getCounterValue :: Ticking Int
getCounterValue = get
Then you can use it to create 'ticking' IO functions (with nuisance: IO functions here need to be prefixed with liftIO since it is now Ticking a monad not IO a):
ticking :: Ticking ()
ticking = do
liftIO $ putStrLn "Starting"
tick
tick
c <- getCounterValue
liftIO $ do
putStrLn ("Finished at " ++ show c)
putStrLn "Press any Enter to start infinite counter"
getChar
forever tick
Which can be converted into 'normal' IO using runStateT (with initial counter value):
startTicking :: Ticking a -> Int -> IO a
startTicking = evalStateT
So:
main :: IO ()
main = startTicking ticking 0
A forkIO safe version similar to Carl's answer using STM is
import Control.Concurrent.STM
import Control.Monad (replicateM_)
import Control.Monad(forever)
makeCounter :: IO (IO Int)
makeCounter = do
var <- newTVarIO 0
return $ do
atomically $ do
value <- readTVar var
modifyTVar var (+1)
readTVar var
-- a version that only counts from 1 to 10
main1:: IO ()
main1 = do
counter <- makeCounter
replicateM_ 10 $ counter >>= print
-- a version that counters forever
main2 :: IO ()
main2 = do
counter <- makeCounter
forever $ do
x<- counter
print x
main :: IO ()
main = do
counter <- makeCounter
tick<- counter
tick<- counter
print tick -- 2
Reference:
Mutable closures in Haskell and nested IO
An EXERCISE from STM tutorial
Mutable State in Haskell
I'm a Haskell beginner and thought this would be good exercise. I have an
assignment where I need to read file in a thread A, handle the file lines
in threads B_i, and then output the results in thread C.
I have implemented this far already, but one of the requirements is that we
cannot trust that the entire file fits into memory. I was hoping that lazy
IO and garbage collector would do this for me, but alas the memory usage
keeps rising and rising.
The reader thread (A) reads the file with readFile which is then zipped
with line numbers and wrapped in Just. These zipped lines are then written
to Control.Concurrent.Chan. Each consumer thread B has its own channel.
Each consumer reads their own channel when it has data and if the regex
matches, it's outputted to their own respective output channel wrapped
within Maybe (made of lists).
The printer checks the output channel of each of the B threads. If none of
the results (line) is Nothing, the line is printed. Since at this point
there should be no reference to the older lines, I thought that the garbage
collector would be able to release these lines, but alas I seem to be in
the wrong here.
The .lhs file is in here:
http://gitorious.org/hajautettujen-sovellusten-muodostamistekniikat/hajautettujen-sovellusten-muodostamistekniikat/blobs/master/mgrep.lhs
So the question is, how do I limit the memory usage, or allow the garbage
collector to remove the lines.
Snippets as per requested. Hopefully indenting isn't too badly destroyed :)
data Global = Global {done :: MVar Bool, consumers :: Consumers}
type Done = Bool
type Linenum = Int
type Line = (Linenum, Maybe String)
type Output = MVar [Line]
type Input = Chan Line
type Consumers = MVar (M.Map ThreadId (Done, (Input, Output)))
type State a = ReaderT Global IO a
producer :: [Input] -> FilePath -> State ()
producer c p = do
liftIO $ Main.log "Starting producer"
d <- asks done
f <- liftIO $ readFile p
mapM_ (\l -> mapM_
(liftIO . flip writeChan l) c)
$ zip [1..] $ map Just $ lines f
liftIO $ modifyMVar_ d (return . not)
printer :: State ()
printer = do
liftIO $ Main.log "Starting printer"
c <- (fmap (map (snd . snd) . M.elems)
(asks consumers >>= liftIO . readMVar))
uniq' c
where head' :: Output -> IO Line
head' ch = fmap head (readMVar ch)
tail' = mapM_ (liftIO . flip modifyMVar_
(return . tail))
cont ch = tail' ch >> uniq' ch
printMsg ch = readMVar (head ch) >>=
liftIO . putStrLn . fromJust . snd . head
cempty :: [Output] -> IO Bool
cempty ch = fmap (any id)
(mapM (fmap ((==) 0 . length) . readMVar ) ch)
{- Return false unless none are Nothing -}
uniq :: [Output] -> IO Bool
uniq ch = fmap (any id . map (isNothing . snd))
(mapM (liftIO . head') ch)
uniq' :: [Output] -> State ()
uniq' ch = do
d <- consumersDone
e <- liftIO $ cempty ch
if not e
then do
u <- liftIO $ uniq ch
if u then cont ch else do
liftIO $ printMsg ch
cont ch
else unless d $ uniq' ch
Concurrent programming offers no defined execution order unless you enforce one yourself with mvars and the like. So its likely that the producer thread sticks all/most of the lines in the chan before any consumer reads them off and passes them on. Another architecture that should fit the requirements is just have thread A call the lazy readfile and stick the result in an mvar. Then each consumer thread takes the mvar, reads a line, then replaces the mvar before proceeding to handle the line. Even then, if the output thread can't keep up, then the number of matching lines stored on the chan there can build up arbitrarily.
What you have is a push architecture. To really make it work in constant space, think in terms of demand driven. Find a mechanism such that the output thread signals to the processing threads that they should do something, and such that the processing threads signal to the reader thread that they should do something.
Another way to do this is to have chans of limited size instead -- so the reader thread blocks when the processor threads haven't caught up, and so the processor threads block when the output thread hasn't caught up.
As a whole, the problem in fact reminds me of Tim Bray's widefinder benchmark, although the requirements are somewhat different. In any case, it led to a widespread discussion on the best way to implement multicore grep. The big punchline was that the problem is IO bound, and you want multiple reader threads over mmapped files.
See here for more than you'll ever want to know: http://www.tbray.org/ongoing/When/200x/2007/09/20/Wide-Finder