[project @ 2005-01-11 16:04:08 by simonmar]

[ghc-base.git] / GHC / Conc.lhs

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index b67847c..02b256a 100644 (file)
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -1,5 +1,5 @@
 \begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
+{-# OPTIONS_GHC -fno-implicit-prelude #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.Conc
@@ -53,6 +53,7 @@ module GHC.Conc
        , newTVar       -- :: a -> STM (TVar a)
        , readTVar      -- :: TVar a -> STM a
        , writeTVar     -- :: a -> TVar a -> STM ()
+       , unsafeIOToSTM -- :: IO a -> STM a
 
 #ifdef mingw32_TARGET_OS
        , asyncRead     -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
@@ -213,7 +214,7 @@ instance  Monad STM  where
     {-# INLINE return #-}
     {-# INLINE (>>)   #-}
     {-# INLINE (>>=)  #-}
-    m >> k      =  m >>= \_ -> k
+    m >> k      = thenSTM m k
     return x   = returnSTM x
     m >>= k     = bindSTM m k
 
@@ -232,6 +233,10 @@ thenSTM (STM m) k = STM ( \s ->
 returnSTM :: a -> STM a
 returnSTM x = STM (\s -> (# s, x #))
 
+-- | Unsafely performs IO in the STM monad.
+unsafeIOToSTM :: IO a -> STM a
+unsafeIOToSTM (IO m) = STM m
+
 -- |Perform a series of STM actions atomically.
 atomically :: STM a -> IO a
 atomically (STM m) = IO (\s -> (atomically# m) s )