From d71ca65be98abb12afa1dfc2815e6e157799ffdc Mon Sep 17 00:00:00 2001
From: Bas van Dijk <v.dijk.bas@gmail.com>
Date: Sun, 26 Sep 2010 19:21:44 +0000
Subject: [PATCH] Add throwSTM :: Exception e => e -> STM a

---
 GHC/Conc.lhs      |    1 +
 GHC/Conc/Sync.lhs |   22 ++++++++++++++++++++++
 2 files changed, 23 insertions(+)

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index d08ccf2..47b6ef6 100644
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -58,6 +58,7 @@ module GHC.Conc
         , atomically    -- :: STM a -> IO a
         , retry         -- :: STM a
         , orElse        -- :: STM a -> STM a -> STM a
+        , throwSTM      -- :: Exception e => e -> STM a
         , catchSTM      -- :: Exception e => STM a -> (e -> STM a) -> STM a
         , alwaysSucceeds -- :: STM a -> STM ()
         , always        -- :: STM Bool -> STM ()
diff --git a/GHC/Conc/Sync.lhs b/GHC/Conc/Sync.lhs
index 38717e6..b00c851 100644
--- a/GHC/Conc/Sync.lhs
+++ b/GHC/Conc/Sync.lhs
@@ -52,6 +52,7 @@ module GHC.Conc.Sync
         , atomically    -- :: STM a -> IO a
         , retry         -- :: STM a
         , orElse        -- :: STM a -> STM a -> STM a
+        , throwSTM      -- :: Exception e => e -> STM a
         , catchSTM      -- :: Exception e => STM a -> (e -> STM a) -> STM a
         , alwaysSucceeds -- :: STM a -> STM ()
         , always        -- :: STM Bool -> STM ()
@@ -509,6 +510,27 @@ retry = STM $ \s# -> retry# s#
 orElse :: STM a -> STM a -> STM a
 orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
 
+-- | A variant of 'throw' that can only be used within the 'STM' monad.
+--
+-- Throwing an exception in @STM@ aborts the transaction and propagates the
+-- exception.
+--
+-- Although 'throwSTM' has a type that is an instance of the type of 'throw', the
+-- two functions are subtly different:
+--
+-- > throw e    `seq` x  ===> throw e
+-- > throwSTM e `seq` x  ===> x
+--
+-- The first example will cause the exception @e@ to be raised,
+-- whereas the second one won\'t.  In fact, 'throwSTM' will only cause
+-- an exception to be raised when it is used within the 'STM' monad.
+-- The 'throwSTM' variant should be used in preference to 'throw' to
+-- raise an exception within the 'STM' monad because it guarantees
+-- ordering with respect to other 'STM' operations, whereas 'throw'
+-- does not.
+throwSTM :: Exception e => e -> STM a
+throwSTM e = STM $ raiseIO# (toException e)
+
 -- |Exception handling within STM actions.
 catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a
 catchSTM (STM m) handler = STM $ catchSTM# m handler'
-- 
1.7.10.4