diff options
Diffstat (limited to 'compiler/main/InteractiveEval.hs')
| -rw-r--r-- | compiler/main/InteractiveEval.hs | 34 |
1 files changed, 18 insertions, 16 deletions
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 2f819e4a60..eb23a60f82 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -94,7 +94,7 @@ import qualified Parser (parseStmt, parseModule, parseDeclaration) import System.Directory import Data.Dynamic import Data.Either -import Data.List (find) +import Data.List (find,intercalate) import StringBuffer (stringToStringBuffer) import Control.Monad import GHC.Exts @@ -293,7 +293,7 @@ handleRunStatus step expr bindings final_ids status history | otherwise = not_tracing where tracing - | EvalBreak is_exception apStack_ref info_ref resume_ctxt <- status + | EvalBreak is_exception apStack_ref info_ref resume_ctxt _ccs <- status , not is_exception = do hsc_env <- getSession @@ -320,7 +320,7 @@ handleRunStatus step expr bindings final_ids status history not_tracing -- Hit a breakpoint - | EvalBreak is_exception apStack_ref info_ref resume_ctxt <- status + | EvalBreak is_exception apStack_ref info_ref resume_ctxt ccs <- status = do hsc_env <- getSession let dflags = hsc_dflags hsc_env @@ -330,7 +330,7 @@ handleRunStatus step expr bindings final_ids status history apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref let mb_info | is_exception = Nothing | otherwise = Just info - (hsc_env1, names, span) <- liftIO $ + (hsc_env1, names, span, decl) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack_fhv mb_info let resume = Resume @@ -338,6 +338,8 @@ handleRunStatus step expr bindings final_ids status history , resumeBindings = bindings, resumeFinalIds = final_ids , resumeApStack = apStack_fhv, resumeBreakInfo = mb_info , resumeSpan = span, resumeHistory = toListBL history + , resumeDecl = decl + , resumeCCS = ccs , resumeHistoryIx = 0 } hsc_env2 = pushResume hsc_env1 resume @@ -365,8 +367,7 @@ isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool isBreakEnabled hsc_env inf = case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of Just hmi -> do - w <- getBreak (hsc_dflags hsc_env) - (modBreaks_flags (getModBreaks hmi)) + w <- getBreak (modBreaks_flags (getModBreaks hmi)) (breakInfo_number inf) case w of Just n -> return (n /= 0); _other -> return False _ -> @@ -419,13 +420,13 @@ resumeExec canLogSpan step fromListBL 50 hist handleRunStatus step expr bindings final_ids status hist' -back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan) +back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String) back n = moveHist (+n) -forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan) +forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String) forward n = moveHist (subtract n) -moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan) +moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String) moveHist fn = do hsc_env <- getSession case ic_resume (hsc_IC hsc_env) of @@ -443,15 +444,15 @@ moveHist fn = do let update_ic apStack mb_info = do - (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env - apStack mb_info + (hsc_env1, names, span, decl) <- + liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info let ic = hsc_IC hsc_env1 r' = r { resumeHistoryIx = new_ix } ic' = ic { ic_resume = r':rs } modifySession (\_ -> hsc_env1{ hsc_IC = ic' }) - return (names, new_ix, span) + return (names, new_ix, span, decl) -- careful: we want apStack to be the AP_STACK itself, not a thunk -- around it, hence the cases are carefully constructed below to @@ -474,7 +475,7 @@ bindLocalsAtBreakpoint :: HscEnv -> ForeignHValue -> Maybe BreakInfo - -> IO (HscEnv, [Name], SrcSpan) + -> IO (HscEnv, [Name], SrcSpan, String) -- Nothing case: we stopped when an exception was raised, not at a -- breakpoint. We have no location information or local variables to @@ -482,7 +483,7 @@ bindLocalsAtBreakpoint -- value. bindLocalsAtBreakpoint hsc_env apStack Nothing = do let exn_occ = mkVarOccFS (fsLit "_exception") - span = mkGeneralSrcSpan (fsLit "<exception thrown>") + span = mkGeneralSrcSpan (fsLit "<unknown>") exn_name <- newInteractiveBinder hsc_env exn_occ span let e_fs = fsLit "e" @@ -495,7 +496,7 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do -- Linker.extendLinkEnv [(exn_name, apStack)] - return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span) + return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>") -- Just case: we stopped at a breakpoint, we have information about the location -- of the breakpoint and the free variables of the expression. @@ -510,6 +511,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just info) = do result_ty = breakInfo_resty info occs = modBreaks_vars breaks ! index span = modBreaks_locs breaks ! index + decl = intercalate "." $ modBreaks_decls breaks ! index -- Filter out any unboxed ids; -- we can't bind these at the prompt @@ -556,7 +558,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just info) = do Linker.extendLinkEnv (zip names fhvs) when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)] hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } - return (hsc_env1, if result_ok then result_name:names else names, span) + return (hsc_env1, if result_ok then result_name:names else names, span, decl) where -- We need a fresh Unique for each Id we bind, because the linker -- state is single-threaded and otherwise we'd spam old bindings |