+newSTRef :: a -> ST s (STRef s a)
+newSTRef = primNewRef
+readSTRef :: STRef s a -> ST s a
+readSTRef = primReadRef
+writeSTRef :: STRef s a -> a -> ST s ()
+writeSTRef = primWriteRef
+
+type IORef a = STRef RealWorld a
+newIORef :: a -> IO (IORef a)
+newIORef = primNewRef
+readIORef :: IORef a -> IO a
+readIORef = primReadRef
+writeIORef :: IORef a -> a -> IO ()
+writeIORef = primWriteRef
+
+
+------------------------------------------------------------------------------
+-- ThreadId, MVar, concurrency stuff -----------------------------------------
+------------------------------------------------------------------------------
+
+data MVar a
+
+newEmptyMVar :: IO (MVar a)
+newEmptyMVar = primNewEmptyMVar
+
+putMVar :: MVar a -> a -> IO ()
+putMVar = primPutMVar
+
+takeMVar :: MVar a -> IO a
+takeMVar m
+ = ST (\world -> primTakeMVar m cont world)
+ where
+ -- cont :: a -> RealWorld -> (a,RealWorld)
+ -- where 'a' is as in the top-level signature
+ cont x world = (x,world)
+
+ -- the type of the handwritten BCO (threesome) primTakeMVar is
+ -- primTakeMVar :: MVar a
+ -- -> (a -> RealWorld -> (a,RealWorld))
+ -- -> RealWorld
+ -- -> (a,RealWorld)
+ --
+ -- primTakeMVar behaves like this:
+ --
+ -- primTakeMVar (MVar# m#) cont world
+ -- = primTakeMVar_wrk m# cont world
+ --
+ -- primTakeMVar_wrk m# cont world
+ -- = cont (takeMVar# m#) world
+ --
+ -- primTakeMVar_wrk has the special property that it is
+ -- restartable by the scheduler, should the MVar be empty.
+
+newMVar :: a -> IO (MVar a)
+newMVar value =
+ newEmptyMVar >>= \ mvar ->
+ putMVar mvar value >>
+ return mvar
+
+readMVar :: MVar a -> IO a
+readMVar mvar =
+ takeMVar mvar >>= \ value ->
+ putMVar mvar value >>
+ return value
+
+swapMVar :: MVar a -> a -> IO a
+swapMVar mvar new =
+ takeMVar mvar >>= \ old ->
+ putMVar mvar new >>
+ return old
+
+instance Eq (MVar a) where
+ m1 == m2 = primSameMVar m1 m2
+
+
+data ThreadId
+
+instance Eq ThreadId where
+ tid1 == tid2 = primCmpThreadIds tid1 tid2 == 0
+
+instance Ord ThreadId where
+ compare tid1 tid2
+ = let r = primCmpThreadIds tid1 tid2
+ in if r < 0 then LT else if r > 0 then GT else EQ
+
+
+forkIO :: IO a -> IO ThreadId
+-- Simple version; doesn't catch exceptions in computation
+-- forkIO computation
+-- = primForkIO (primRunST computation)
+
+forkIO computation
+ = primForkIO (
+ primCatch
+ (unST computation realWorld `primSeq` ())
+ (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ())
+ )
+ where
+ realWorld = error "primForkIO: entered the RealWorld"