/compiler/main/InteractiveEval.hs
Haskell | 1042 lines | 743 code | 132 blank | 167 comment | 18 complexity | 60d5ad244884dcd7ba2954376bb3c6cc MD5 | raw file
- -- -----------------------------------------------------------------------------
- --
- -- (c) The University of Glasgow, 2005-2007
- --
- -- Running statements interactively
- --
- -- -----------------------------------------------------------------------------
- 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 TyCon
- 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.Either
- import Data.List (find)
- import Control.Monad
- import Foreign.Safe
- import Foreign.C
- import GHC.Exts
- import Data.Array
- import Exception
- import Control.Concurrent
- 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
- -- | Update fixity environment in the current interactive context.
- updateFixityEnv :: GhcMonad m => FixityEnv -> m ()
- updateFixityEnv fix_env = do
- hsc_env <- getSession
- let ic = hsc_IC hsc_env
- setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } }
- -- | Run a statement in the current interactive context. Statement
- -- may bind multple values.
- runStmt :: GhcMonad m => String -> SingleStep -> m RunResult
- runStmt = runStmtWithLocation "<interactive>" 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 ic = hsc_IC hsc_env -- use the interactive dflags
- idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedBinds
- hsc_env' = hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } }
- -- compile to value (IO [HValue]), don't run
- r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber
- case r of
- -- empty statement / comment
- Nothing -> return (RunOk [])
- Just (tyThings, hval, fix_env) -> do
- updateFixityEnv fix_env
- status <-
- withVirtualCWD $
- withBreakAction (isStep step) idflags' breakMVar statusMVar $ do
- liftIO $ sandboxIO idflags' statusMVar hval
- 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 "<interactive>" 1
- runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name]
- runDeclsWithLocation source linenumber expr =
- do
- hsc_env <- getSession
- (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 (hsc_dflags hsc_env)
- (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 (pushInterruptTargetThread thread)
- (\_ -> popInterruptTargetThread)
- (\_ -> 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 "<exception thrown>")
- --
- 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 | UnaryRep ty <- repType (idType id)
- , PtrRep <- typePrimRep ty = 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
- 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
- let dflags = hsc_dflags hsc_env
- when (dopt Opt_D_dump_rtti dflags) $
- printInfoForUser dflags 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.
- -- (c) wait for the thread to terminate by taking its status MVar. This
- -- step is necessary to prevent race conditions with
- -- -fbreak-on-exception (see #5975).
- -- See test break010.
- abandon_ :: Resume -> IO ()
- abandon_ r = do
- killThread (resumeThreadId r)
- putMVar (resumeBreakMVar r) ()
- _ <- takeMVar (resumeStatMVar r)
- return ()
- -- -----------------------------------------------------------------------------
- -- 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
- ; let dflags = hsc_dflags hsc_env
- ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports
- ; case all_env_err of
- Left (mod, err) -> ghcError (formatError dflags mod err)
- Right all_env -> do {
- ; 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 }}}}
- where
- formatError dflags mod err = ProgramError . showSDoc dflags $
- text "Cannot add module" <+> ppr mod <+>
- text "to context:" <+> text err
- findGlobalRdrEnv :: HscEnv -> [InteractiveImport]
- -> IO (Either (ModuleName, String) 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
- ; return $ case partitionEithers (map mkEnv imods) of
- ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env)
- (err : _, _) -> Left err }
- where
- idecls :: [LImportDecl RdrName]
- idecls = [noLoc d | IIDecl d <- imports]
- imods :: [ModuleName]
- imods = [m | IIModule m <- imports]
- mkEnv mod = case mkTopLevEnv (hsc_HPT hsc_env) mod of
- Left err -> Left (mod, err)
- Right env -> Right env
- 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 -> ModuleName -> Either String GlobalRdrEnv
- mkTopLevEnv hpt modl
- = case lookupUFM hpt modl of
- Nothing -> Left "not a home module"
- Just details ->
- case mi_globals (hm_iface details) of
- Nothing -> Left "not interpreted"
- Just env -> Right 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,[ClsInst]))
- 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
- -----------------------------------------------------------------------------
- -- Compile an expression, run it and deliver the resulting HValue
- compileExpr :: GhcMonad m => String -> m HValue
- compileExpr expr = withSession $ \hsc_env -> do
- Just (ids, hval, fix_env) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr)
- updateFixityEnv fix_env
- hvals <- liftIO hval
- case (ids,hvals) of
- ([_],[hv]) -> return hv
- _ -> panic "compileExpr"
- -- -----------------------------------------------------------------------------
- -- Compile an expression, run it and return the result as 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, fix_env) <- withSession $ \hsc_env ->
- liftIO $ hscStmt hsc_env stmt
- setContext iis
- updateFixityEnv fix_env
- 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
- let dflags = hsc_dflags hsc_env
- return (showModMsg dflags (hscTarget dflags) 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 */