--- | 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 :: Session
- -> [Module] -- entire top level scope of these modules
- -> [Module] -- exports only of these modules
- -> IO ()
-setContext sess@(Session ref) toplev_mods export_mods = do
- hsc_env <- readIORef ref
- let old_ic = hsc_IC hsc_env
- hpt = hsc_HPT hsc_env
- --
- export_env <- mkExportEnv hsc_env export_mods
- toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
- let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
- writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
- ic_exports = export_mods,
- ic_rn_gbl_env = all_env }}
-
--- 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_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}]
- where
- 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 -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
- showSDoc (ppr modl)))
- Just details ->
- case mi_globals (hm_iface details) of
- Nothing ->
- throwDyn (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 :: Session -> IO ([Module],[Module])
-getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
- return (ic_toplev_scope ic, ic_exports ic))
-
--- | Returns 'True' if the specified module is interpreted, and hence has
--- its full top-level scope available.
-moduleIsInterpreted :: Session -> Module -> IO Bool
-moduleIsInterpreted s modl = withSession s $ \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)
-getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
-getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name
-
--- | Returns all names in scope in the current interactive context
-getNamesInScope :: Session -> IO [Name]
-getNamesInScope s = withSession s $ \hsc_env -> do
- return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
-
-getRdrNamesInScope :: Session -> IO [RdrName]
-getRdrNamesInScope s = withSession s $ \hsc_env -> do
- let env = ic_rn_gbl_env (hsc_IC hsc_env)
- return (concat (map greToRdrNames (globalRdrEnvElts env)))
-
--- 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 :: Session -> String -> IO [Name]
-parseName s str = withSession s $ \hsc_env -> do
- maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
- case maybe_rdr_name of
- Nothing -> return []
- Just (L _ rdr_name) -> do
- mb_names <- tcRnLookupRdrName hsc_env rdr_name
- case mb_names of
- Nothing -> return []
- Just ns -> return ns
- -- ToDo: should return error messages
-
--- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
--- entity known to GHC, including 'Name's defined using 'runStmt'.
-lookupName :: Session -> Name -> IO (Maybe TyThing)
-lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
-
--- -----------------------------------------------------------------------------
--- Getting the type of an expression
-
--- | Get the type of an expression
-exprType :: Session -> String -> IO (Maybe Type)
-exprType s expr = withSession s $ \hsc_env -> do
- maybe_stuff <- hscTcExpr hsc_env expr
- case maybe_stuff of
- Nothing -> return Nothing
- Just ty -> return (Just tidy_ty)
- where
- tidy_ty = tidyType emptyTidyEnv ty
-
--- -----------------------------------------------------------------------------
--- Getting the kind of a type
-
--- | Get the kind of a type
-typeKind :: Session -> String -> IO (Maybe Kind)
-typeKind s str = withSession s $ \hsc_env -> do
- maybe_stuff <- hscKcType hsc_env str
- case maybe_stuff of
- Nothing -> return Nothing
- Just kind -> return (Just kind)
-
------------------------------------------------------------------------------
--- cmCompileExpr: compile an expression and deliver an HValue
-
-compileExpr :: Session -> String -> IO (Maybe HValue)
-compileExpr s expr = withSession s $ \hsc_env -> do
- maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
- case maybe_stuff of
- Nothing -> return Nothing
- Just (new_ic, names, hval) -> do
- -- Run it!
- hvals <- (unsafeCoerce# hval) :: IO [HValue]
-
- case (names,hvals) of
- ([n],[hv]) -> return (Just hv)
- _ -> panic "compileExpr"
-
--- -----------------------------------------------------------------------------
--- Compile an expression into a dynamic
-
-dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
-dynCompileExpr ses expr = do
- (full,exports) <- getContext ses
- setContext ses full $
- (mkModule
- (stringToPackageId "base") (mkModuleName "Data.Dynamic")
- ):exports
- let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
- res <- withSession ses (flip hscStmt stmt)
- setContext ses full exports
- case res of
- Nothing -> return Nothing
- Just (_, names, hvals) -> do
- vals <- (unsafeCoerce# hvals :: IO [Dynamic])
- case (names,vals) of
- (_:[], v:[]) -> return (Just v)
- _ -> panic "dynCompileExpr"
-
--- -----------------------------------------------------------------------------
--- running a statement interactively
-
-data RunResult
- = RunOk [Name] -- ^ names bound by this evaluation
- | RunFailed -- ^ statement failed compilation
- | RunException Exception -- ^ statement raised an exception
- | RunBreak ThreadId [Name] BreakInfo ResumeHandle
-
-data Status
- = Break HValue BreakInfo ThreadId (MVar ()) (MVar Status) [Name]
- -- ^ the computation hit a breakpoint
- | Complete (Either Exception [HValue])
- -- ^ the computation completed with either an exception or a value
-
--- | This is a token given back to the client when runStmt stops at a
--- breakpoint. It allows the original computation to be resumed, restoring
--- the old interactive context.
-data ResumeHandle
- = ResumeHandle
- (MVar ()) -- breakMVar
- (MVar Status) -- statusMVar
- [Name] -- [Name] to bind on completion
- InteractiveContext -- IC to restore on resumption
- [Name] -- [Name] to remove from the link env
-
--- | Run a statement in the current interactive context. Statement
--- may bind multple values.
-runStmt :: Session -> String -> IO RunResult
-runStmt (Session ref) expr
- = do
- hsc_env <- readIORef ref
-
- breakMVar <- newEmptyMVar -- wait on this when we hit a breakpoint
- statusMVar <- 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' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
- hsc_env' = hsc_env{ hsc_dflags = dflags' }
-
- maybe_stuff <- hscStmt hsc_env' expr
-
- case maybe_stuff of
- Nothing -> return RunFailed
- Just (new_hsc_env, names, hval) -> do
- writeIORef ref new_hsc_env
-
- -- set the onBreakAction to be performed when we hit a
- -- breakpoint this is visible in the Byte Code
- -- Interpreter, thus it is a global variable,
- -- implemented with stable pointers
- stablePtr <- setBreakAction breakMVar statusMVar names
-
- let thing_to_run = unsafeCoerce# hval :: IO [HValue]
- status <- sandboxIO statusMVar thing_to_run
- freeStablePtr stablePtr -- be careful not to leak stable pointers!
- handleRunStatus ref (hsc_IC new_hsc_env) names status
-
-handleRunStatus ref ic names status =
- case status of
- -- did we hit a breakpoint or did we complete?
- (Break apStack info tid breakMVar statusMVar final_names) -> do
- hsc_env <- readIORef ref
- (new_hsc_env, names) <- extendEnvironment hsc_env apStack
- (breakInfo_vars info)
- writeIORef ref new_hsc_env
- let res = ResumeHandle breakMVar statusMVar final_names
- ic names
- return (RunBreak tid names info res)
- (Complete either_hvals) ->
- case either_hvals of
- Left e -> return (RunException e)
- Right hvals -> do
- Linker.extendLinkEnv (zip names hvals)
- return (RunOk names)
-
--- this points to the IO action that is executed when a breakpoint is hit
-foreign import ccall "&breakPointIOAction"
- breakPointIOAction :: Ptr (StablePtr (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".
-sandboxIO :: MVar Status -> IO [HValue] -> IO Status
-sandboxIO statusMVar thing = do
- ts <- takeMVar interruptTargetThread
- child <- forkIO (do res <- Exception.try thing; putMVar statusMVar (Complete res))
- putMVar interruptTargetThread (child:ts)
- takeMVar statusMVar `finally` modifyMVar_ interruptTargetThread (return.tail)
-
-setBreakAction breakMVar statusMVar final_names = do
- stablePtr <- newStablePtr onBreak
- poke breakPointIOAction stablePtr
- return stablePtr
- where onBreak ids apStack = do
- tid <- myThreadId
- putMVar statusMVar (Break apStack ids tid breakMVar statusMVar
- final_names)
- takeMVar breakMVar
-
-resume :: Session -> ResumeHandle -> IO RunResult
-resume (Session ref) res@(ResumeHandle breakMVar statusMVar
- final_names ic names)
- = do
- -- restore the original interactive context. This is not entirely
- -- satisfactory: any new bindings made since the breakpoint stopped
- -- will be dropped from the interactive context, but not from the
- -- linker's environment.
- hsc_env <- readIORef ref
- writeIORef ref hsc_env{ hsc_IC = ic }
- Linker.deleteFromLinkEnv names
-
- stablePtr <- setBreakAction breakMVar statusMVar final_names
- putMVar breakMVar () -- this awakens the stopped thread...
- status <- takeMVar statusMVar -- and wait for the result
- freeStablePtr stablePtr -- be careful not to leak stable pointers!
- handleRunStatus ref ic names status
-
-{-
--- This version of sandboxIO runs the expression in a completely new
--- RTS main thread. It is disabled for now because ^C exceptions
--- won't be delivered to the new thread, instead they'll be delivered
--- to the (blocked) GHCi main thread.
-
--- SLPJ: when re-enabling this, reflect a wrong-stat error as an exception
-
-sandboxIO :: IO a -> IO (Either Int (Either Exception a))
-sandboxIO thing = do
- st_thing <- newStablePtr (Exception.try thing)
- alloca $ \ p_st_result -> do
- stat <- rts_evalStableIO st_thing p_st_result
- freeStablePtr st_thing
- if stat == 1
- then do st_result <- peek p_st_result
- result <- deRefStablePtr st_result
- freeStablePtr st_result
- return (Right result)
- else do
- return (Left (fromIntegral stat))
-
-foreign import "rts_evalStableIO" {- safe -}
- rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
- -- more informative than the C type!
-
-XXX the type of rts_evalStableIO no longer matches the above
-
--}
-
--- -----------------------------------------------------------------------------
--- After stopping at a breakpoint, add free variables to the environment
-
--- Todo: turn this into a primop, and provide special version(s) for unboxed things
-foreign import ccall "rts_getApStackVal" getApStackVal :: StablePtr a -> Int -> IO (StablePtr b)
-
-getIdValFromApStack :: a -> (Id, Int) -> IO (Id, HValue)
-getIdValFromApStack apStack (identifier, stackDepth) = do
- -- ToDo: check the type of the identifer and decide whether it is unboxed or not
- apSptr <- newStablePtr apStack
- resultSptr <- getApStackVal apSptr (stackDepth - 1)
- result <- deRefStablePtr resultSptr
- freeStablePtr apSptr
- freeStablePtr resultSptr
- return (identifier, unsafeCoerce# result)
-
-extendEnvironment :: HscEnv -> a -> [(Id, Int)] -> IO (HscEnv, [Name])
-extendEnvironment hsc_env apStack idsOffsets = do
- idsVals <- mapM (getIdValFromApStack apStack) idsOffsets
- let (ids, hValues) = unzip idsVals
- let names = map idName ids
- let global_ids = map globaliseAndTidy ids
- typed_ids <- mapM instantiateIdType global_ids
- let ictxt = hsc_IC hsc_env
- rn_env = ic_rn_local_env ictxt
- type_env = ic_type_env ictxt
- bound_names = map idName typed_ids
- new_rn_env = extendLocalRdrEnv rn_env bound_names
- -- Remove any shadowed bindings from the type_env;
- -- they are inaccessible but might, I suppose, cause
- -- a space leak if we leave them there
- shadowed = [ n | name <- bound_names,
- let rdr_name = mkRdrUnqual (nameOccName name),
- Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
- filtered_type_env = delListFromNameEnv type_env shadowed
- new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids)
- new_ic = ictxt { ic_rn_local_env = new_rn_env,
- ic_type_env = new_type_env }
- Linker.extendLinkEnv (zip names hValues) -- ToDo: we must remember to restore the old env after we finish a breakpoint
- return (hsc_env{hsc_IC = new_ic}, names)
- where
- globaliseAndTidy :: Id -> Id
- globaliseAndTidy id
- = let tidied_type = tidyTopType$ idType id
- in setIdType (globaliseId VanillaGlobal id) tidied_type
-
- -- | Instantiate the tyVars with GHC.Base.Unknown
- instantiateIdType :: Id -> IO Id
- instantiateIdType id = do
- instantiatedType <- instantiateTyVarsToUnknown hsc_env (idType id)
- return$ setIdType id instantiatedType
-
------------------------------------------------------------------------------
--- show a module and it's source/object filenames
-
-showModule :: Session -> ModSummary -> IO String
-showModule s mod_summary = withSession s $ \hsc_env ->
- isModuleInterpreted s mod_summary >>= \interpreted ->
- return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
-
-isModuleInterpreted :: Session -> ModSummary -> IO Bool
-isModuleInterpreted s mod_summary = withSession s $ \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))