Difference between revisions of "WrapConc"

From HaskellWiki
Jump to: navigation, search
(category)
(chris says WrapConc is museum material)
 
Line 1: Line 1:
[[Category:Code]]
 
  +
''This code is now likely obsolete and has been archived in the wiki history''
[[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