X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=794459c4587ed70a14688f7791eef0a9b7b1c391;hb=cbbee4e8727c583daf32d9bf17f00afaa839ef10;hp=e5d91c930cc9b3988ee16393093945c5de8f39fe;hpb=decbb181cf7a06c6135ca451307a7e7214385f2e;p=ghc-hetmet.git diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index e5d91c9..794459c 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -47,7 +47,6 @@ import TcType hiding (typeKind) import InstEnv import Var import Id -import IdInfo import Name hiding ( varName ) import NameSet import RdrName @@ -72,6 +71,7 @@ import Outputable import FastString import MonadUtils +import System.Directory import Data.Dynamic import Data.List (find) import Control.Monad @@ -213,6 +213,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 +229,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 @@ -350,32 +373,13 @@ sandboxIO dflags statusMVar thing = -- 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, - -- but with care of not breaking twice - _ | dopt Opt_BreakOnError dflags && - not(dopt Opt_BreakOnException dflags) - -> poke exceptionFlag 1 - - -- If it is an "Interrupted" exception, we allow - -- a possible break by way of -fbreak-on-exception - DynException d | Just Interrupted <- fromDynamic d - -> return () - - -- In any other case, we don't want to break - _ -> poke exceptionFlag 0 - - Exception.throwIO e -#else -rethrow dflags io = Exception.catch io $ \se@(SomeException e) -> do +rethrow dflags io = Exception.catch io $ \se -> 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 + else case fromException se of -- If it is an "Interrupted" exception, we allow -- a possible break by way of -fbreak-on-exception Just Interrupted -> return () @@ -383,7 +387,6 @@ rethrow dflags io = Exception.catch io $ \se@(SomeException e) -> do _ -> poke exceptionFlag 0 Exception.throwIO se -#endif withInterruptsSentTo :: ThreadId -> IO r -> IO r withInterruptsSentTo thread get_result = do @@ -428,8 +431,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 @@ -456,7 +459,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 @@ -464,10 +468,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 -> @@ -543,8 +549,7 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do e_fs = fsLit "e" e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol) - exn_id = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar) - vanillaIdInfo + exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar) new_tyvars = unitVarSet e_tyvar ictxt0 = hsc_IC hsc_env @@ -595,8 +600,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do -- _result in scope at any time. let result_name = mkInternalName (getUnique result_fs) (mkVarOccFS result_fs) span - result_id = Id.mkGlobalId VanillaGlobal result_name result_ty - vanillaIdInfo + result_id = Id.mkVanillaGlobal result_name result_ty -- for each Id we're about to bind in the local envt: -- - skolemise the type variables in its type, so they can't @@ -605,18 +609,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 @@ -630,7 +638,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do loc = nameSrcSpan (idName id) name = mkInternalName uniq occ loc ty = idType id - new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id) + new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id) return new_id rttiEnvironment :: HscEnv -> IO HscEnv