Difference between revisions of "WrapConc"
Jump to navigation
Jump to search
(category) |
(chris says WrapConc is museum material) |
||
| Line 1: | Line 1: | ||
| + | ''This code is now likely obsolete and has been archived in the wiki history'' |
||
| − | [[Category:Code]] |
||
| − | [[Category:Parallel]] |
||
| − | |||
| − | <haskell> |
||
| − | -- By Chris Kuklewicz <haskell at list dot mightyreason dot com> |
||
| − | -- |
||
| − | -- This WrapConc module provides modified version of forkIO which have |
||
| − | -- been combined with block from Control.Exception to provide stronger |
||
| − | -- guarantees as well as notification when a thread has finished. |
||
| − | module WrapConc(finally',bracket',fork,forkB,forkC,forkF |
||
| − | ,ThreadFlag,isSetThreadFlag,waitThreadFlag,waitKillThread,abandonThread) where |
||
| − | |||
| − | import Prelude hiding (catch) |
||
| − | import Control.Concurrent(forkIO,ThreadId,killThread,yield) |
||
| − | import Control.Concurrent.MVar(MVar,newEmptyMVar,tryPutMVar,takeMVar,putMVar,isEmptyMVar,readMVar) |
||
| − | import Control.Exception(Exception,catch,block,throw) |
||
| − | import Control.Monad (liftM) |
||
| − | |||
| − | -- Some code copied from http://darcs.haskell.org/packages/base/Control/Exception.hs |
||
| − | |||
| − | -- This is like finally but leaves your code to execute in 'block' |
||
| − | -- instead of 'unblock' |
||
| − | finally' :: IO a -> IO b -> IO a |
||
| − | finally' a sequel = block $ do |
||
| − | r <- catch a (\e -> sequel >> throw e) |
||
| − | sequel |
||
| − | return r |
||
| − | |||
| − | -- This is like bracket but leaves your code to execute in 'block' |
||
| − | -- instead of 'unblock' |
||
| − | bracket' :: IO a -- ^ computation to run first (\"acquire resource\") |
||
| − | -> (a -> IO b) -- ^ computation to run last (\"release resource\") |
||
| − | -> (a -> IO c) -- ^ computation to run in-between |
||
| − | -> IO c -- returns the value from the in-between computation |
||
| − | bracket' before after thing = block $ do |
||
| − | a <- before |
||
| − | r <- catch (thing a) (\e -> after a >> throw e ) |
||
| − | after a |
||
| − | return r |
||
| − | |||
| − | -- ThreadFlag is a limited newtype of an MVar |
||
| − | newtype ThreadFlag = ThreadFlag (MVar ()) |
||
| − | |||
| − | -- Intially unset, the ThreadFlag will become set when the thread is finished |
||
| − | isSetThreadFlag :: ThreadFlag -> IO Bool |
||
| − | isSetThreadFlag (ThreadFlag m) = liftM not (isEmptyMVar m) |
||
| − | |||
| − | -- If unset then block until set. This will wait for the thread to have finished |
||
| − | waitThreadFlag :: ThreadFlag -> IO () |
||
| − | waitThreadFlag (ThreadFlag m) = readMVar m |
||
| − | |||
| − | -- This does a background killThread and then waits for the passed |
||
| − | -- ThreadFlag to signal that it is done via the ThreadFlag |
||
| − | waitKillThread :: (ThreadFlag,ThreadId) -> IO () |
||
| − | waitKillThread (flag,tid) = forkIO (killThread tid) >> yield >> waitThreadFlag flag |
||
| − | |||
| − | -- This does two things: |
||
| − | -- First it does a background killThread. |
||
| − | -- Second it immediately ensure the ThreadFlag is set |
||
| − | -- |
||
| − | -- The main effect will be to release any thread waiting on (or that |
||
| − | -- will wait on) the ThreadFlag. |
||
| − | -- |
||
| − | -- This should only be needed in highly unusual situations where |
||
| − | -- waiting for thread to properly exit and set the ThreadFlag is |
||
| − | -- impossible. It may be useful if the thread has hung or the |
||
| − | -- application needs to perform an "emergency shutdown". |
||
| − | abandonThread (ThreadFlag m,tid) = forkIO (killThread tid) >> tryPutMVar m () |
||
| − | |||
| − | -- Safer forkIO. If this returns then you are not guaranteed that your |
||
| − | -- operations run but you are guranteed that the thread has started |
||
| − | -- and that the ThreadFlag will be set when it finishes. Your code |
||
| − | -- starts to execute in the scope of a 'block' function. |
||
| − | -- |
||
| − | -- It is possible to interrupt the fork and to have still succeeded in |
||
| − | -- starting the thread. |
||
| − | fork :: IO a -> IO (ThreadFlag,ThreadId) |
||
| − | fork ioA = block $ do |
||
| − | a <- newEmptyMVar |
||
| − | b <- newEmptyMVar |
||
| − | tid <- forkIO (finally' (putMVar a () >> yield >> ioA) |
||
| − | (tryPutMVar b ()) >> return ()) |
||
| − | yield |
||
| − | takeMVar a |
||
| − | return (ThreadFlag b, tid) |
||
| − | |||
| − | -- fork merged with bracket'. If this returns then you are not |
||
| − | -- guaranteed that your operations run but you are guranteed that the |
||
| − | -- thread has started and that the ThreadFlag will be set when it |
||
| − | -- finishes. Your code starts to execute in the scope of a 'block' |
||
| − | -- function. |
||
| − | -- |
||
| − | -- The is equivalent to (fork (bracket' ioA ioAB ioAC)) |
||
| − | -- |
||
| − | -- It is possible to interrupt the forkB and to have still succeeded in |
||
| − | -- starting the thread. |
||
| − | forkB :: IO a -> (a -> IO b) -> (a -> IO c) -> IO (ThreadFlag,ThreadId) |
||
| − | forkB ioA ioAB ioAC = block $ do |
||
| − | a <- newEmptyMVar |
||
| − | b <- newEmptyMVar |
||
| − | tid <- forkIO (finally' (putMVar a () >> yield >> bracket' ioA ioAB ioAC) |
||
| − | (tryPutMVar b ()) >> return ()) |
||
| − | yield |
||
| − | takeMVar a |
||
| − | return (ThreadFlag b, tid) |
||
| − | |||
| − | -- fork merged with catch. If this returns then you are not guarenteed |
||
| − | -- that your operation is running, but you are guranteed that the |
||
| − | -- handler will run if your code received or raises an exception. And |
||
| − | -- the ThreadFlag will be set when the thread finishes. Your code |
||
| − | -- starts to execute in the scope of a 'block' function. |
||
| − | -- |
||
| − | -- This is a stronger guarantee than (fork (catch ioA ioEA)) |
||
| − | -- |
||
| − | -- It is possible to interrupt the forkC and to have still succeeded in |
||
| − | -- starting the thread. |
||
| − | forkC :: IO a -> (Exception -> IO a) -> IO (ThreadFlag,ThreadId) |
||
| − | forkC ioA ioEA = block $ do |
||
| − | a <- newEmptyMVar |
||
| − | b <- newEmptyMVar |
||
| − | tid <- forkIO (finally' (catch (putMVar a () >> yield >> ioA) ioEA) |
||
| − | (tryPutMVar b ()) >> return ()) |
||
| − | yield |
||
| − | takeMVar a |
||
| − | return (ThreadFlag b, tid) |
||
| − | |||
| − | -- fork merged with finally'. If this returns then you are guaranteed |
||
| − | -- that your second command will be run even if your first command |
||
| − | -- receives or raises an exception. And the ThreadFlag will be set |
||
| − | -- when the thread finishes. Your code starts to execute in the |
||
| − | -- scope of a 'block' function. |
||
| − | -- |
||
| − | -- This is a stronger guarantee than (fork (finally' ioA ioB)) |
||
| − | -- |
||
| − | -- It is possible to interrupt the forkF and to have still succeeded in |
||
| − | -- starting the thread. |
||
| − | forkF :: IO a -> IO b -> IO (ThreadFlag,ThreadId) |
||
| − | forkF ioA ioB = block $ do |
||
| − | a <- newEmptyMVar |
||
| − | b <- newEmptyMVar |
||
| − | tid <- forkIO (finally' (finally' (putMVar a () >> yield >> ioA) ioB) |
||
| − | (tryPutMVar b ()) >> return ()) |
||
| − | yield |
||
| − | takeMVar a |
||
| − | return (ThreadFlag b, tid) |
||
| − | </haskell> |
||
Latest revision as of 09:26, 19 May 2012
This code is now likely obsolete and has been archived in the wiki history