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