--
-- -----------------------------------------------------------------------------
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module InteractiveEval (
#ifdef GHCI
RunResult(..), Status(..), Resume(..), History(..),
import UniqSupply
import Module
import Panic
-import UniqFM
+import LazyUniqFM
import Maybes
import ErrUtils
import Util
import SrcLoc
import BreakArray
import RtClosureInspect
-import Packages
import BasicTypes
import Outputable
+import FastString
import Data.Dynamic
import Data.List (find)
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
| SingleStep
| RunAndLogSteps
+isStep :: SingleStep -> Bool
isStep RunToCompletion = False
isStep _ = True
handleRunStatus expr ref bindings ids
breakMVar statusMVar status emptyHistory
-
+emptyHistory :: BoundedList History
emptyHistory = nilBL 50 -- keep a log of length 50
+handleRunStatus :: String -> IORef HscEnv -> ([Id], TyVarSet) -> [Id]
+ -> MVar () -> MVar Status -> Status -> BoundedList History
+ -> IO RunResult
handleRunStatus expr ref bindings final_ids breakMVar statusMVar status
history =
case status of
writeIORef ref hsc_env'
return (RunOk final_names)
-
+traceRunStatus :: String -> IORef HscEnv -> ([Id], TyVarSet) -> [Id]
+ -> MVar () -> MVar Status -> Status -> BoundedList History
+ -> IO RunResult
traceRunStatus expr ref bindings final_ids
breakMVar statusMVar status history = do
hsc_env <- readIORef ref
evaluate history'
status <- withBreakAction True (hsc_dflags hsc_env)
breakMVar statusMVar $ do
- withInterruptsSentTo
- (do putMVar breakMVar () -- awaken the stopped thread
- return tid)
- (takeMVar statusMVar) -- and wait for the result
+ withInterruptsSentTo tid $ do
+ putMVar breakMVar () -- awaken the stopped thread
+ takeMVar statusMVar -- and wait for the result
traceRunStatus expr ref bindings final_ids
breakMVar statusMVar status history'
_other ->
foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt
foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt
-setStepFlag = poke stepFlag 1
+setStepFlag :: IO ()
+setStepFlag = poke stepFlag 1
+resetStepFlag :: IO ()
resetStepFlag = poke stepFlag 0
-- this points to the IO action that is executed when a breakpoint is hit
-- thread. ToDo: we might want a way to continue even if the target
-- 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)
sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
-sandboxIO dflags statusMVar thing =
- withInterruptsSentTo
- (forkIO (do res <- Exception.try (rethrow dflags thing)
- putMVar statusMVar (Complete res)))
- (takeMVar statusMVar)
+sandboxIO dflags statusMVar thing =
+ block $ do -- fork starts blocked
+ id <- forkIO $ do res <- Exception.try (unblock $ rethrow dflags thing)
+ putMVar statusMVar (Complete res) -- empty: can't block
+ withInterruptsSentTo id $ takeMVar statusMVar
+
-- We want to turn ^C into a break when -fbreak-on-exception is on,
-- but it's an async exception and we only break for sync exceptions.
-- 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 :: IO ThreadId -> IO r -> IO r
-withInterruptsSentTo io get_result = do
- ts <- takeMVar interruptTargetThread
- child <- io
- putMVar interruptTargetThread (child:ts)
- get_result `finally` modifyMVar_ interruptTargetThread (return.tail)
+withInterruptsSentTo :: ThreadId -> IO r -> IO r
+withInterruptsSentTo thread get_result = do
+ bracket (modifyMVar_ interruptTargetThread (return . (thread:)))
+ (\_ -> modifyMVar_ interruptTargetThread (\tl -> return $! tail tl))
+ (\_ -> get_result)
-- This function sets up the interpreter for catching breakpoints, and
-- resets everything when the computation has stopped running. This
-- is a not-very-good way to ensure that only the interactive
-- evaluation should generate breakpoints.
+withBreakAction :: Bool -> DynFlags -> MVar () -> MVar Status -> IO a -> IO a
withBreakAction step dflags breakMVar statusMVar io
= bracket setBreakAction resetBreakAction (\_ -> io)
where
resetStepFlag
freeStablePtr stablePtr
+noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ())
noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
-noBreakAction False info apStack = putStrLn "*** Ignoring breakpoint"
-noBreakAction True info apStack = return () -- exception: just continue
+noBreakAction :: Bool -> BreakInfo -> HValue -> IO ()
+noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
+noBreakAction True _ _ = return () -- exception: just continue
resume :: Session -> SingleStep -> IO RunResult
resume (Session ref) step
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
final_ids apStack info _ hist _ -> do
withBreakAction (isStep step) (hsc_dflags hsc_env)
breakMVar statusMVar $ do
- status <- withInterruptsSentTo
- (do putMVar breakMVar ()
+ status <- withInterruptsSentTo tid $ do
+ putMVar breakMVar ()
-- this awakens the stopped thread...
- return tid)
- (takeMVar statusMVar)
+ takeMVar statusMVar
-- and wait for the result
let hist' =
case info of
forward :: Session -> IO ([Name], Int, SrcSpan)
forward = moveHist (subtract 1)
+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
- [] -> 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 = FSLIT("_result")
-
+result_fs :: FastString
+result_fs = fsLit "_result"
+
bindLocalsAtBreakpoint
:: HscEnv
-> HValue
-- 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)
-- So that we don't fall over in a heap when this happens, just don't
-- bind any free variables instead, and we emit a warning.
mb_hValues <- mapM (getIdValFromApStack apStack) offsets
- let filtered_ids = [ id | (id, Just hv) <- zip ids mb_hValues ]
+ let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
when (any isNothing mb_hValues) $
debugTraceMsg (hsc_dflags hsc_env) 1 $
text "Warning: _result has been evaluated, some bindings have been lost"
tys <- reconstructType hsc_env 10 `mapM` incompletelyTypedIds
-- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds)
- let substs = [computeRTTIsubst ty ty'
+ improvs <- sequence [improveRTTIType hsc_env ty ty'
| (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys]
- ic' = foldr (flip substInteractiveContext) ic
- (map skolemiseSubst $ catMaybes substs)
+ let ic' = foldr (\mb_subst ic' ->
+ maybe (WARN(True, text ("RTTI failed to calculate the "
+ ++ "improvement for a type")) ic')
+ (substInteractiveContext ic' . skolemiseSubst)
+ mb_subst)
+ ic
+ improvs
return hsc_env{hsc_IC=ic'}
+skolemiseSubst :: TvSubst -> TvSubst
skolemiseSubst subst = subst `setTvSubstEnv`
mapVarEnv (fst.skolemiseTy) (getTvSubstEnv subst)
nilBL :: Int -> BoundedList a
nilBL bound = BL 0 bound [] []
+consBL :: a -> BoundedList a -> BoundedList a
consBL a (BL len bound left right)
| len < bound = BL (len+1) bound (a:left) right
| null right = BL len bound [a] $! tail (reverse left)
| otherwise = BL len bound (a:left) $! tail right
+toListBL :: BoundedList a -> [a]
toListBL (BL _ _ left right) = left ++ reverse right
+fromListBL :: Int -> [a] -> BoundedList a
fromListBL bound l = BL (length l) bound l []
-- lenBL (BL len _ _ _) = len
-> [Module] -- entire top level scope of these modules
-> [Module] -- exports only of these modules
-> IO ()
-setContext sess@(Session ref) toplev_mods export_mods = do
+setContext (Session ref) toplev_mods export_mods = do
hsc_env <- readIORef ref
let old_ic = hsc_IC hsc_env
hpt = hsc_HPT hsc_env
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
hvals <- (unsafeCoerce# hval) :: IO [HValue]
case (ids,hvals) of
- ([n],[hv]) -> return (Just hv)
+ ([_],[hv]) -> return (Just hv)
_ -> panic "compileExpr"
-- -----------------------------------------------------------------------------