From: Ian Lynagh <igloo@earth.li>
Date: Fri, 1 Aug 2008 21:42:08 +0000 (+0000)
Subject: Rejig some code so Control.Exception and GHC.Conc don't need recursive imports
X-Git-Tag: 6_10_branch_has_been_forked~108
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=b9152b3523862840a0b682ffa55cf55281c93185;p=ghc-base.git

Rejig some code so Control.Exception and GHC.Conc don't need recursive imports
---

diff --git a/Control/Exception.hs b/Control/Exception.hs
index 5c1738d..7dddc45 100644
--- a/Control/Exception.hs
+++ b/Control/Exception.hs
@@ -124,23 +124,17 @@ module Control.Exception (
         recSelError, recConError, irrefutPatError, runtimeError,
         nonExhaustiveGuardsError, patError, noMethodBindingError,
         assertError,
-
-#ifdef __GLASGOW_HASKELL__
-        setUncaughtExceptionHandler,      -- :: (Exception -> IO ()) -> IO ()
-        getUncaughtExceptionHandler       -- :: IO (Exception -> IO ())
-#endif
   ) where
 
 #ifdef __GLASGOW_HASKELL__
 import GHC.Base
 import GHC.IOBase
-import {-# SOURCE #-} GHC.Handle
 import GHC.List
 import GHC.Num
 import GHC.Show
 import GHC.IOBase as ExceptionBase
 import GHC.Exception hiding ( Exception )
-import {-# SOURCE #-} GHC.Conc         ( ThreadId(ThreadId) )
+import GHC.Conc         ( ThreadId(ThreadId) )
 import Foreign.C.String ( CString, withCString )
 #endif
 
@@ -516,36 +510,6 @@ assert True x = x
 assert False _ = throw (AssertionFailed "")
 #endif
 
-
-#ifdef __GLASGOW_HASKELL__
-{-# NOINLINE uncaughtExceptionHandler #-}
-uncaughtExceptionHandler :: IORef (SomeException -> IO ())
-uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
-   where
-      defaultHandler :: SomeException -> IO ()
-      defaultHandler se@(SomeException ex) = do
-         (hFlush stdout) `catchAny` (\ _ -> return ())
-         let msg = case cast ex of
-               Just Deadlock -> "no threads to run:  infinite loop or deadlock?"
-               _ -> case cast ex of
-                    Just (ErrorCall s) -> s
-                    _                  -> showsPrec 0 se ""
-         withCString "%s" $ \cfmt ->
-          withCString msg $ \cmsg ->
-            errorBelch cfmt cmsg
-
--- don't use errorBelch() directly, because we cannot call varargs functions
--- using the FFI.
-foreign import ccall unsafe "HsBase.h errorBelch2"
-   errorBelch :: CString -> CString -> IO ()
-
-setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO ()
-setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
-
-getUncaughtExceptionHandler :: IO (SomeException -> IO ())
-getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler
-#endif
-
 recSelError, recConError, irrefutPatError, runtimeError,
              nonExhaustiveGuardsError, patError, noMethodBindingError
         :: Addr# -> a   -- All take a UTF8-encoded C string
@@ -635,16 +599,6 @@ nonTermination = toException NonTermination
 
 -----
 
-data Deadlock = Deadlock
-INSTANCE_TYPEABLE0(Deadlock,deadlockTc,"Deadlock")
-
-instance Exception Deadlock
-
-instance Show Deadlock where
-    showsPrec _ Deadlock = showString "<<deadlock>>"
-
------
-
 data NestedAtomically = NestedAtomically
 INSTANCE_TYPEABLE0(NestedAtomically,nestedAtomicallyTc,"NestedAtomically")
 
diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index a584d31..c45d563 100644
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -95,6 +95,9 @@ module GHC.Conc
         , win32ConsoleHandler
         , toWin32ConsoleEvent
 #endif
+        , setUncaughtExceptionHandler      -- :: (Exception -> IO ()) -> IO ()
+        , getUncaughtExceptionHandler      -- :: IO (Exception -> IO ())
+
         , reportError, reportStackOverflow
         ) where
 
@@ -108,6 +111,7 @@ import Foreign.C
 import Data.Maybe
 
 import GHC.Base
+import {-# SOURCE #-} GHC.Handle
 import GHC.IOBase
 import GHC.Num          ( Num(..) )
 import GHC.Real         ( fromIntegral, div )
@@ -125,7 +129,6 @@ import GHC.STRef
 import GHC.Show         ( Show(..), showString )
 import Data.Typeable
 import GHC.Err
-import Control.Exception hiding (throwTo)
 
 infixr 0 `par`, `pseq`
 \end{code}
@@ -1264,4 +1267,31 @@ reportError ex = do
 -- the unsafe below.
 foreign import ccall unsafe "stackOverflow"
         callStackOverflowHook :: IO ()
+
+{-# NOINLINE uncaughtExceptionHandler #-}
+uncaughtExceptionHandler :: IORef (SomeException -> IO ())
+uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
+   where
+      defaultHandler :: SomeException -> IO ()
+      defaultHandler se@(SomeException ex) = do
+         (hFlush stdout) `catchAny` (\ _ -> return ())
+         let msg = case cast ex of
+               Just Deadlock -> "no threads to run:  infinite loop or deadlock?"
+               _ -> case cast ex of
+                    Just (ErrorCall s) -> s
+                    _                  -> showsPrec 0 se ""
+         withCString "%s" $ \cfmt ->
+          withCString msg $ \cmsg ->
+            errorBelch cfmt cmsg
+
+-- don't use errorBelch() directly, because we cannot call varargs functions
+-- using the FFI.
+foreign import ccall unsafe "HsBase.h errorBelch2"
+   errorBelch :: CString -> CString -> IO ()
+
+setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO ()
+setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
+
+getUncaughtExceptionHandler :: IO (SomeException -> IO ())
+getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler
 \end{code}
diff --git a/GHC/IOBase.lhs b/GHC/IOBase.lhs
index 986cde6..f50c775 100644
--- a/GHC/IOBase.lhs
+++ b/GHC/IOBase.lhs
@@ -47,7 +47,7 @@ module GHC.IOBase(
     throwIO, block, unblock, blocked, catchAny, catchException,
     evaluate,
     ErrorCall(..), ArithException(..), AsyncException(..),
-    BlockedOnDeadMVar(..), BlockedIndefinitely(..),
+    BlockedOnDeadMVar(..), BlockedIndefinitely(..), Deadlock(..)
   ) where
 
 import GHC.ST
@@ -660,6 +660,16 @@ instance Show BlockedIndefinitely where
 
 -----
 
+data Deadlock = Deadlock
+    deriving Typeable
+
+instance Exception Deadlock
+
+instance Show Deadlock where
+    showsPrec _ Deadlock = showString "<<deadlock>>"
+
+-----
+
 -- |The type of arithmetic exceptions
 data ArithException
   = Overflow