X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=7467c2ea4fa4619d72fc9dcb5417911aeb4c5aee;hb=f8c572418898d4c0e703f6d67510c9c37b51cc6e;hp=42b787a6b3387a974b835c038591268e0885cc0a;hpb=b0d80aa3d908a6b9991920a5ac7fd1b437ecafd3;p=ghc-hetmet.git diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 42b787a..7467c2e 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -14,6 +14,7 @@ module InteractiveEval ( abandon, abandonAll, getResumeContext, getHistorySpan, + getHistoryModule, back, forward, setContext, getContext, nameSetToGlobalRdrEnv, @@ -28,7 +29,7 @@ module InteractiveEval ( isModuleInterpreted, compileExpr, dynCompileExpr, lookupName, - obtainTerm, obtainTerm1, reconstructType, + Term(..), obtainTerm, obtainTerm1, obtainTermB, reconstructType, skolemiseSubst, skolemiseTy #endif ) where @@ -69,6 +70,7 @@ import BasicTypes import Outputable import Data.Dynamic +import Data.List (find) import Control.Monad import Foreign import Foreign.C @@ -76,6 +78,7 @@ import GHC.Exts import Data.Array import Control.Exception as Exception import Control.Concurrent +import Data.List (sortBy) import Data.IORef import Foreign.StablePtr @@ -128,17 +131,50 @@ isStep _ = True data History = History { historyApStack :: HValue, - historyBreakInfo :: BreakInfo + historyBreakInfo :: BreakInfo, + historyEnclosingDecl :: Id + -- ^^ A cache of the enclosing top level declaration, for convenience } -getHistorySpan :: Session -> History -> IO SrcSpan -getHistorySpan s hist = withSession s $ \hsc_env -> do - let inf = historyBreakInfo hist +mkHistory :: HscEnv -> HValue -> BreakInfo -> History +mkHistory hsc_env hval bi = let + h = History hval bi decl + decl = findEnclosingDecl hsc_env (getHistoryModule h) + (getHistorySpan hsc_env h) + in h + +getHistoryModule :: History -> Module +getHistoryModule = breakInfo_module . historyBreakInfo + +getHistorySpan :: HscEnv -> History -> SrcSpan +getHistorySpan hsc_env hist = + let inf = historyBreakInfo hist num = breakInfo_number inf - case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of - Just hmi -> return (modBreaks_locs (md_modBreaks (hm_details hmi)) ! num) + in case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of + Just hmi -> modBreaks_locs (md_modBreaks (hm_details hmi)) ! num _ -> panic "getHistorySpan" +-- | Finds the enclosing top level function name +findEnclosingDecl :: HscEnv -> Module -> SrcSpan -> Id +findEnclosingDecl hsc_env mod span = + case lookupUFM (hsc_HPT hsc_env) (moduleName mod) of + Nothing -> panic "findEnclosingDecl" + Just hmi -> let + globals = typeEnvIds (md_types (hm_details hmi)) + Just decl = + find (\id -> let n = idName id in + nameSrcSpan n < span && isExternalName n) + (reverse$ sortBy (compare `on` (nameSrcSpan.idName)) + globals) + in decl + +-- | Find the Module corresponding to a FilePath +findModuleFromFile :: HscEnv -> FilePath -> Maybe Module +findModuleFromFile hsc_env fp = + listToMaybe $ [ms_mod ms | ms <- hsc_mod_graph hsc_env + , ml_hs_file(ms_location ms) == Just (read fp)] + + -- | Run a statement in the current interactive context. Statement -- may bind multple values. runStmt :: Session -> String -> SingleStep -> IO RunResult @@ -223,7 +259,7 @@ traceRunStatus expr ref bindings final_ids if b then handle_normally else do - let history' = consBL (History apStack info) history + let history' = mkHistory hsc_env apStack info `consBL` history -- probably better make history strict here, otherwise -- our BoundedList will be pointless. evaluate history' @@ -358,7 +394,7 @@ resume (Session ref) step when (isStep step) $ setStepFlag case r of Resume expr tid breakMVar statusMVar bindings - final_ids apStack info _ _ _ -> do + final_ids apStack info _ hist _ -> do withBreakAction (isStep step) (hsc_dflags hsc_env) breakMVar statusMVar $ do status <- withInterruptsSentTo @@ -366,14 +402,19 @@ resume (Session ref) step -- this awakens the stopped thread... return tid) (takeMVar statusMVar) - -- and wait for the result + -- and wait for the result + let hist' = + case info of + Nothing -> fromListBL 50 hist + Just i -> mkHistory hsc_env apStack i `consBL` + fromListBL 50 hist case step of RunAndLogSteps -> traceRunStatus expr ref bindings final_ids - breakMVar statusMVar status emptyHistory + breakMVar statusMVar status hist' _other -> handleRunStatus expr ref bindings final_ids - breakMVar statusMVar status emptyHistory + breakMVar statusMVar status hist' back :: Session -> IO ([Name], Int, SrcSpan) @@ -417,7 +458,7 @@ moveHist fn (Session ref) = do resumeBreakInfo = mb_info } -> update_ic apStack mb_info else case history !! (new_ix - 1) of - History apStack info -> + History apStack info _ -> update_ic apStack (Just info) -- ----------------------------------------------------------------------------- @@ -632,6 +673,8 @@ consBL a (BL len bound left right) toListBL (BL _ _ left right) = left ++ reverse right +fromListBL bound l = BL (length l) bound l [] + -- lenBL (BL len _ _ _) = len -- ----------------------------------------------------------------------------- @@ -867,12 +910,17 @@ isModuleInterpreted s mod_summary = withSession s $ \hsc_env -> obtainTerm1 :: HscEnv -> Bool -> Maybe Type -> a -> IO Term obtainTerm1 hsc_env force mb_ty x = - cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x) + cvObtainTerm hsc_env maxBound force mb_ty (unsafeCoerce# x) + +obtainTermB :: HscEnv -> Int -> Bool -> Id -> IO Term +obtainTermB hsc_env bound force id = do + hv <- Linker.getHValue hsc_env (varName id) + cvObtainTerm hsc_env bound force (Just$ idType id) hv obtainTerm :: HscEnv -> Bool -> Id -> IO Term obtainTerm hsc_env force id = do hv <- Linker.getHValue hsc_env (varName id) - cvObtainTerm hsc_env force (Just$ idType id) hv + cvObtainTerm hsc_env maxBound force (Just$ idType id) hv -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic reconstructType :: HscEnv -> Bool -> Id -> IO (Maybe Type)