1
2module GUI.ConcurrencyControl (
3    ConcurrencyControl,
4    start,
5    fullSpeed,
6  ) where
7
8import qualified System.Glib.MainLoop as Glib
9import qualified Control.Concurrent as Concurrent
10import qualified Control.Exception  as Exception
11import Control.Concurrent.MVar
12
13
14newtype ConcurrencyControl = ConcurrencyControl (MVar (Int, Glib.HandlerId))
15
16-- | Setup cooperative thread scheduling with Gtk+.
17--
18start :: IO ConcurrencyControl
19start = do
20  handlerId <- normalScheduling
21  return . ConcurrencyControl =<< newMVar (0, handlerId)
22
23-- | Run an expensive action that needs to use all the available CPU power.
24--
25-- The normal cooperative GUI thread scheduling does not work so well in this
26-- case so we use an alternative technique. We can't use this one all the time
27-- however or we'd hog the CPU even when idle.
28--
29fullSpeed :: ConcurrencyControl -> IO a -> IO a
30fullSpeed (ConcurrencyControl handlerRef) =
31    Exception.bracket_ begin end
32  where
33    -- remove the normal scheduling handler and put in the full speed one
34    begin = do
35      (count, handlerId) <- takeMVar handlerRef
36      if count == 0
37        -- nobody else is running fullSpeed
38        then do Glib.timeoutRemove handlerId
39                handlerId' <- fullSpeedScheduling
40                putMVar handlerRef (1, handlerId')
41        -- we're already running fullSpeed, just inc the count
42        else do putMVar handlerRef (count+1, handlerId)
43
44    -- reinstate the normal scheduling
45    end = do
46      (count, handlerId) <- takeMVar handlerRef
47      if count == 1
48        -- just us running fullSpeed so we clean up
49        then do Glib.timeoutRemove handlerId
50                handlerId' <- normalScheduling
51                putMVar handlerRef (0, handlerId')
52        -- someone else running fullSpeed, they're responsible for stopping
53        else do putMVar handlerRef (count-1, handlerId)
54
55normalScheduling :: IO Glib.HandlerId
56normalScheduling =
57  Glib.timeoutAddFull
58    (Concurrent.yield >> return True)
59    Glib.priorityDefaultIdle 50
60    --50ms, ie 20 times a second.
61
62fullSpeedScheduling :: IO Glib.HandlerId
63fullSpeedScheduling =
64  Glib.idleAdd
65    (Concurrent.yield >> return True)
66    Glib.priorityDefaultIdle
67