Split the Id related functions out from Var into Id, document Var and some of Id

[ghc-hetmet.git] / compiler / main / InteractiveEval.hs

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 96e0b34..dd55dd5 100644 (file)
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -37,13 +37,15 @@ module InteractiveEval (
 
 #ifdef GHCI
 
 
 #ifdef GHCI
 

+#include "HsVersions.h"
+

 import HscMain          hiding (compileExpr)
 import HscTypes
 import TcRnDriver
 import Type             hiding (typeKind)
 import TcType           hiding (typeKind)
 import InstEnv
 import HscMain          hiding (compileExpr)
 import HscTypes
 import TcRnDriver
 import Type             hiding (typeKind)
 import TcType           hiding (typeKind)
 import InstEnv

-import Var              hiding (setIdType)
+import Var

 import Id
 import IdInfo
 import Name             hiding ( varName )
 import Id
 import IdInfo
 import Name             hiding ( varName )

@@ -76,7 +78,7 @@ import Foreign
 import Foreign.C
 import GHC.Exts
 import Data.Array
 import Foreign.C
 import GHC.Exts
 import Data.Array

-import Control.Exception as Exception
+import Exception

 import Control.Concurrent
 import Data.List (sortBy)
 import Data.IORef
 import Control.Concurrent
 import Data.List (sortBy)
 import Data.IORef

@@ -88,13 +90,13 @@ import Foreign.StablePtr
 data RunResult
   = RunOk [Name]               -- ^ names bound by this evaluation
   | RunFailed                  -- ^ statement failed compilation
 data RunResult
   = RunOk [Name]               -- ^ names bound by this evaluation
   | RunFailed                  -- ^ statement failed compilation

-  | RunException Exception     -- ^ statement raised an exception
+  | RunException SomeException -- ^ statement raised an exception

   | RunBreak ThreadId [Name] (Maybe BreakInfo)
 
 data Status
    = Break Bool HValue BreakInfo ThreadId
           -- ^ the computation hit a breakpoint (Bool <=> was an exception)
   | RunBreak ThreadId [Name] (Maybe BreakInfo)
 
 data Status
    = Break Bool HValue BreakInfo ThreadId
           -- ^ the computation hit a breakpoint (Bool <=> was an exception)

-   | Complete (Either Exception [HValue])
+   | Complete (Either SomeException [HValue])

           -- ^ the computation completed with either an exception or a value
 
 data Resume
           -- ^ the computation completed with either an exception or a value
 
 data Resume

@@ -315,11 +317,10 @@ foreign import ccall "&rts_breakpoint_io_action"
 -- thread doesn't die when it receives the exception... "this thread
 -- is not responding".
 -- 
 -- thread doesn't die when it receives the exception... "this thread
 -- is not responding".
 -- 

--- Careful here: there may be ^C exceptions flying around, so we start
--- the new thread blocked (forkIO inherits block from the parent,
--- #1048), and unblock only while we execute the user's code.  We
--- can't afford to lose the final putMVar, otherwise deadlock
--- ensues. (#1583, #1922, #1946)
+-- Careful here: there may be ^C exceptions flying around, so we start the new
+-- thread blocked (forkIO inherits block from the parent, #1048), and unblock
+-- only while we execute the user's code.  We can't afford to lose the final
+-- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946)

 sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
 sandboxIO dflags statusMVar thing =
    block $ do  -- fork starts blocked
 sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
 sandboxIO dflags statusMVar thing =
    block $ do  -- fork starts blocked

@@ -337,6 +338,7 @@ sandboxIO dflags statusMVar thing =
 -- not "Interrupted", we unset the exception flag before throwing.
 --
 rethrow :: DynFlags -> IO a -> IO a
 -- not "Interrupted", we unset the exception flag before throwing.
 --
 rethrow :: DynFlags -> IO a -> IO a

+#if __GLASGOW_HASKELL__ < 609

 rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn
                 case e of
                    -- If -fbreak-on-error, we break unconditionally,
 rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn
                 case e of
                    -- If -fbreak-on-error, we break unconditionally,

@@ -354,7 +356,22 @@ rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn
                    _    -> poke exceptionFlag 0
 
                 Exception.throwIO e
                    _    -> poke exceptionFlag 0
 
                 Exception.throwIO e

-
+#else
+rethrow dflags io = Exception.catch io $ \se@(SomeException e) -> do
+                   -- If -fbreak-on-error, we break unconditionally,
+                   --  but with care of not breaking twice 
+                if dopt Opt_BreakOnError dflags &&
+                   not (dopt Opt_BreakOnException dflags)
+                    then poke exceptionFlag 1
+                    else case cast e of
+                         -- If it is an "Interrupted" exception, we allow
+                         --  a possible break by way of -fbreak-on-exception
+                         Just Interrupted -> return ()
+                         -- In any other case, we don't want to break
+                         _ -> poke exceptionFlag 0
+
+                Exception.throwIO se
+#endif

 
 withInterruptsSentTo :: ThreadId -> IO r -> IO r
 withInterruptsSentTo thread get_result = do
 
 withInterruptsSentTo :: ThreadId -> IO r -> IO r
 withInterruptsSentTo thread get_result = do

@@ -406,7 +423,7 @@ resume (Session ref) step
        resume = ic_resume ic
 
    case resume of
        resume = ic_resume ic
 
    case resume of

-     [] -> throwDyn (ProgramError "not stopped at a breakpoint")
+     [] -> ghcError (ProgramError "not stopped at a breakpoint")

      (r:rs) -> do
         -- unbind the temporary locals by restoring the TypeEnv from
         -- before the breakpoint, and drop this Resume from the
      (r:rs) -> do
         -- unbind the temporary locals by restoring the TypeEnv from
         -- before the breakpoint, and drop this Resume from the

@@ -457,16 +474,16 @@ moveHist :: (Int -> Int) -> Session -> IO ([Name], Int, SrcSpan)
 moveHist fn (Session ref) = do
   hsc_env <- readIORef ref
   case ic_resume (hsc_IC hsc_env) of
 moveHist fn (Session ref) = do
   hsc_env <- readIORef ref
   case ic_resume (hsc_IC hsc_env) of

-     [] -> throwDyn (ProgramError "not stopped at a breakpoint")
+     [] -> ghcError (ProgramError "not stopped at a breakpoint")

      (r:rs) -> do
         let ix = resumeHistoryIx r
             history = resumeHistory r
             new_ix = fn ix
         --
         when (new_ix > length history) $
      (r:rs) -> do
         let ix = resumeHistoryIx r
             history = resumeHistory r
             new_ix = fn ix
         --
         when (new_ix > length history) $

-           throwDyn (ProgramError "no more logged breakpoints")
+           ghcError (ProgramError "no more logged breakpoints")

         when (new_ix < 0) $
         when (new_ix < 0) $

-           throwDyn (ProgramError "already at the beginning of the history")
+           ghcError (ProgramError "already at the beginning of the history")

 
         let
           update_ic apStack mb_info = do
 
         let
           update_ic apStack mb_info = do

@@ -774,12 +791,12 @@ vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
 mkTopLevEnv hpt modl
   = case lookupUFM hpt (moduleName modl) of
 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
 mkTopLevEnv hpt modl
   = case lookupUFM hpt (moduleName modl) of

-      Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++ 
+      Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++ 

                                                 showSDoc (ppr modl)))
       Just details ->
         case mi_globals (hm_iface details) of
                Nothing  -> 
                                                 showSDoc (ppr modl)))
       Just details ->
         case mi_globals (hm_iface details) of
                Nothing  -> 

-                  throwDyn (ProgramError ("mkTopLevEnv: not interpreted " 
+                  ghcError (ProgramError ("mkTopLevEnv: not interpreted " 

                                                ++ showSDoc (ppr modl)))
                Just env -> return env
 
                                                ++ showSDoc (ppr modl)))
                Just env -> return env
 

@@ -808,12 +825,12 @@ moduleIsInterpreted s modl = withSession s $ \h ->
 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
 getInfo s name 
   = withSession s $ \hsc_env -> 
 getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
 getInfo s name 
   = withSession s $ \hsc_env -> 

-    do { mb_stuff <- tcRnGetInfo hsc_env name
-       ; case mb_stuff of
-           Nothing -> return Nothing
-           Just (thing, fixity, ispecs) -> do
-       { let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
-       ; return (Just (thing, fixity, filter (plausible rdr_env) ispecs)) } }
+    do mb_stuff <- tcRnGetInfo hsc_env name
+       case mb_stuff of
+         Nothing -> return Nothing
+         Just (thing, fixity, ispecs) -> do
+           let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
+           return (Just (thing, fixity, filter (plausible rdr_env) ispecs))

   where
     plausible rdr_env ispec    -- Dfun involving only names that are in ic_rn_glb_env
        = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
   where
     plausible rdr_env ispec    -- Dfun involving only names that are in ic_rn_glb_env
        = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec