I'm having a little bit of trouble with threading (using STM) and combining that with GTK (http://hackage.haskell.org/package/gtk-0.12.3).
I have a function that loops indefinitely, ticking every 2 seconds, which prints the contents of a list, then clears the list, defined like
data VirtualHelicopter = VirtualHelicopter { getOrders :: TVar [(Option, Int)] }
run :: VirtualHelicopter -> IO ()
run h = do
forever ( (putStrLn . show =<< (atomRead orders))
>> clearOrders orders
>> milliSleep 2000)
where
orders = getOrders h
atomRead = atomically . readTVar
clearOrders x = atomically $ writeTVar x []
milliSleep = threadDelay . (*) 1000
Additionally, I have a GUI function, defined as
runGUI :: VirtualHelicopter -> IO ()
runGUI flyer = do
Gtk.initGUI
~ GUI set up stuff, some key listeners that write to the TVar inside flyer ~
forkIO $ run flyer
Gtk.mainGUI
If I forkIO the "run" function from inside GHCI, everything works fine - it ticks every 2 seconds, printing to the console and updating the queue with anything I add into it using the TVar from the flyer.
However, when I try to forkIO from within the GUI, it no longer ticks every two seconds - it just kind of hangs until I put in some input, then gives unreliable outputs.
Anyone have any idea why this happens? You can see the whole project this is from, with full context at https://github.com/tetigi/majom, which is a Haskell extension of this project idea http://procrastineering.blogspot.co.uk/2011/11/computer-controlling-syma-helicopter.html. The threading implementation is on the "threadingForVHeli" branch.
As hammar said, adding -threaded to the build options solved it. I didn't realise there was a compiler option for threaded things!
I'll also work on clearing up the race condition that was mentioned :)
Related
My code needs to fire multiple threads and keep track of which have finished and which are still running. I as planning on using waitAny or waitAnyCatch, but was thrown off by the following in the documentation
If multiple Asyncs complete or have completed, then the value returned corresponds to the first completed Async in the list.
If that is really the case, how does one ever keep track of running / exited threads reliably?
Here's my simplified code:
chan <- newChan
currentThreadsRef <- newIORef []
-- read jobs from a channel, and run them in parallel asyncs/threads,
-- while adding all threads references to currentThreadsRef
async $ do
jobArgs <- readChan chan
jobAsync <- async $ runJob jobArgs
atomicallyModifyIORef' currentThreadsRef $ \x -> (jobAsync:x, ())
-- wait for jobs to be finished, and remove the thread refernece
-- from currentThreadsRef
waitForAllJobs currentJobsRef = do
(readIORef currentJobsRef) >>= \case
[] -> logDebug "All jobs exited"
currentJobs -> do
(exitedJob, jobResult) <- waitAnyCatch currentJobs
atomicallyModifyIORef currentJobsRef $ \x -> (filter (/= exitedjob) x, ())
logDebug $ "Job completed with result=" <> show result
waitForAllJobs currentJobsRef
PS: Although it may not be obvious from my simplified code above, there is a reason why I cannot simply use mapConcurrently over the input-data. Actually, async-pool seems like a good fit for my use-case, but even that has the same problem with waitAny.
Here's a program that launches 1000 asyncs all set to terminate within a second and waits for them all in a loop. Compiled with ghc -O2 -threaded and run with +RTS -N, it runs in about 1.5 seconds, and none of the asyncs gets "lost":
import Control.Concurrent
import Control.Concurrent.Async
import qualified Data.Set as Set
main :: IO ()
main = do
let n = 1000 :: Int
asyncs0 <- mapM (\i -> async (threadDelay 1000000 >> return i)) [1..n]
let loop :: Set.Set (Async Int) -> IO ()
loop asyncs | null asyncs = return ()
| otherwise = do
(a, _i) <- waitAny (Set.toList asyncs)
loop (Set.delete a asyncs)
loop (Set.fromList asyncs0)
So, as was mentioned in a comment, the documentation is referring to the fact that the first completed async in the provided list is the one that will be "returned", but if multiple asyncs have completed, the additional ones aren't "forgotten". You just need to remove the returned async from the list and re-poll, and you'll eventually get them all.
So, you shouldn't have any trouble waiting on multiple asyncs with waitAny.
I'm trying to write a safe timing-out evaluation function in Haskell. The code goes as follows
import System.Timeout
compute, compute' :: Int -> Int
compute i = sum [1..300000 + i]
compute' i = last $ repeat i
timedComp :: Int -> a -> IO (Maybe a)
timedComp timeLeft toCompute =
timeout timeLeft go
where
go = toCompute `seq` return toCompute
main = do
res <- timedComp 10000 (compute 0)
print res
res' <- timedComp 10000 (compute' 0)
print res'
(I know that I only evaluate to WHNF.)
When I run main, I get only one Nothing on output and then the program hangs. I tried to compile and run the program multi-threaded but it doesn't help. Tried on both GHC 7.6.3 and 7.8.3. Any suggestions?
There's a limitation in the GHC implementation of Haskell threads: context switches occur only during allocation. As a consequence, tight loops which perform no allocation at all can prevent the scheduler to run, switching to other threads.
This is one of such examples: compute' i = last $ repeat i looks as if it's allocating list cells, but unfortunately GHC is able to optimize it as a trivial infinite loop, removing all allocation -- GHC Core looks roughly as f x = f x. This triggers the scheduler shortcoming.
Reid Barton suggests the option -fno-omit-yields to work around this. This will cause GHC not to optimize so much.
I am reading a button's state (whether being pressed or not) every moment:
readButton :: IO Boolean
readButton = ...
main = do
(add, fire) <- newAddHandler
network <- compile (desc add)
actuate network
forever $ do
buttonState <- readButton
fire buttonState
desc addButtonEvent = do
eButtonState <- fromAddHandler addButtonEvent
...
All the read states are stored into eButtonState in the network description desc.
The button is considered to be newly pressed when the current moment's state is 1 with the previous moment's being 0. So, if the event sequence was a list, the function would be written like this:
f :: [Bool] -> Bool
f (True:False:_) = True
f _ = False
I want to apply this function to eButtonState so I would know whether the button is newly pressed or not in the moment.
Is it ever possible? How would you do it? I would appreciate if there is a better or more common idea or method to achieve this goal.
Here is one way (this is a runnable demo):
import Reactive.Banana
import Reactive.Banana.Frameworks
import Control.Monad
import Control.Applicative -- Needed if you aren't on GHC 7.10.
desc addDriver = do
-- Refreshes the button state. Presumably fired by external IO.
eButtonDriver <- fromAddHandler addDriver
let -- Canonical repersentation of the button state.
bButtonState = stepper False eButtonDriver
-- Observes the button just before changing its state.
ePreviousState = bButtonState <# eButtonDriver
-- Performs the test your f function would do.
newlyPressed :: Bool -> Bool -> Bool
newlyPressed previous current = not previous && current
-- Applies the test. This works because eButtonDriver and
-- ePreviousState are fired simultaneously.
eNewlyPressed = unionWith newlyPressed
ePreviousState eButtonDriver
-- The same but more compactly, without needing ePreviousState.
{-
eNewlyPressed = newlyPressed <$> bButtonState <#> eButtonDriver
-}
reactimate (print <$> eNewlyPressed)
main = do
(addDriver, fireDriver) <- newAddHandler
network <- compile (desc addDriver)
actuate network
-- Demo: enter y to turn the button on, and any other string to
-- turn it off.
forever $ do
buttonState <- (== "y") <$> getLine
fireDriver buttonState
Notes:
Events are transient, behaviors are permanent is a good general rule to decide whether you need a behavior or an event stream. In this case, you need to look at what the button state was before the update in order to decide whether it was newly updated. The natural thing to do, then, is to represent the button state with a behavior (bButtonState), which is updated by an event fired externally (eButtonDriver).
For details about what the combinators are doing, see Reactive.Banana.Combinators.
For the fine print on the timing of events and behavior updates in reactive-banana, see this question.
Depending on what you are trying to do, the changes function might be useful. Be aware of the caveats related to it mentioned by the documentation.
I'm toying with Haskell threads, and I'm running into the problem of communicating lazily-evaluated values across a channel. For example, with N worker threads and 1 output thread, the workers communicate unevaluated work and the output thread ends up doing the work for them.
I've read about this problem in various documentation and seen various solutions, but I only found one solution that works and the rest do not. Below is some code in which worker threads start some computation that can take a long time. I start the threads in descending order, so that the first thread should take the longest, and the later threads should finish earlier.
import Control.Concurrent (forkIO)
import Control.Concurrent.Chan -- .Strict
import Control.Concurrent.MVar
import Control.Exception (finally, evaluate)
import Control.Monad (forM_)
import Control.Parallel.Strategies (using, rdeepseq)
main = (>>=) newChan $ (>>=) (newMVar []) . run
run :: Chan (Maybe String) -> MVar [MVar ()] -> IO ()
run logCh statVars = do
logV <- spawn1 readWriteLoop
say "START"
forM_ [18,17..10] $ spawn . busyWork
await
writeChan logCh Nothing -- poison the logger
takeMVar logV
putStrLn "DONE"
where
say mesg = force mesg >>= writeChan logCh . Just
force s = mapM evaluate s -- works
-- force s = return $ s `using` rdeepseq -- no difference
-- force s = return s -- no-op; try this with strict channel
busyWork = say . show . sum . filter odd . enumFromTo 2 . embiggen
embiggen i = i*i*i*i*i
readWriteLoop = readChan logCh >>= writeReadLoop
writeReadLoop Nothing = return ()
writeReadLoop (Just mesg) = putStrLn mesg >> readWriteLoop
spawn1 action = do
v <- newEmptyMVar
forkIO $ action `finally` putMVar v ()
return v
spawn action = do
v <- spawn1 action
modifyMVar statVars $ \vs -> return (v:vs, ())
await = do
vs <- modifyMVar statVars $ \vs -> return ([], vs)
mapM_ takeMVar vs
Using most techniques, the results are reported in the order spawned; that is, the longest-running computation first. I interpret this to mean that the output thread is doing all the work:
-- results in order spawned (longest-running first = broken)
START
892616806655
503999185040
274877906943
144162977343
72313663743
34464808608
15479341055
6484436675
2499999999
DONE
I thought the answer to this would be strict channels, but they didn't work. I understand that WHNF for strings is insufficient because that would just force the outermost constructor (nil or cons for the first character of the string). The rdeepseq is supposed to fully evaluate, but it makes no difference. The only thing I've found that works is to map Control.Exception.evaluate :: a -> IO a over all the characters in the string. (See the force function comments in the code for several different alternatives.) Here's the result with Control.Exception.evaluate:
-- results in order finished (shortest-running first = correct)
START
2499999999
6484436675
15479341055
34464808608
72313663743
144162977343
274877906943
503999185040
892616806655
DONE
So why don't strict channels or rdeepseq produce this result? Are there other techniques? Am I misinterpreting why the first result is broken?
There are two issues going on here.
The reason the first attempt (using an explicit rnf) doesn't work is that, by using return, you've created a thunk that fully evaluates itself when it is evaluated, but the thunk itself has not being evaluated. Notice that the type of evaluate is a -> IO a: the fact that it returns a value in IO means that evaluate can impose ordering:
return (error "foo") >> return 1 == return 1
evaluate (error "foo") >> return 1 == error "foo"
The upshot is that this code:
force s = evaluate $ s `using` rdeepseq
will work (as in, have the same behavior as mapM_ evaluate s).
The case of using strict channels is a little trickier, but I believe this is due to a bug in strict-concurrency. The expensive computation is actually being run on the worker threads, but it's not doing you much good (you can check for this explicitly by hiding some asynchronous exceptions in your strings and seeing which thread the exception surfaces on).
What's the bug? Let's take a look at the code for strict writeChan:
writeChan :: NFData a => Chan a -> a -> IO ()
writeChan (Chan _read write) val = do
new_hole <- newEmptyMVar
modifyMVar_ write $ \old_hole -> do
putMVar old_hole $! ChItem val new_hole
return new_hole
We see that modifyMVar_ is called on write before we evaluate the thunk. The sequence of operations then is:
writeChan is entered
We takeMVar write (blocking anyone else who wants to write to the channel)
We evaluate the expensive thunk
We put the expensive thunk onto the channel
We putMVar write, unblocking all of the other threads
You don't see this behavior with the evaluate variants, because they perform the evaluation before the lock is acquired.
I’ll send Don mail about this and see if he agrees that this behavior is kind of suboptimal.
Don agrees that this behavior is suboptimal. We're working on a patch.
I am using WxHaskell to graphically show the state of a program that advertises state updates using TCP (which I decode using Data.Binary). When an update is received, I want to update the display. So I want the GUI to update its display asynchronously. I know that processExecAsync runs a command line process asynchronously, but I don't think this is what I want.
This is rough code using transactional variables (i.e. software transactional memory). You could use an IORef, MVar, or numerous other constructs.
main = do
recvFunc <- initNetwork
cntTV <- newTVarIO 0
forkIO $ threadA recvFunc cntTV
runGUI cntTV 0
Above you start the program, initialize the network and a shared variable cntTV
threadA recvCntFromNetwork cntTVar = forever $ do
cnt <- recvCntFromNetwork
atomically (writeTVar cntTVar cnt)
threadA receives data from the network and writes the new value of the counter to the shared variable.
runGUI cntTVar currentCnt = do
counter <- initGUI
cnt <- atomically $ do
cnt <- readTVar cntTVar
if (cnt == currentCnt)
then retry
else return cnt
updateGUICounter counter cnt
runGUI cntTVar cnt
runGUI reads the shared variable and if there is a change will update the GUI counter. FYI, the runGUI thread won't wake up on retry until cntTVar is modified, so this isn't a CPU hogging polling loop.
In this code I've assumed you have functions named updateGUICounter, initGUI, and initNetwork. I advise you use Hoogle to find the location of any other functions you don't already know and learn a little about each module.
I have come up with a kind of hack that seems to work. Namely, use an event timer to check an update queue:
startClient :: IO (TVar [Update])
startClient = /*Connect to server,
listen for updates and add to queue*/
gui :: TVar [Update] -> IO ()
gui trdl = do
f <- frame [text := "counter", visible := False]
p <- panel f []
st <- staticText p []
t <- timer f [interval := 10, on command := updateGui st]
set f [layout := container p $ fill $ widget st, clientSize := (sz 200 100), visible := True]
where
updateGui st = do
rdl <- atomically $ readTVar trdl
atomically $ writeTVar trdl []
case rdl of
[] -> return ()
dat : dl -> set st [text := (show dat)]
main :: IO ()
main = startClient >>= start gui
So a client listens for the updates on the TCP connection, adds them to a queue. Every 10ms, an event is raised whose action is to check this queue and show the latest update in a static text widget.
If you have a better solution, please let me know!
I found a solution without a busy wait at:
http://snipplr.com/view/17538/
However you might choose a higher eventId in order to avoid conflicts with existing ids.
Here is some code from my module http://code.haskell.org/alsa/gui/src/Common.hs:
myEventId :: Int
myEventId = WXCore.wxID_HIGHEST+100
-- the custom event ID, avoid clash with Graphics.UI.WXCore.Types.varTopId
-- | the custom event is registered as a menu event
createMyEvent :: IO (WXCore.CommandEvent ())
createMyEvent =
WXCore.commandEventCreate WXCore.wxEVT_COMMAND_MENU_SELECTED myEventId
registerMyEvent :: WXCore.EvtHandler a -> IO () -> IO ()
registerMyEvent win io =
WXCore.evtHandlerOnMenuCommand win myEventId io
reactOnEvent, reactOnEventTimer ::
SndSeq.AllowInput mode =>
Int -> WX.Window a -> Sequencer mode ->
(Event.T -> IO ()) ->
IO ()
reactOnEvent _interval frame (Sequencer h _) action = do
mvar <- MVar.newEmptyMVar
void $ forkIO $ forever $ do
MVar.putMVar mvar =<< Event.input h
WXCore.evtHandlerAddPendingEvent frame =<< createMyEvent
registerMyEvent frame $
MVar.takeMVar mvar >>= action
-- naive implementation using a timer, requires Non-Blocking sequencer mode
reactOnEventTimer interval frame sequ action =
void $
WX.timer frame [
WX.interval := interval,
on command := getWaitingEvents sequ >>= mapM_ action]
The code shows two ways to handle the problem:
reactOnEventTimer does a busy wait using the WX timer.
reactOnEvent only gets active when an event actually arrives. This is the prefered solution.
In my example I wait for ALSA MIDI sequencer messages. The Event.input call waits for the next ALSA message to come. The action gets the results of Event.input, that is, the incoming ALSA messages, but it is run in the WX thread.