-- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow, 2005-2007 -- -- Running statements interactively -- -- ----------------------------------------------------------------------------- {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details module InteractiveEval ( #ifdef GHCI RunResult(..), Status(..), Resume(..), History(..), runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation, parseImportDecl, SingleStep(..), resume, abandon, abandonAll, getResumeContext, getHistorySpan, getModBreaks, getHistoryModule, back, forward, setContext, getContext, availsToGlobalRdrEnv, getNamesInScope, getRdrNamesInScope, moduleIsInterpreted, getInfo, exprType, typeKind, parseName, showModule, isModuleInterpreted, compileExpr, dynCompileExpr, Term(..), obtainTermFromId, obtainTermFromVal, reconstructType #endif ) where #ifdef GHCI #include "HsVersions.h" import GhcMonad import HscMain import HsSyn import HscTypes import InstEnv import Type hiding( typeKind ) import TcType hiding( typeKind ) import Var import Id import Name hiding ( varName ) import NameSet import Avail import RdrName import VarSet import VarEnv import ByteCodeInstr import Linker import DynFlags import Unique import UniqSupply import Module import Panic import UniqFM import Maybes import ErrUtils import SrcLoc import BreakArray import RtClosureInspect import Outputable import FastString import MonadUtils import System.Directory import Data.Dynamic import Data.List (find) import Control.Monad #if __GLASGOW_HASKELL__ >= 701 import Foreign.Safe #else import Foreign hiding (unsafePerformIO) #endif import Foreign.C import GHC.Exts import Data.Array import Exception import Control.Concurrent import System.IO import System.IO.Unsafe -- ----------------------------------------------------------------------------- -- running a statement interactively data RunResult = RunOk [Name] -- ^ names bound by this evaluation | 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 SomeException [HValue]) -- ^ the computation completed with either an exception or a value data Resume = Resume { resumeStmt :: String, -- the original statement resumeThreadId :: ThreadId, -- thread running the computation resumeBreakMVar :: MVar (), resumeStatMVar :: MVar Status, resumeBindings :: ([TyThing], GlobalRdrEnv), resumeFinalIds :: [Id], -- [Id] to bind on completion resumeApStack :: HValue, -- The object from which we can get -- value of the free variables. resumeBreakInfo :: Maybe BreakInfo, -- the breakpoint we stopped at -- (Nothing <=> exception) resumeSpan :: SrcSpan, -- just a cache, otherwise it's a pain -- to fetch the ModDetails & ModBreaks -- to get this. resumeHistory :: [History], resumeHistoryIx :: Int -- 0 <==> at the top of the history } getResumeContext :: GhcMonad m => m [Resume] getResumeContext = withSession (return . ic_resume . hsc_IC) data SingleStep = RunToCompletion | SingleStep | RunAndLogSteps isStep :: SingleStep -> Bool isStep RunToCompletion = False isStep _ = True data History = History { historyApStack :: HValue, historyBreakInfo :: BreakInfo, historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint } mkHistory :: HscEnv -> HValue -> BreakInfo -> History mkHistory hsc_env hval bi = let decls = findEnclosingDecls hsc_env bi in History hval bi decls getHistoryModule :: History -> Module getHistoryModule = breakInfo_module . historyBreakInfo getHistorySpan :: HscEnv -> History -> SrcSpan getHistorySpan hsc_env hist = let inf = historyBreakInfo hist num = breakInfo_number inf in case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of Just hmi -> modBreaks_locs (getModBreaks hmi) ! num _ -> panic "getHistorySpan" getModBreaks :: HomeModInfo -> ModBreaks getModBreaks hmi | Just linkable <- hm_linkable hmi, [BCOs _ modBreaks] <- linkableUnlinked linkable = modBreaks | otherwise = emptyModBreaks -- probably object code {- | Finds the enclosing top level function name -} -- ToDo: a better way to do this would be to keep hold of the decl_path computed -- by the coverage pass, which gives the list of lexically-enclosing bindings -- for each tick. findEnclosingDecls :: HscEnv -> BreakInfo -> [String] findEnclosingDecls hsc_env inf = let hmi = expectJust "findEnclosingDecls" $ lookupUFM (hsc_HPT hsc_env) (moduleName $ breakInfo_module inf) mb = getModBreaks hmi in modBreaks_decls mb ! breakInfo_number inf -- | Run a statement in the current interactive context. Statement -- may bind multple values. runStmt :: GhcMonad m => String -> SingleStep -> m RunResult runStmt = runStmtWithLocation "" 1 -- | Run a statement in the current interactive context. Passing debug information -- Statement may bind multple values. runStmtWithLocation :: GhcMonad m => String -> Int -> String -> SingleStep -> m RunResult runStmtWithLocation source linenumber expr step = do hsc_env <- getSession breakMVar <- liftIO $ newEmptyMVar -- wait on this when we hit a breakpoint statusMVar <- liftIO $ newEmptyMVar -- wait on this when a computation is running -- Turn off -fwarn-unused-bindings when running a statement, to hide -- warnings about the implicit bindings we introduce. let dflags' = wopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds hsc_env' = hsc_env{ hsc_dflags = dflags' } r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber case r of Nothing -> return (RunOk []) -- empty statement / comment Just (tyThings, hval) -> do status <- withVirtualCWD $ withBreakAction (isStep step) dflags' breakMVar statusMVar $ do let thing_to_run = unsafeCoerce# hval :: IO [HValue] liftIO $ sandboxIO dflags' statusMVar thing_to_run let ic = hsc_IC hsc_env bindings = (ic_tythings ic, ic_rn_gbl_env ic) case step of RunAndLogSteps -> traceRunStatus expr bindings tyThings breakMVar statusMVar status emptyHistory _other -> handleRunStatus expr bindings tyThings breakMVar statusMVar status emptyHistory runDecls :: GhcMonad m => String -> m [Name] runDecls = runDeclsWithLocation "" 1 runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name] runDeclsWithLocation source linenumber expr = do hsc_env <- getSession -- Turn off -fwarn-unused-bindings when running a statement, to hide -- warnings about the implicit bindings we introduce. let dflags' = wopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds hsc_env' = hsc_env{ hsc_dflags = dflags' } (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env' expr source linenumber setSession $ hsc_env { hsc_IC = ic } hsc_env <- getSession hsc_env' <- liftIO $ rttiEnvironment hsc_env modifySession (\_ -> hsc_env') return (map getName tyThings) 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 parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName) parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr emptyHistory :: BoundedList History emptyHistory = nilBL 50 -- keep a log of length 50 handleRunStatus :: GhcMonad m => String-> ([TyThing],GlobalRdrEnv) -> [Id] -> MVar () -> MVar Status -> Status -> BoundedList History -> m RunResult handleRunStatus expr bindings final_ids breakMVar statusMVar status history = case status of -- did we hit a breakpoint or did we complete? (Break is_exception apStack info tid) -> do hsc_env <- getSession let mb_info | is_exception = Nothing | otherwise = Just info (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info let resume = Resume { resumeStmt = expr, resumeThreadId = tid , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar , resumeBindings = bindings, resumeFinalIds = final_ids , resumeApStack = apStack, resumeBreakInfo = mb_info , resumeSpan = span, resumeHistory = toListBL history , resumeHistoryIx = 0 } hsc_env2 = pushResume hsc_env1 resume -- modifySession (\_ -> hsc_env2) return (RunBreak tid names mb_info) (Complete either_hvals) -> case either_hvals of Left e -> return (RunException e) Right hvals -> do hsc_env <- getSession let final_ic = extendInteractiveContext (hsc_IC hsc_env) (map AnId final_ids) final_names = map getName final_ids liftIO $ Linker.extendLinkEnv (zip final_names hvals) hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic} modifySession (\_ -> hsc_env') return (RunOk final_names) traceRunStatus :: GhcMonad m => String -> ([TyThing], GlobalRdrEnv) -> [Id] -> MVar () -> MVar Status -> Status -> BoundedList History -> m RunResult traceRunStatus expr bindings final_ids breakMVar statusMVar status history = do hsc_env <- getSession case status of -- when tracing, if we hit a breakpoint that is not explicitly -- enabled, then we just log the event in the history and continue. (Break is_exception apStack info tid) | not is_exception -> do b <- liftIO $ isBreakEnabled hsc_env info if b then handle_normally else do let history' = mkHistory hsc_env apStack info `consBL` history -- probably better make history strict here, otherwise -- our BoundedList will be pointless. _ <- liftIO $ evaluate history' status <- withBreakAction True (hsc_dflags hsc_env) breakMVar statusMVar $ do liftIO $ withInterruptsSentTo tid $ do putMVar breakMVar () -- awaken the stopped thread takeMVar statusMVar -- and wait for the result traceRunStatus expr bindings final_ids breakMVar statusMVar status history' _other -> handle_normally where handle_normally = handleRunStatus expr bindings final_ids breakMVar statusMVar status history 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 (modBreaks_flags (getModBreaks hmi)) (breakInfo_number inf) case w of Just n -> return (n /= 0); _other -> return False _ -> return False foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt 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 foreign import ccall "&rts_breakpoint_io_action" breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ())) -- When running a computation, we redirect ^C exceptions to the running -- 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 mask 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 = mask $ \restore -> -- fork starts blocked let runIt = liftM Complete $ try (restore $ rethrow dflags thing) in if dopt Opt_GhciSandbox dflags then do tid <- forkIO $ do res <- runIt putMVar statusMVar res -- empty: can't block withInterruptsSentTo tid $ takeMVar statusMVar else -- GLUT on OS X needs to run on the main thread. If you -- try to use it from another thread then you just get a -- white rectangle rendered. For this, or anything else -- with such restrictions, you can turn the GHCi sandbox off -- and things will be run in the main thread. runIt -- 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. -- Idea: if we catch and re-throw it, then the re-throw will trigger -- a break. Great - but we don't want to re-throw all exceptions, because -- then we'll get a double break for ordinary sync exceptions (you'd have -- to :continue twice, which looks strange). So if the exception is -- not "Interrupted", we unset the exception flag before throwing. -- rethrow :: DynFlags -> IO a -> IO a 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 fromException se of -- If it is a "UserInterrupt" exception, we allow -- a possible break by way of -fbreak-on-exception Just UserInterrupt -> return () -- In any other case, we don't want to break _ -> poke exceptionFlag 0 Exception.throwIO se 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 :: (ExceptionMonad m, MonadIO m) => Bool -> DynFlags -> MVar () -> MVar Status -> m a -> m a withBreakAction step dflags breakMVar statusMVar act = gbracket (liftIO setBreakAction) (liftIO . resetBreakAction) (\_ -> act) where setBreakAction = do stablePtr <- newStablePtr onBreak poke breakPointIOAction stablePtr when (dopt Opt_BreakOnException dflags) $ poke exceptionFlag 1 when step $ setStepFlag return stablePtr -- Breaking on exceptions is not enabled by default, since it -- might be a bit surprising. The exception flag is turned off -- as soon as it is hit, or in resetBreakAction below. onBreak is_exception info apStack = do tid <- myThreadId putMVar statusMVar (Break is_exception apStack info tid) takeMVar breakMVar resetBreakAction stablePtr = do poke breakPointIOAction noBreakStablePtr poke exceptionFlag 0 resetStepFlag freeStablePtr stablePtr noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ()) noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction noBreakAction :: Bool -> BreakInfo -> HValue -> IO () noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint" noBreakAction True _ _ = return () -- exception: just continue resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult resume canLogSpan step = do hsc_env <- getSession let ic = hsc_IC hsc_env resume = ic_resume ic case resume of [] -> 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 -- InteractiveContext. let (resume_tmp_te,resume_rdr_env) = resumeBindings r ic' = ic { ic_tythings = resume_tmp_te, ic_rn_gbl_env = resume_rdr_env, ic_resume = rs } modifySession (\_ -> hsc_env{ hsc_IC = ic' }) -- remove any bindings created since the breakpoint from the -- linker's environment let new_names = map getName (filter (`notElem` resume_tmp_te) (ic_tythings ic)) liftIO $ Linker.deleteFromLinkEnv new_names when (isStep step) $ liftIO setStepFlag case r of Resume { resumeStmt = expr, resumeThreadId = tid , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar , resumeBindings = bindings, resumeFinalIds = final_ids , resumeApStack = apStack, resumeBreakInfo = info, resumeSpan = span , resumeHistory = hist } -> do withVirtualCWD $ do withBreakAction (isStep step) (hsc_dflags hsc_env) breakMVar statusMVar $ do status <- liftIO $ withInterruptsSentTo tid $ do putMVar breakMVar () -- this awakens the stopped thread... takeMVar statusMVar -- and wait for the result 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 -> traceRunStatus expr bindings final_ids breakMVar statusMVar status hist' _other -> handleRunStatus expr bindings final_ids breakMVar statusMVar status hist' back :: GhcMonad m => m ([Name], Int, SrcSpan) back = moveHist (+1) forward :: GhcMonad m => m ([Name], Int, SrcSpan) forward = moveHist (subtract 1) moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan) moveHist fn = do hsc_env <- getSession case ic_resume (hsc_IC hsc_env) of [] -> 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) $ ghcError (ProgramError "no more logged breakpoints") when (new_ix < 0) $ ghcError (ProgramError "already at the beginning of the history") let update_ic apStack mb_info = do (hsc_env1, names, span) <- 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) -- careful: we want apStack to be the AP_STACK itself, not a thunk -- around it, hence the cases are carefully constructed below to -- make this the case. ToDo: this is v. fragile, do something better. if new_ix == 0 then case r of Resume { resumeApStack = apStack, resumeBreakInfo = mb_info } -> update_ic apStack mb_info else case history !! (new_ix - 1) of History apStack info _ -> update_ic apStack (Just info) -- ----------------------------------------------------------------------------- -- After stopping at a breakpoint, add free variables to the environment result_fs :: FastString result_fs = fsLit "_result" bindLocalsAtBreakpoint :: HscEnv -> HValue -> Maybe BreakInfo -> IO (HscEnv, [Name], SrcSpan) -- Nothing case: we stopped when an exception was raised, not at a -- breakpoint. We have no location information or local variables to -- 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" exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span e_fs = fsLit "e" e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind exn_id = AnId $ Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar) ictxt0 = hsc_IC hsc_env ictxt1 = extendInteractiveContext ictxt0 [exn_id] span = mkGeneralSrcSpan (fsLit "") -- Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)] return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span) -- Just case: we stopped at a breakpoint, we have information about the location -- of the breakpoint and the free variables of the expression. bindLocalsAtBreakpoint hsc_env apStack (Just info) = do let mod_name = moduleName (breakInfo_module info) hmi = expectJust "bindLocalsAtBreakpoint" $ lookupUFM (hsc_HPT hsc_env) mod_name breaks = getModBreaks hmi index = breakInfo_number info vars = breakInfo_vars info result_ty = breakInfo_resty info occs = modBreaks_vars breaks ! index span = modBreaks_locs breaks ! index -- Filter out any unboxed ids; -- we can't bind these at the prompt pointers = filter (\(id,_) -> isPointer id) vars isPointer id | PtrRep <- idPrimRep id = True | otherwise = False (ids, offsets) = unzip pointers free_tvs = foldr (unionVarSet . tyVarsOfType . idType) (tyVarsOfType result_ty) ids -- It might be that getIdValFromApStack fails, because the AP_STACK -- 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) (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 $ text "Warning: _result has been evaluated, some bindings have been lost" us <- mkSplitUniqSupply 'I' let (us1, us2) = splitUniqSupply us tv_subst = newTyVars us1 free_tvs new_ids = zipWith3 (mkNewId tv_subst) occs filtered_ids (uniqsFromSupply us2) names = map idName new_ids -- make an Id for _result. We use the Unique of the FastString "_result"; -- we don't care about uniqueness here, because there will only be one -- _result in scope at any time. let result_name = mkInternalName (getUnique result_fs) (mkVarOccFS result_fs) span result_id = Id.mkVanillaGlobal result_name (substTy tv_subst result_ty) -- for each Id we're about to bind in the local envt: -- - tidy the type variables -- - globalise the Id (Ids are supposed to be Global, apparently). -- let result_ok = isPointer result_id && not (isUnboxedTupleType (idType result_id)) all_ids | result_ok = result_id : new_ids | otherwise = new_ids id_tys = map idType all_ids (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys final_ids = zipWith setIdType all_ids tidy_tys ictxt0 = hsc_IC hsc_env ictxt1 = extendInteractiveContext ictxt0 (map AnId final_ids) Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ] when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } return (hsc_env1, if result_ok then result_name:names else names, span) 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 -- whenever we stop at a breakpoint. The InteractveContext is properly -- saved/restored, but not the linker state. See #1743, test break026. mkNewId :: TvSubst -> OccName -> Id -> Unique -> Id mkNewId tv_subst occ id uniq = Id.mkVanillaGlobalWithInfo name ty (idInfo id) where loc = nameSrcSpan (idName id) name = mkInternalName uniq occ loc ty = substTy tv_subst (idType id) newTyVars :: UniqSupply -> TcTyVarSet -> TvSubst -- Similarly, clone the type variables mentioned in the types -- we have here, *and* make them all RuntimeUnk tyars newTyVars us tvs = mkTopTvSubst [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv))) | (tv, uniq) <- varSetElems tvs `zip` uniqsFromSupply us , let name = setNameUnique (tyVarName tv) uniq ] rttiEnvironment :: HscEnv -> IO HscEnv rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do let tmp_ids = [id | AnId id <- ic_tythings ic] incompletelyTypedIds = [id | id <- tmp_ids , not $ noSkolems id , (occNameFS.nameOccName.idName) id /= result_fs] hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds) return hsc_env' where noSkolems = isEmptyVarSet . tyVarsOfType . idType improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do let tmp_ids = [id | AnId id <- ic_tythings ic] Just id = find (\i -> idName i == name) tmp_ids if noSkolems id then return hsc_env else do mb_new_ty <- reconstructType hsc_env 10 id let old_ty = idType id case mb_new_ty of Nothing -> return hsc_env Just new_ty -> do case improveRTTIType hsc_env old_ty new_ty of Nothing -> return $ WARN(True, text (":print failed to calculate the " ++ "improvement for a type")) hsc_env Just subst -> do when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $ printForUser stderr alwaysQualify $ fsep [text "RTTI Improvement for", ppr id, equals, ppr subst] let ic' = extendInteractiveContext (substInteractiveContext ic subst) [] return hsc_env{hsc_IC=ic'} getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue) getIdValFromApStack apStack (I# stackDepth) = do case getApStackVal# apStack (stackDepth +# 1#) of -- The +1 is magic! I don't know where it comes -- from, but this makes things line up. --SDM (# ok, result #) -> case ok of 0# -> return Nothing -- AP_STACK not found _ -> return (Just (unsafeCoerce# result)) pushResume :: HscEnv -> Resume -> HscEnv pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 } where ictxt0 = hsc_IC hsc_env ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 } -- ----------------------------------------------------------------------------- -- Abandoning a resume context abandon :: GhcMonad m => m Bool abandon = do hsc_env <- getSession let ic = hsc_IC hsc_env resume = ic_resume ic case resume of [] -> return False r:rs -> do modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } } liftIO $ abandon_ r return True abandonAll :: GhcMonad m => m Bool abandonAll = do hsc_env <- getSession let ic = hsc_IC hsc_env resume = ic_resume ic case resume of [] -> return False rs -> do modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } } liftIO $ mapM_ abandon_ rs return True -- when abandoning a computation we have to -- (a) kill the thread with an async exception, so that the -- computation itself is stopped, and -- (b) fill in the MVar. This step is necessary because any -- thunks that were under evaluation will now be updated -- with the partial computation, which still ends in takeMVar, -- so any attempt to evaluate one of these thunks will block -- unless we fill in the MVar. -- See test break010. abandon_ :: Resume -> IO () abandon_ r = do killThread (resumeThreadId r) putMVar (resumeBreakMVar r) () -- ----------------------------------------------------------------------------- -- Bounded list, optimised for repeated cons data BoundedList a = BL {-# UNPACK #-} !Int -- length {-# UNPACK #-} !Int -- bound [a] -- left [a] -- right, list is (left ++ reverse right) 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 -- ----------------------------------------------------------------------------- -- | Set the interactive evaluation context. -- -- Setting the context doesn't throw away any bindings; the bindings -- we've built up in the InteractiveContext simply move to the new -- module. They always shadow anything in scope in the current context. setContext :: GhcMonad m => [InteractiveImport] -> m () setContext imports = do { hsc_env <- getSession ; all_env <- liftIO $ findGlobalRdrEnv hsc_env imports ; let old_ic = hsc_IC hsc_env final_rdr_env = ic_tythings old_ic `icPlusGblRdrEnv` all_env ; modifySession $ \_ -> hsc_env{ hsc_IC = old_ic { ic_imports = imports , ic_rn_gbl_env = final_rdr_env }}} findGlobalRdrEnv :: HscEnv -> [InteractiveImport] -> IO GlobalRdrEnv -- Compute the GlobalRdrEnv for the interactive context findGlobalRdrEnv hsc_env imports = do { idecls_env <- hscRnImportDecls hsc_env idecls -- This call also loads any orphan modules ; imods_env <- mapM (mkTopLevEnv (hsc_HPT hsc_env)) imods ; return (foldr plusGlobalRdrEnv idecls_env imods_env) } where idecls :: [LImportDecl RdrName] idecls = [noLoc d | IIDecl d <- imports] imods :: [Module] imods = [m | IIModule m <- imports] 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 } mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv mkTopLevEnv hpt modl = case lookupUFM hpt (moduleName modl) of Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++ showSDoc (ppr modl))) Just details -> case mi_globals (hm_iface details) of Nothing -> ghcError (ProgramError ("mkTopLevEnv: not interpreted " ++ showSDoc (ppr modl))) Just env -> return env -- | Get the interactive evaluation context, consisting of a pair of the -- set of modules from which we take the full top-level scope, and the set -- of modules from which we take just the exports respectively. getContext :: GhcMonad m => m [InteractiveImport] getContext = withSession $ \HscEnv{ hsc_IC=ic } -> return (ic_imports ic) -- | Returns @True@ if the specified module is interpreted, and hence has -- its full top-level scope available. moduleIsInterpreted :: GhcMonad m => Module -> m Bool moduleIsInterpreted modl = withSession $ \h -> if modulePackageId modl /= thisPackage (hsc_dflags h) then return False else case lookupUFM (hsc_HPT h) (moduleName modl) of Just details -> return (isJust (mi_globals (hm_iface details))) _not_a_home_module -> return False -- | Looks up an identifier in the current interactive context (for :info) -- Filter the instances by the ones whose tycons (or clases resp) -- are in scope (qualified or otherwise). Otherwise we list a whole lot too many! -- The exact choice of which ones to show, and which to hide, is a judgement call. -- (see Trac #1581) getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance])) getInfo name = withSession $ \hsc_env -> do mb_stuff <- liftIO $ hscTcRnGetInfo 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 $ orphNamesOfType $ idType $ instanceDFunId ispec where -- A name is ok if it's in the rdr_env, -- whether qualified or not ok n | n == name = True -- The one we looked for in the first place! | isBuiltInSyntax n = True | isExternalName n = any ((== n) . gre_name) (lookupGRE_Name rdr_env n) | otherwise = True -- | Returns all names in scope in the current interactive context getNamesInScope :: GhcMonad m => m [Name] getNamesInScope = withSession $ \hsc_env -> do return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) getRdrNamesInScope :: GhcMonad m => m [RdrName] getRdrNamesInScope = withSession $ \hsc_env -> do let ic = hsc_IC hsc_env gbl_rdrenv = ic_rn_gbl_env ic gbl_names = concatMap greToRdrNames $ globalRdrEnvElts gbl_rdrenv return gbl_names -- ToDo: move to RdrName greToRdrNames :: GlobalRdrElt -> [RdrName] greToRdrNames GRE{ gre_name = name, gre_prov = prov } = case prov of LocalDef -> [unqual] Imported specs -> concat (map do_spec (map is_decl specs)) where occ = nameOccName name unqual = Unqual occ do_spec decl_spec | is_qual decl_spec = [qual] | otherwise = [unqual,qual] where qual = Qual (is_as decl_spec) occ -- | Parses a string as an identifier, and returns the list of 'Name's that -- the identifier can refer to in the current interactive context. parseName :: GhcMonad m => String -> m [Name] parseName str = withSession $ \hsc_env -> do (L _ rdr_name) <- liftIO $ hscParseIdentifier hsc_env str liftIO $ hscTcRnLookupRdrName hsc_env rdr_name -- ----------------------------------------------------------------------------- -- Getting the type of an expression -- | Get the type of an expression exprType :: GhcMonad m => String -> m Type exprType expr = withSession $ \hsc_env -> do ty <- liftIO $ hscTcExpr hsc_env expr return $ tidyType emptyTidyEnv ty -- ----------------------------------------------------------------------------- -- Getting the kind of a type -- | Get the kind of a type typeKind :: GhcMonad m => Bool -> String -> m (Type, Kind) typeKind normalise str = withSession $ \hsc_env -> do liftIO $ hscKcType hsc_env normalise str ----------------------------------------------------------------------------- -- cmCompileExpr: compile an expression and deliver an HValue compileExpr :: GhcMonad m => String -> m HValue compileExpr expr = withSession $ \hsc_env -> do Just (ids, hval) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr) -- Run it! hvals <- liftIO (unsafeCoerce# hval :: IO [HValue]) case (ids,hvals) of ([_],[hv]) -> return hv _ -> panic "compileExpr" -- ----------------------------------------------------------------------------- -- Compile an expression into a dynamic dynCompileExpr :: GhcMonad m => String -> m Dynamic dynCompileExpr expr = do iis <- getContext let importDecl = ImportDecl { ideclName = noLoc (mkModuleName "Data.Dynamic"), ideclPkgQual = Nothing, ideclSource = False, ideclSafe = False, ideclQualified = True, ideclImplicit = False, ideclAs = Nothing, ideclHiding = Nothing } setContext (IIDecl importDecl : iis) let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")" Just (ids, hvals) <- withSession $ \hsc_env -> liftIO $ hscStmt hsc_env stmt setContext iis vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic]) case (ids,vals) of (_:[], v:[]) -> return v _ -> panic "dynCompileExpr" ----------------------------------------------------------------------------- -- show a module and it's source/object filenames showModule :: GhcMonad m => ModSummary -> m String showModule mod_summary = withSession $ \hsc_env -> do interpreted <- isModuleInterpreted mod_summary return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary) isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool isModuleInterpreted mod_summary = withSession $ \hsc_env -> case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of Nothing -> panic "missing linkable" Just mod_info -> return (not obj_linkable) where obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info)) ---------------------------------------------------------------------------- -- RTTI primitives obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term obtainTermFromVal hsc_env bound force ty x = cvObtainTerm hsc_env bound force ty (unsafeCoerce# x) obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term obtainTermFromId hsc_env bound force id = do hv <- Linker.getHValue hsc_env (varName id) cvObtainTerm hsc_env bound force (idType id) hv -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type) reconstructType hsc_env bound id = do hv <- Linker.getHValue hsc_env (varName id) cvReconstructType hsc_env bound (idType id) hv mkRuntimeUnkTyVar :: Name -> Kind -> TyVar mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk #endif /* GHCI */