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