view release on metacpan or  search on metacpan

hugs98-Nov2003/libraries/Hugs/ConcBase.hs  view on Meta::CPAN

-----------------------------------------------------------------------------
-- This implements Concurrent Haskell's "MVar"s as described in the paper
--
--   "Concurrent Haskell"
--   Simon Peyton Jones, Andrew Gordon and Sigbjorn Finne.
--   In Proceedings of the ACM Symposium on Principles of Programming
--   Languages,St Petersburg Beach, Florida, January 1996. 
--   http://www.dcs.gla.ac.uk/fp/authors/Simon_Peyton_Jones/
--     concurrent-haskell.ps
--
-- except that we have made the following name changes for compatability
-- with GHC 2.05.
--
--   newMVar  -> newEmptyMVar
--
-- There is one significant difference between this implementation and
-- GHC 2.05: 
--
-- o GHC uses preemptive multitasking.
-- 
--   Context switches can occur at any time (except if you call a C
--   function (like "getchar") which blocks the entire process while
--   waiting for input.
-- 
-- o Hugs uses cooperative multitasking.  
-- 
--   Context switches only occur when you use one of the primitives
--   defined in this module.  This means that programs such as:
-- 
--     main = forkIO (write 'a') >> write 'b'
-- 	where
-- 	 write c = putChar c >> write c
-- 
--   will print either "aaaaaaaaaaaaaa..." or "bbbbbbbbbbbb..."
--   instead of some random interleaving of 'a's and 'b's.
-- 
-- Cooperative multitasking is sufficient for writing coroutines and simple
-- graphical user interfaces but the usual assumptions of fairness don't
-- apply and Channel.getChanContents cannot be implemented.
-----------------------------------------------------------------------------
module Hugs.ConcBase(
	forkIO,
	MVar,
	newEmptyMVar, newMVar, takeMVar, tryTakeMVar, putMVar, tryPutMVar,
	isEmptyMVar,
        yield
	) where

import Hugs.Prelude(
	IO(..), IOResult(..), threadToIOResult,
	Exception(..), catchException, blockIO)
import Hugs.IORef

----------------------------------------------------------------
-- The interface
----------------------------------------------------------------

forkIO       :: IO () -> IO () -- Spawn a thread
yield        :: IO ()

newEmptyMVar :: IO (MVar a)
newMVar      :: a -> IO (MVar a)
takeMVar     :: MVar a -> IO a
putMVar      :: MVar a -> a -> IO ()
tryPutMVar   :: MVar a -> a -> IO Bool
tryTakeMVar  :: MVar a -> IO (Maybe a)

isEmptyMVar :: MVar a -> IO Bool

----------------------------------------------------------------
-- Implementation
----------------------------------------------------------------

kill :: IO a
kill = IO (\ s -> Hugs_DeadThread)

yield = IO (\ s -> Hugs_YieldThread (s ()))

-- add the continuation to the runnable list, and continue
continueIO :: IOResult -> IO ()
continueIO cc = IO (\ s -> Hugs_ForkThread (s ()) cc)

-- The thread is scheduled immediately and runs with its own success/error
-- continuations.
forkIO m = continueIO (threadToIOResult (m `catchException` forkExnHandler))

forkExnHandler :: Exception -> IO a
forkExnHandler e = do
    putStr "\nThread raised exception: "
    putStr (show e)
    putStr "\n"           
    kill

newtype MVar a = MkMVar (IORef (MVarState a)) deriving Eq
data MVarState a
  = Full a [(a,()->IOResult)]
	-- a value and a list of value-thread pairs blocked waiting