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 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
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)
- | Complete (Either Exception [HValue])
+ | Complete (Either SomeException [HValue])
-- ^ the computation completed with either an exception or a value
data Resume
-- 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
-- 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,
_ -> 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
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
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) $
- throwDyn (ProgramError "no more logged breakpoints")
+ ghcError (ProgramError "no more logged breakpoints")
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
-- -----------------------------------------------------------------------------
-- After stopping at a breakpoint, add free variables to the environment
result_fs :: FastString
-result_fs = FSLIT("_result")
+result_fs = fsLit "_result"
bindLocalsAtBreakpoint
:: HscEnv
-- bind, all we can do is bind a local variable to the exception
-- value.
bindLocalsAtBreakpoint hsc_env apStack Nothing = do
- let exn_fs = FSLIT("_exception")
+ let exn_fs = fsLit "_exception"
exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
- e_fs = FSLIT("e")
+ e_fs = fsLit "e"
e_name = mkInternalName (getUnique e_fs) (mkTyVarOcc e_fs) span
e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
exn_id = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
ictxt0 = hsc_IC hsc_env
ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
- span = mkGeneralSrcSpan FSLIT("<exception thrown>")
+ span = mkGeneralSrcSpan (fsLit "<exception thrown>")
--
Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
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 ->
- throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
+ ghcError (ProgramError ("mkTopLevEnv: not interpreted "
++ showSDoc (ppr modl)))
Just env -> return 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
projects / ghc-hetmet.git / blobdiff