Hugs.ConcBase

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
	-- to write to the MVar.
	-- The ()-> part of the thread is because blocked threads have
	-- to be functions. :-(
  | Empty [a -> IOResult]
	-- no value, just a list of threads waiting to receive a value

newEmptyMVar = fmap MkMVar (newIORef (Empty []))

newMVar x    = fmap MkMVar (newIORef (Full x []))

takeMVar (MkMVar v) = do
  state <- readIORef v
  case state of
    Full a [] -> do
      writeIORef v (Empty [])
      return a
    Full a ((a',t):ts) -> do
      writeIORef v (Full a' ts)
      continueIO (t ())		-- reschedule t
      return a
    Empty cs ->
      blockIO (\cc -> writeIORef v (Empty (cs ++ [cc])))

-- tryTakeMVar is a non-blocking takeMVar
tryTakeMVar (MkMVar v) = do
  state <- readIORef v
  case state of
    Full a [] -> do
      writeIORef v (Empty [])
      return (Just a)
    Full a ((a',t):ts) -> do
      writeIORef v (Full a' ts)
      continueIO (t ())		-- reschedule t
      return (Just a)
    Empty cs ->
      return Nothing

putMVar (MkMVar v) a = do
  state <- readIORef v
  case state of
    Full a' ts ->
      blockIO (\cc -> writeIORef v (Full a' (ts++[(a,cc)])))
    Empty [] ->
      writeIORef v (Full a [])
    Empty (c:cs) -> do
      writeIORef v (Empty cs)
      continueIO (c a)		-- reschedule the blocked thread

tryPutMVar (MkMVar v) a = do
  state <- readIORef v
  case state of
    Full _ _ ->
      return False
    Empty [] -> do
      writeIORef v (Full a [])
      return True
    Empty (c:cs) -> do
      writeIORef v (Empty cs)
      continueIO (c a)		-- reschedule the blocked thread
      return True

{- 
 Low-level op. for checking whether an MVar is filled-in or not.
 Notice that the boolean value returned  is just a snapshot of
 the state of the MVar. By the time you get to react on its result,
 the MVar may have been filled (or emptied) - so be extremely
 careful when using this operation.  

 Use tryTakeMVar instead if possible.

 If you can re-work your abstractions to avoid having to
 depend on isEmptyMVar, then you're encouraged to do so,
 i.e., consider yourself warned about the imprecision in
 general of isEmptyMVar :-)
-}
isEmptyMVar (MkMVar v) = do
  state <- readIORef v
  case state of
    Full _ _ -> return False
    Empty _  -> return True

-----------------------------------------------------------------------------