X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=7e4406e61bceea28cf70cf6a3fd0024072b19aac;hb=f4e82828c43302ce4ccc02a2978852106e6f8056;hp=b4d49c9268054b2c7301f5f75e84b39ab639ad95;hpb=9ffadf219cbc4f8ec57264786df936a3cee88aec;p=ghc-hetmet.git diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index b4d49c9..7e4406e 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -18,7 +18,7 @@ module InteractiveEval ( getHistoryModule, back, forward, setContext, getContext, - nameSetToGlobalRdrEnv, + availsToGlobalRdrEnv, getNamesInScope, getRdrNamesInScope, moduleIsInterpreted, @@ -42,12 +42,12 @@ module InteractiveEval ( import HscMain hiding (compileExpr) import HscTypes import TcRnDriver -import Type hiding (typeKind) -import TcType hiding (typeKind) +import RnNames ( gresFromAvails ) import InstEnv +import Type +import TcType hiding( typeKind ) import Var import Id -import IdInfo import Name hiding ( varName ) import NameSet import RdrName @@ -60,7 +60,7 @@ import Unique import UniqSupply import Module import Panic -import LazyUniqFM +import UniqFM import Maybes import ErrUtils import Util @@ -72,6 +72,7 @@ import Outputable import FastString import MonadUtils +import System.Directory import Data.Dynamic import Data.List (find) import Control.Monad @@ -82,7 +83,7 @@ import Data.Array import Exception import Control.Concurrent import Data.List (sortBy) -import Foreign.StablePtr +-- import Foreign.StablePtr import System.IO -- ----------------------------------------------------------------------------- @@ -213,6 +214,7 @@ runStmt expr step = clearWarnings status <- + withVirtualCWD $ withBreakAction (isStep step) dflags' breakMVar statusMVar $ do let thing_to_run = unsafeCoerce# hval :: IO [HValue] liftIO $ sandboxIO dflags' statusMVar thing_to_run @@ -228,6 +230,28 @@ runStmt expr step = handleRunStatus expr bindings ids breakMVar statusMVar status emptyHistory +withVirtualCWD :: GhcMonad m => m a -> m a +withVirtualCWD m = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + + let set_cwd = do + dir <- liftIO $ getCurrentDirectory + case ic_cwd ic of + Just dir -> liftIO $ setCurrentDirectory dir + Nothing -> return () + return dir + + reset_cwd orig_dir = do + virt_dir <- liftIO $ getCurrentDirectory + hsc_env <- getSession + let old_IC = hsc_IC hsc_env + setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } } + liftIO $ setCurrentDirectory orig_dir + + gbracket set_cwd reset_cwd $ \_ -> m + + emptyHistory :: BoundedList History emptyHistory = nilBL 50 -- keep a log of length 50 @@ -285,7 +309,7 @@ traceRunStatus expr bindings final_ids let history' = mkHistory hsc_env apStack info `consBL` history -- probably better make history strict here, otherwise -- our BoundedList will be pointless. - liftIO $ evaluate history' + _ <- liftIO $ evaluate history' status <- withBreakAction True (hsc_dflags hsc_env) breakMVar statusMVar $ do @@ -357,9 +381,9 @@ rethrow dflags io = Exception.catch io $ \se -> do not (dopt Opt_BreakOnException dflags) then poke exceptionFlag 1 else case fromException se of - -- If it is an "Interrupted" exception, we allow + -- If it is a "UserInterrupt" exception, we allow -- a possible break by way of -fbreak-on-exception - Just Interrupted -> return () + Just UserInterrupt -> return () -- In any other case, we don't want to break _ -> poke exceptionFlag 0 @@ -408,8 +432,8 @@ noBreakAction :: Bool -> BreakInfo -> HValue -> IO () noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint" noBreakAction True _ _ = return () -- exception: just continue -resume :: GhcMonad m => SingleStep -> m RunResult -resume step +resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult +resume canLogSpan step = do hsc_env <- getSession let ic = hsc_IC hsc_env @@ -436,7 +460,8 @@ resume step when (isStep step) $ liftIO setStepFlag case r of Resume expr tid breakMVar statusMVar bindings - final_ids apStack info _ hist _ -> do + final_ids apStack info span hist _ -> do + withVirtualCWD $ do withBreakAction (isStep step) (hsc_dflags hsc_env) breakMVar statusMVar $ do status <- liftIO $ withInterruptsSentTo tid $ do @@ -444,10 +469,12 @@ resume step -- this awakens the stopped thread... takeMVar statusMVar -- and wait for the result - let hist' = - case info of - Nothing -> fromListBL 50 hist - Just i -> mkHistory hsc_env apStack i `consBL` + let prevHistoryLst = fromListBL 50 hist + hist' = case info of + Nothing -> prevHistoryLst + Just i + | not $canLogSpan span -> prevHistoryLst + | otherwise -> mkHistory hsc_env apStack i `consBL` fromListBL 50 hist case step of RunAndLogSteps -> @@ -560,7 +587,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do -- has been accidentally evaluated, or something else has gone wrong. -- 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 + mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets) let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ] when (any isNothing mb_hValues) $ debugTraceMsg (hsc_dflags hsc_env) 1 $ @@ -583,18 +610,22 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do -- - tidy the type variables -- - globalise the Id (Ids are supposed to be Global, apparently). -- - let all_ids | isPointer result_id = result_id : new_ids - | otherwise = new_ids + let result_ok = isPointer result_id + && not (isUnboxedTupleType (idType result_id)) + + all_ids | result_ok = result_id : new_ids + | otherwise = new_ids (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys new_tyvars = unionVarSets tyvarss - let final_ids = zipWith setIdType all_ids tidy_tys + final_ids = zipWith setIdType all_ids tidy_tys ictxt0 = hsc_IC hsc_env ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars + Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ] - Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] + when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } - return (hsc_env1, result_name:names, span) + return (hsc_env1, if result_ok then result_name:names else names, span) where mkNewId :: OccName -> Id -> IO Id mkNewId occ id = do @@ -777,25 +808,20 @@ setContext toplev_mods export_mods = do -- Make a GlobalRdrEnv based on the exports of the modules only. mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv -mkExportEnv hsc_env mods = do - stuff <- mapM (getModuleExports hsc_env) mods - let - (_msgs, mb_name_sets) = unzip stuff - gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod) - | (Just avails, mod) <- zip mb_name_sets mods ] - -- - return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres - -nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv -nameSetToGlobalRdrEnv names mod = - mkGlobalRdrEnv [ GRE { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod } - | name <- nameSetToList names ] - -vanillaProv :: ModuleName -> Provenance --- We're building a GlobalRdrEnv as if the user imported --- all the specified modules into the global interactive module -vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] +mkExportEnv hsc_env mods + = do { stuff <- mapM (getModuleExports hsc_env) mods + ; let (_msgs, mb_name_sets) = unzip stuff + envs = [ availsToGlobalRdrEnv (moduleName mod) avails + | (Just avails, mod) <- zip mb_name_sets mods ] + ; return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs } + +availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv +availsToGlobalRdrEnv mod_name avails + = mkGlobalRdrEnv (gresFromAvails imp_prov avails) where + -- We're building a GlobalRdrEnv as if the user imported + -- all the specified modules into the global interactive module + imp_prov = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, is_qual = False, is_dloc = srcLocSpan interactiveSrcLoc }