I'm working through Parallel and Concurrent Programming in Haskell on the Overlapping Input/Output Chapter and I can't understand how async actually works asynchronously.
data Async a = Async (MVar a)
async' :: IO a -> IO (Async a)
async' action = do
var <- newEmptyMVar
forkIO (do r <- action; putMVar var r)
return (Async var)
-- if I desugar the do notation for async:
async'' :: IO a -> IO (Async a)
async'' action = newEmptyMVar >>= \var ->
(forkIO (action >>= \r -> putMVar var r)) >>
(return $ Async var)
wait :: Async a -> IO a
wait (Async var) = readMVar var
blah = do
a1 <- async'' (getURL "http://www.wikipedia.org/wiki/Shovel")
a2 <- async'' (getURL "http://www.wikipedia.org/wiki/Spade")
r1 <- wait a1
r2 <- wait a2
print (B.length r1, B.length r2)
-- if I desguar the above do block I get this, which looks
-- like a2 won't happen until a1 is finished?
blah' = async''(getURL "http://www.wikipedia.org/wiki/Shovel") >>= \a1 ->
async''(getURL "http://www.wikipedia.org/wiki/Spade") >>= \a2 ->
wait a1 >>= \r1 ->
wait a2 >>= \r2 ->
(print (B.length r1, B.length r2))
When I run this no matter what I do, Shovel always resolves before Spade. So how is this running async? I would have expected interleaving sometimes (getting Spade before shovel). Is my exampple just too fast and I'd see this behavior if I made many more examples?
no matter what I do, Shovel always resolves before Spade.
Well, you always ask for the result of shovel before spade via that call to wait coming first. You always start shovel before spade so it isn't surprising if it almost always resolves first too.
A simple test: use threadDelay 100000 >> getURL "...shovel" then look at the network traffic. This will show you things are happening concurrently.
Related
Seems like ForkIO creates as many threads as there are cores in the Haskell program I work with
-- | Fork a thread in checker monad.
fork :: Checker a b () -> Checker a b ()
fork act = do
s0 <- get
void $ liftIO $ forkIO (curTGroup s0) $ evalChecker act s0
occurs :: Eq a => a -> [a] -> Int
occurs x = length . filter (x==)
https://github.com/PLSysSec/sys/blob/821c4d7cf924e68838c128cbe824be46c9955416/src/Static/Check.hs#L73
New to Haskel ForkIO, I wanted to set the thread amount using setNumCapabilities.
Tried adding
let setNumCapabilities = 1
Haskell made a warning about unused var and this didn't make any effect.
How to do it properly?
setNumCapabilities :: Int -> IO () is a function. You thus use it in your code with:
import Control.Concurrent(setNumCapabilities)
fork :: Checker a b () -> Checker a b ()
fork act = do
s0 <- get
void $ liftIO $ do
setNumCapabilities 1
forkIO (curTGroup s0) $ evalChecker act s0
or somewhere else, for example in the main function.
So I wrote my own implementation of StateT because I couldn't get transformers to compile correctly in Haste. I think wanted to get the javascript setInterval working inside my state monad. Here is the ffi call to setInterval.
jsInterval :: Int -> IO () -> IO Int
jsInterval = ffi "(function(t,f){window.setInterval(f,t);})"
I couldn't think of anyway to get the result of m back after it is passed to jsInterval. So I tried to use IORefs.
interval :: Int -> StateT s IO () -> StateT s IO Int
interval i m = StateT $ \s -> do
ref <- newIORef Nothing
id_ <- jsInterval i $ do
(_, s') <- runStateT m s
writeIORef ref (Just s')
s' <- readIORef ref
return (id_, s')
This didn't work because it kept the original state. The read happened before the write. So I wrote a function that would poll in a loop until the IORef was written but this just hung forever.
interval :: Int -> StateT s IO () -> StateT s IO Int
interval i m = StateT $ \s -> do
ref <- newIORef Nothing
id_ <- jsInterval i $ do
(_, s') <- runStateT m s
writeIORef ref (Just s')
s' <- go ref
return (id_, s')
where
go ref = do
s <- readIORef ref
case s of
Nothing -> go ref
Just s' -> return s'
Is it possible to implement this function? I tried writing an instance of MonadEvent for StateT but that was also unsuccessful.
The IO action you are passing to your FFI'ed jsInterval is just a plain IO action. If you implement that action using runStateT you are just running a little 'local' StateT. It's unrelated to the enclosing code.
This is a generic problem with callbacks and monad stacks - callbacks (in the sense that the IO() parameter to jsInterval is a callback) have a fixed monad chosen in their definition and they have no way to generalise to other monadic effects you might be using elsewhere.
Since callbacks - in general - can be called at any time, including multiple times at once, in different threads, after the calling function has completed and its state has been destroyed - you can see that this is hard problem to solve in general.
The pragmatic answer is, as you have tried, to just use an IORef; create the IORef in the enclosing action and let the callback modify it. You can still write the callback in StateT style if you wish - just extract the state from the IORef and pass it to runStateT. Your code doesn't do this, you are just referencing the parameter s from the top-level : you need to use the IORef, something like this:
id_ <- jsInterval i $ do
current_s <- readIORef ref
(_, new_s) <- runStateT m current_s
writeIORef ref (new_s)
You can't really use Maybe unless you are prepared to teach the action m how to cope with a Maybe - it need to deal with the Nothing, so perhaps you want it to have the type StateT (Maybe s) IO () ?
A second logic problem (?) with your code is that certainly the s returned by interval will not have been changed yet - the setInterval code can't possibly have been triggered until javascript goes back into its idle loop.
The general problem of passing callbacks has been discussed a few times over the years, see:
https://mail.haskell.org/pipermail/haskell-cafe/2007-July/028501.html
http://andersk.mit.edu/haskell/monad-peel/
http://blog.sigfpe.com/2011/10/quick-and-dirty-reinversion-of-control.html
etc.
I'm trying to work out if it's possible to write an abstraction for the following situation. Suppose I have a type a with function a -> m Bool e.g. MVar Bool and readMVar. To abstract this concept out I create a newtype wrapper for the type and its function:
newtype MPredicate m a = MPredicate (a,a -> m Bool)
I can define a fairly simple operation like so:
doUnless :: (Monad m) => Predicate m a -> m () -> m ()
doUnless (MPredicate (a,mg)) g = mg a >>= \b -> unless b g
main = do
b <- newMVar False
let mpred = MPredicate (b,readMVar)
doUnless mpred (print "foo")
In this case doUnless would print "foo". Aside: I'm not sure whether a type class might be more appropriate to use instead of a newtype.
Now take the code below, which outputs an incrementing number then waits a second and repeats. It does this until it receives a "turn off" instruction via the MVar.
foobar :: MVar Bool -> IO ()
foobar mvb = foobar' 0
where
foobar' :: Int -> IO ()
foobar' x = readMVar mvb >>= \b -> unless b $ do
let x' = x + 1
print x'
threadDelay 1000000
foobar' x'
goTillEnter :: MVar Bool -> IO ()
goTillEnter mv = do
_ <- getLine
_ <- takeMVar mv
putMVar mv True
main = do
mvb <- newMVar False
forkIO $ foobar mvb
goTillEnter mvb
Is it possible to refactor foobar so that it uses MPredicate and doUnless?
Ignoring the actual implementation of foobar' I can think of a simplistic way of doing something similar:
cycleUnless :: x -> (x -> x) -> MPredicate m a -> m ()
cycleUnless x g mp = let g' x' = doUnless mp (g' $ g x')
in g' $ g x
Aside: I feel like fix could be used to make the above neater, though I still have trouble working out how to use it
But cycleUnless won't work on foobar because the type of foobar' is actually Int -> IO () (from the use of print x').
I'd also like to take this abstraction further, so that it can work threading around a Monad. With stateful Monads it becomes even harder. E.g.
-- EDIT: Updated the below to show an example of how the code is used
{- ^^ some parent function which has the MVar ^^ -}
cycleST :: (forall s. ST s (STArray s Int Int)) -> IO ()
cycleST sta = readMVar mvb >>= \b -> unless b $ do
n <- readMVar someMVar
i <- readMVar someOtherMVar
let sta' = do
arr <- sta
x <- readArray arr n
writeArray arr n (x + i)
return arr
y = runSTArray sta'
print y
cycleST sta'
I have something similar to the above working with RankNTypes. Now there's the additional problem of trying to thread through the existential s, which is not likely to type check if threaded around through an abstraction the likes of cycleUnless.
Additionally, this is simplified to make the question easier to answer. I also use a set of semaphores built from MVar [MVar ()] similar to the skip channel example in the MVar module. If I can solve the above problem I plan to generalize the semaphores as well.
Ultimately this isn't some blocking problem. I have 3 components of the application operating in a cycle off the same MVar Bool but doing fairly different asynchronous tasks. In each one I have written a custom function that performs the appropriate cycle.
I'm trying to learn the "don't write large programs" approach. What I'd like to do is refactor chunks of code into their own mini libraries so that I'm not building a large program but assembling lots of small ones. But so far this particular abstraction is escaping me.
Any thoughts on how I might go about this are very much appreciated!
You want to cleanly combine a stateful action having side effects, a delay, and an independent stopping condition.
The iterative monad transformer from the free package can be useful in these cases.
This monad transformer lets you describe a (possibly nonending) computation as a series of discrete steps. And what's better, it let's you interleave "stepped" computations using mplus. The combined computation stops when any of the individual computations stops.
Some preliminary imports:
import Data.Bool
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.Iter (delay,untilJust,IterT,retract,cutoff)
import Control.Concurrent
Your foobar function could be understood as a "sum" of three things:
A computation that does nothing but reading from the MVar at each step, and finishes when the Mvar is True.
untilTrue :: (MonadIO m) => MVar Bool -> IterT m ()
untilTrue = untilJust . liftM guard . liftIO . readMVar
An infinite computation that takes a delay at each step.
delays :: (MonadIO m) => Int -> IterT m a
delays = forever . delay . liftIO . threadDelay
An infinite computation that prints an increasing series of numbers.
foobar' :: (MonadIO m) => Int -> IterT m a
foobar' x = do
let x' = x + 1
liftIO (print x')
delay (foobar' x')
With this in place, we can write foobar as:
foobar :: (MonadIO m) => MVar Bool -> m ()
foobar v = retract (delays 1000000 `mplus` untilTrue v `mplus` foobar' 0)
The neat thing about this is that you can change or remove the "stopping condition" and the delay very easily.
Some clarifications:
The delay function is not a delay in IO, it just tells the iterative monad transformer to "put the argument in a separate step".
retract brings you back from the iterative monad transformer to the base monad. It's like saying "I don't care about the steps, just run the computation". You can combine retract with cutoff if you want to limit the maximum number of iterations.
untilJustconverts a value m (Maybe a) of the base monad into a IterT m a by retrying in each step until a Just is returned. Of course, this risks non-termination!
MPredicate is rather superfluous here; m Bool can be used instead. The monad-loops package contains plenty of control structures with m Bool conditions. whileM_ in particular is applicable here, although we need to include a State monad for the Int that we're threading around:
import Control.Monad.State
import Control.Monad.Loops
import Control.Applicative
foobar :: MVar Bool -> IO ()
foobar mvb = (`evalStateT` (0 :: Int)) $
whileM_ (not <$> lift (readMVar mvb)) $ do
modify (+1)
lift . print =<< get
lift $ threadDelay 1000000
Alternatively, we can use a monadic version of unless. For some reason monad-loops doesn't export such a function, so let's write it:
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM mb action = do
b <- mb
unless b action
It's somewhat more convenient and more modular in a monadic setting, since we can always go from a pure Bool to m Bool, but not vice versa.
foobar :: MVar Bool -> IO ()
foobar mvb = go 0
where
go :: Int -> IO ()
go x = unlessM (readMVar mvb) $ do
let x' = x + 1
print x'
threadDelay 1000000
go x'
You mentioned fix; sometimes people indeed use it for ad-hoc monadic loops, for example:
printUntil0 :: IO ()
printUntil0 =
putStrLn "hello"
fix $ \loop -> do
n <- fmap read getLine :: IO Int
print n
when (n /= 0) loop
putStrLn "bye"
With some juggling it's possible to use fix with multi-argument functions. In the case of foobar:
foobar :: MVar Bool -> IO ()
foobar mvb = ($(0 :: Int)) $ fix $ \loop x -> do
unlessM (readMVar mvb) $ do
let x' = x + 1
print x'
threadDelay 1000000
loop x'
I'm not sure what's your MPredicate is doing.
First, instead of newtyping a tuple, it's probably better to use a normal algebric data type
data MPredicate a m = MPredicate a (a -> m Bool)
Second, the way you use it, MPredicate is equivalent to m Bool.
Haskell is lazzy, therefore there is no need to pass, a function and it's argument (even though
it's usefull with strict languages). Just pass the result, and the function will be called when needed.
I mean, instead of passing (x, f) around, just pass f x
Of course, if you are not trying to delay the evaluation and really need at some point, the argument or the function as well as the result, a tuple is fine.
Anyway, in the case your MPredicate is only there to delay the function evaluation, MPredicat reduces to m Bool and doUnless to unless.
Your first example is strictly equivalent :
main = do
b <- newMVar False
unless (readMVar b) (print "foo")
Now, if you want to loop a monad until a condition is reach (or equivalent) you should have a look at the monad-loop package. What you are looking it at is probably untilM_ or equivalent.
I'm trying to write a convenient abstraction to thottle api calls. The API calls will be some kind of HTTP request. I want to be able to write all the app logic as if I were just in the IO Monad but then have the abstraction throttle the calls for me so I don't surpass some predefined limit. Having these calls run asynchronously would be nice. Right now I have this.
data APICallStats = APICallStats
{
startTime :: !UTCTime
, requestCount :: !Int
, tps :: !Int
} deriving Show
newtype APICall a = APICall (IO a)
initStats :: Int -> IO APICallStats
initStats limit = APICallStats <$> getCurrentTime <*> pure 0 <*> pure limit
makeCall :: MVar APICallStats -> APICall a -> IO a
makeCall mv (APICall f) = do
(APICallStats st c t) <- readMVar mv
now <- getCurrentTime
let inSeconds = realToFrac (diffUTCTime now st) :: Double
cp1 = fromIntegral (c+1)
td = fromIntegral t
when (cp1 / inSeconds > td)
(threadDelay (round $ (cp1 / td - inSeconds)*1000000))
modifyMVar_ mv
(\(APICallStats start req ts) -> return $ APICallStats start (req+1) ts)
f
And I can test it like this. And it works fine in a single or multiple threads because of the MVar.
testCall :: String -> APICall ()
testCall id = APICall (getCurrentTime >>= (putStrLn . ((++) (id ++ " ")) . show))
test :: IO ()
test = do
mv <- initStats 1 >>= newMVar
forever $ makeCall mv (testCall "")
threadedTest :: IO ()
threadedTest = do
mv <- initStats 1 >>= newMVar
threadId <- forkIO $ forever $ makeCall mv (testCall "thread0")
forever $ makeCall mv (testCall "main thread")
killThread threadId
This is nice and all but it is not as abstract as I want it to be. Since there will only be a couple specific API calls I can have them return the type APICall a. And then make this a monad that is an instance of MonadIO so I can just write my logic and use liftIO when I need to. But I'm unsure if I would be able to make this a monad that didn't break the laws and how exactly to go about it.
EDIT
I think I've gotten pretty close to what I want it to do.
withThrottle :: Int -> StateT (MVar APICallStats) IO a -> IO a
withThrottle limit f = do
mv <- initStats limit >>= newMVar
evalStateT f mv
process :: APICall a -> StateT (MVar APICallStats) IO a
process a = do
mv <- get
liftIO $ makeCall mv a
With this I can write something like this.
stateTest = do
withThrottle 2 $ do
process (testCall "")
process (testCall "")
process (testCall "")
liftIO $ threadDelay 10000000 -- Some long computation
process (testCall "")
process (testCall "")
process (testCall "")
process (testCall "")
With a long running app the entire thing can run is this monad. This will guarantee that It doesn't make too many outside API calls over the lifetime of the service. I just don't want the state monad. Just something that is MonadIO. So I think I just need to hide that and I'll be done. But the solution isn't very pretty so other suggestions welcome.
Browsing the source of readChan one finds the following implementation and comment, starting with version 4.6 of base:
-- |Read the next value from the 'Chan'.
readChan :: Chan a -> IO a
readChan (Chan readVar _) = do
modifyMVarMasked readVar $ \read_end -> do -- Note [modifyMVarMasked]
(ChItem val new_read_end) <- readMVar read_end
-- Use readMVar here, not takeMVar,
-- else dupChan doesn't work
return (new_read_end, val)
-- Note [modifyMVarMasked]
-- This prevents a theoretical deadlock if an asynchronous exception
-- happens during the readMVar while the MVar is empty. In that case
-- the read_end MVar will be left empty, and subsequent readers will
-- deadlock. Using modifyMVarMasked prevents this. The deadlock can
-- be reproduced, but only by expanding readMVar and inserting an
-- artificial yield between its takeMVar and putMVar operations.
Prior to base version 4.6, modifyMVar was used rather than modifyMVarMasked.
I don't understand what theoretical problem is solved for here. The last sentence states there is a problem if the thread yields between the takeMVar and putMVar that comprise readMVar. But as readMVar executes under mask_, how can an async exception prevent the put after successful take?
Any help understanding the issue here is appreciated.
Let's compare the source of modifyMVar and modifyMVarMasked, since the code changed from using one to using the other:
modifyMVar m io =
mask $ \restore -> do
a <- takeMVar m
(a',b) <- restore (io a) `onException` putMVar m a
putMVar m a'
return b
modifyMVarMasked m io =
mask_ $ do
a <- takeMVar m
(a',b) <- io a `onException` putMVar m a
putMVar m a'
return b
The key here is that modifyMVar calls restore before executing its second argument, whereas modifyMVarMasked does not. So readMVar was not called under mask_ in the old version of the code as you claim in your question! It was called under restore, instead, and therefore asynchronous exceptions could be enabled after all.
Here's me working through it.
So in readMVar...
readMVar :: MVar a -> IO a
readMVar m =
mask_ $ do
a <- takeMVar m
putMVar m a
return a
...despite the mask_ the runtime may raise an exception in a blocked takeMVar. Note in that function there's no need to actually handle that case; either the readMVar worked, in which case we're safe from async exceptions, or the takeMVar never succeeds; either way we never break the MVar by leaving it empty. (Is this correct? This is what I took away from the answer to my own related question.)
modifyMVar and modifyMVarMasked are:
modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
modifyMVar m io =
mask $ \restore -> do
a <- takeMVar m
(a',b) <- restore (io a) `onException` putMVar m a
putMVar m a'
return b
modifyMVarMasked :: MVar a -> (a -> IO (a,b)) -> IO b
modifyMVarMasked m io =
mask_ $ do
a <- takeMVar m
(a',b) <- io a `onException` putMVar m a
putMVar m a'
return b
...where the difference is in modifyMVar the masking state is restored (i.e. async exceptions probably become unmasked) in io a, which in our case is more or less readMVar.
EDIT: Although readMVar is mask_-ed as well, so now I can't see why either choice of modifyMVarMasked or modifyMVar would make a difference...
The comment seems to imply that yield (inserted into readMVar) is interruptible (I can't find this documented anywhere) and so an async exception might be raised, in which case readVar would be restored (in both current and pre-4.6 versions), but in a non-empty queue readers would see an empty one and block.
You may be interested in reading the GHC trac on this commit, which has a sample program that consistently reproduces this bug when both Control.Concurrent.Chan and the test program are compiled -O0
https://ghc.haskell.org/trac/ghc/ticket/6153
In a similar vein:
https://ghc.haskell.org/trac/ghc/ticket/5870