data BreakInfo
= BreakInfo
{ breakInfo_module :: Module
- , breakInfo_number :: Int
+ , breakInfo_number :: {-# UNPACK #-} !Int
, breakInfo_vars :: [(Id,Int)]
, breakInfo_resty :: Type
}
hsc_env <- readIORef ref
inScope <- GHC.getBindings cms
let ictxt = hsc_IC hsc_env
- type_env = ic_type_env ictxt
- ids = typeEnvIds type_env
+ ids = ic_tmp_ids ictxt
ids' = map (\id -> id `setIdType` substTy subst (idType id)) ids
- type_env'= extendTypeEnvWithIds type_env ids'
subst_dom= varEnvKeys$ getTvSubstEnv subst
subst_ran= varEnvElts$ getTvSubstEnv subst
new_tvs = [ tv | t <- subst_ran, let Just tv = getTyVar_maybe t]
ic_tyvars'= (`delVarSetListByKey` subst_dom)
. (`extendVarSetList` new_tvs)
$ ic_tyvars ictxt
- ictxt' = ictxt { ic_type_env = type_env'
+ ictxt' = ictxt { ic_tmp_ids = ids'
, ic_tyvars = ic_tyvars' }
writeIORef ref (hsc_env {hsc_IC = ictxt'})
hsc_env <- readIORef ref
inScope <- GHC.getBindings cms
let ictxt = hsc_IC hsc_env
- type_env = ic_type_env ictxt
+ type_env = ic_tmp_ids ictxt
prefix = "_t"
alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
availNames = map ((prefix++) . show) [1..] \\ alreadyUsedNames
let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
| (name,ty) <- zip names tys']
new_tyvars = tyVarsOfTypes tys'
- new_type_env = extendTypeEnvWithIds type_env ids
old_tyvars = ic_tyvars ictxt
- new_ic = ictxt { ic_type_env = new_type_env,
+ new_ic = ictxt { ic_tmp_ids = ids ++ ic_tmp_ids ictxt,
ic_tyvars = old_tyvars `unionVarSet` new_tyvars }
extendLinkEnv (zip names hvals)
writeIORef ref (hsc_env {hsc_IC = new_ic })
bindToFreshName hsc_env ty userName = do
name <- newGrimName cms userName
let ictxt = hsc_IC hsc_env
- type_env = ic_type_env ictxt
+ tmp_ids = ic_tmp_ids ictxt
id = mkGlobalId VanillaGlobal name ty vanillaIdInfo
- new_type_env = extendTypeEnv type_env (AnId id)
- new_ic = ictxt { ic_type_env = new_type_env }
+ new_ic = ictxt { ic_tmp_ids = id : tmp_ids }
return (hsc_env {hsc_IC = new_ic }, name)
-- Create new uniques and give them sequentially numbered names
session :: GHC.Session,
options :: [GHCiOption],
prelude :: GHC.Module,
- resume :: [EvalInProgress],
breaks :: !ActiveBreakPoints,
tickarrays :: ModuleEnv TickArray
-- tickarrays caches the TickArray for loaded modules,
, breakLocations :: ![(Int, BreakLocation)] -- break location uniquely numbered
}
--- The context of an evaluation in progress that stopped at a breakpoint
-data EvalInProgress
- = EvalInProgress
- { evalStmt :: String,
- evalSpan :: SrcSpan,
- evalThreadId :: ThreadId,
- evalResumeHandle :: GHC.ResumeHandle }
-
instance Outputable ActiveBreakPoints where
ppr activeBrks = prettyLocations $ breakLocations activeBrks
io :: IO a -> GHCi a
io m = GHCi { unGHCi = \s -> m >>= return }
-popResume :: GHCi (Maybe EvalInProgress)
-popResume = do
- st <- getGHCiState
- case (resume st) of
- [] -> return Nothing
- (x:xs) -> do setGHCiState $ st { resume = xs } ; return (Just x)
-
-pushResume :: EvalInProgress -> GHCi ()
-pushResume eval = do
- st <- getGHCiState
- let oldResume = resume st
- setGHCiState $ st { resume = eval : oldResume }
-
-discardResumeContext :: GHCi ()
-discardResumeContext = do
- st <- getGHCiState
- setGHCiState st { resume = [] }
-
printForUser :: SDoc -> GHCi ()
printForUser doc = do
session <- getSession
import qualified GHC
import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
Type, Module, ModuleName, TyThing(..), Phase,
- BreakIndex, Name, SrcSpan )
+ BreakIndex, Name, SrcSpan, Resume )
import DynFlags
import Packages
import PackageConfig
import Digraph
import BasicTypes hiding (isTopLevel)
import Panic hiding (showException)
-import FastString ( unpackFS )
import Config
import StaticFlags
import Linker
session = session,
options = [],
prelude = prel_mod,
- resume = [],
breaks = emptyActiveBreakPoints,
tickarrays = emptyModuleEnv
}
session <- getSession
(mod,imports) <- io (GHC.getContext session)
st <- getGHCiState
- when show_prompt (io (putStr (mkPrompt mod imports (resume st) (prompt st))))
+ resumes <- io $ GHC.getResumeContext session
+ when show_prompt (io (putStr (mkPrompt mod imports resumes (prompt st))))
l <- io (IO.try (hGetLine hdl))
case l of
Left e | isEOFError e -> return ()
perc_s
| eval:rest <- resumes
= (if not (null rest) then text "... " else empty)
- <> brackets (ppr (evalSpan eval)) <+> modules_prompt
+ <> brackets (ppr (GHC.resumeSpan eval)) <+> modules_prompt
| otherwise
= modules_prompt
io yield
saveSession -- for use by completion
st <- getGHCiState
- l <- io (readline (mkPrompt mod imports (resume st) (prompt st))
+ resumes <- io $ GHC.getResumeContext session
+ l <- io (readline (mkPrompt mod imports resumes (prompt st))
`finally` setNonBlockingFD 0)
-- readline sometimes puts stdin into blocking mode,
-- so we need to put it back for the IO library
where
doCommand (':' : command) = specialCommand command
doCommand stmt
- = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
+ = do timeIt $ runStmt stmt
return False
-- This version is for the GHC command-line option -e. The only difference
doCommand (':' : command) = specialCommand command
doCommand stmt
- = do nms <- runStmt stmt
- case nms of
- Nothing -> io (exitWith (ExitFailure 1))
+ = do r <- runStmt stmt
+ case r of
+ False -> io (exitWith (ExitFailure 1))
-- failure to run the command causes exit(1) for ghc -e.
- _ -> do finishEvalExpr nms
- return True
+ _ -> return True
-runStmt :: String -> GHCi (Maybe (Bool,[Name]))
+runStmt :: String -> GHCi Bool
runStmt stmt
- | null (filter (not.isSpace) stmt) = return (Just (False,[]))
+ | null (filter (not.isSpace) stmt) = return False
| otherwise
= do st <- getGHCiState
session <- getSession
result <- io $ withProgName (progname st) $ withArgs (args st) $
GHC.runStmt session stmt
- switchOnRunResult stmt result
+ afterRunStmt result
+ return False
-switchOnRunResult :: String -> GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
-switchOnRunResult stmt GHC.RunFailed = return Nothing
-switchOnRunResult stmt (GHC.RunException e) = throw e
-switchOnRunResult stmt (GHC.RunOk names) = return $ Just (False,names)
-switchOnRunResult stmt (GHC.RunBreak threadId names info resume) = do
+
+afterRunStmt :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
+afterRunStmt run_result = do
+ mb_result <- switchOnRunResult run_result
+
+ -- possibly print the type and revert CAFs after evaluating an expression
+ show_types <- isOptionSet ShowType
+ session <- getSession
+ case mb_result of
+ Nothing -> return ()
+ Just (is_break,names) ->
+ when (is_break || show_types) $
+ mapM_ (showTypeOfName session) names
+
+ flushInterpBuffers
+ io installSignalHandlers
+ b <- isOptionSet RevertCAFs
+ io (when b revertCAFs)
+
+ return mb_result
+
+
+switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
+switchOnRunResult GHC.RunFailed = return Nothing
+switchOnRunResult (GHC.RunException e) = throw e
+switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
+switchOnRunResult (GHC.RunBreak threadId names info) = do
session <- getSession
Just mod_info <- io $ GHC.getModuleInfo session (GHC.breakInfo_module info)
let modBreaks = GHC.modInfoModBreaks mod_info
let location = ticks ! GHC.breakInfo_number info
printForUser $ ptext SLIT("Stopped at") <+> ppr location
- pushResume EvalInProgress{ evalStmt = stmt,
- evalSpan = location,
- evalThreadId = threadId,
- evalResumeHandle = resume }
-
-- run the command set with ":set stop <cmd>"
st <- getGHCiState
runCommand (stop st)
return (Just (True,names))
--- possibly print the type and revert CAFs after evaluating an expression
-finishEvalExpr mb_names
- = do show_types <- isOptionSet ShowType
- session <- getSession
- case mb_names of
- Nothing -> return ()
- Just (is_break,names) ->
- when (is_break || show_types) $
- mapM_ (showTypeOfName session) names
-
- flushInterpBuffers
- io installSignalHandlers
- b <- isOptionSet RevertCAFs
- io (when b revertCAFs)
showTypeOfName :: Session -> Name -> GHCi ()
showTypeOfName session n
afterLoad ok session = do
io (revertCAFs) -- always revert CAFs on load.
- discardResumeContext
discardTickArrays
discardActiveBreakPoints
graph <- io (GHC.getModuleGraph session)
showContext :: GHCi ()
showContext = do
- st <- getGHCiState
- printForUser $ vcat (map pp_resume (reverse (resume st)))
+ session <- getSession
+ resumes <- io $ GHC.getResumeContext session
+ printForUser $ vcat (map pp_resume (reverse resumes))
where
- pp_resume eval =
- ptext SLIT("--> ") <> text (evalStmt eval)
- $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (evalSpan eval))
+ pp_resume resume =
+ ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
+ $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
+
-- -----------------------------------------------------------------------------
-- Completion
session <- getSession
io $ pprintClosureCommand session bind force str
-foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
-
stepCmd :: String -> GHCi Bool
-stepCmd [] = doContinue setStepFlag
+stepCmd [] = doContinue True
stepCmd expression = do
- io $ setStepFlag
runCommand expression
continueCmd :: String -> GHCi Bool
-continueCmd [] = doContinue $ return ()
+continueCmd [] = doContinue False
continueCmd other = do
io $ putStrLn "The continue command accepts no arguments."
return False
-doContinue :: IO () -> GHCi Bool
-doContinue actionBeforeCont = do
- resumeAction <- popResume
- case resumeAction of
- Nothing -> do
- io $ putStrLn "There is no computation running."
- return False
- Just eval -> do
- io $ actionBeforeCont
- session <- getSession
- runResult <- io $ GHC.resume session (evalResumeHandle eval)
- names <- switchOnRunResult (evalStmt eval) runResult
- finishEvalExpr names
- return False
+doContinue :: Bool -> GHCi Bool
+doContinue step = do
+ session <- getSession
+ let resume | step = GHC.stepResume
+ | otherwise = GHC.resume
+ runResult <- io $ resume session
+ afterRunStmt runResult
+ return False
abandonCmd :: String -> GHCi ()
abandonCmd "" = do
- mb_res <- popResume
- case mb_res of
- Nothing -> do
- io $ putStrLn "There is no computation running."
- Just eval ->
- return ()
- -- the prompt will change to indicate the new context
+ s <- getSession
+ b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
+ when (not b) $ io $ putStrLn "There is no computation running."
+ return ()
+abandonCmd _ = do
+ io $ putStrLn "The abandon command accepts no arguments."
deleteCmd :: String -> GHCi ()
deleteCmd argLine = do
listCmd :: String -> GHCi ()
listCmd str = do
- st <- getGHCiState
- case resume st of
+ session <- getSession
+ resumes <- io $ GHC.getResumeContext session
+ case resumes of
[] -> printForUser $ text "not stopped at a breakpoint; nothing to list"
- eval:_ -> io $ listAround (evalSpan eval) True
+ eval:_ -> io $ listAround (GHC.resumeSpan eval) True
-- | list a section of a source file around a particular SrcSpan.
-- If the highlight flag is True, also highlight the span using
exprType,
typeKind,
parseName,
- RunResult(..), ResumeHandle,
- runStmt,
- resume,
+ RunResult(..),
+ runStmt, stepStmt, -- traceStmt,
+ resume, stepResume, -- traceResume,
+ Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan),
+ getResumeContext,
+ abandon, abandonAll,
showModule,
isModuleInterpreted,
compileExpr, HValue, dynCompileExpr,
lookupName,
obtainTerm, obtainTerm1,
+ modInfoModBreaks,
ModBreaks(..), BreakIndex,
BreakInfo(breakInfo_number, breakInfo_module),
BreakArray, setBreakOn, setBreakOff, getBreak,
- modInfoModBreaks,
#endif
-- * Abstract syntax elements
#include "HsVersions.h"
#ifdef GHCI
-import RtClosureInspect ( cvObtainTerm, Term )
-import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo,
- tcRnLookupName, getModuleExports )
-import GHC.Exts ( unsafeCoerce#, Ptr )
-import Foreign.StablePtr( deRefStablePtr, StablePtr, newStablePtr, freeStablePtr )
-import Foreign ( poke )
import qualified Linker
import Linker ( HValue )
-
-import Data.Dynamic ( Dynamic )
-
import ByteCodeInstr
-import IdInfo
-import HscMain ( hscParseIdentifier, hscTcExpr, hscKcType, hscStmt )
import BreakArray
+import NameSet
+import TcRnDriver
+import InteractiveEval
#endif
import Packages
import TcType hiding (typeKind)
import Id
import Var hiding (setIdType)
-import VarEnv
-import VarSet
import TysPrim ( alphaTyVars )
import TyCon
import Class
import DataCon
import Name hiding ( varName )
import OccName ( parenSymOcc )
-import NameEnv
import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
import SrcLoc
import DriverPipeline
import Maybes ( expectJust, mapCatMaybes )
import HaddockParse
import HaddockLex ( tokenise )
-import Unique
-import System.IO.Unsafe
-import Data.Array
import Control.Concurrent
import System.Directory ( getModificationTime, doesFileExist )
import Data.Maybe
sessionHscEnv :: Session -> IO HscEnv
sessionHscEnv (Session ref) = readIORef ref
-withSession :: Session -> (HscEnv -> IO a) -> IO a
-withSession (Session ref) f = do h <- readIORef ref; f h
-
-modifySession :: Session -> (HscEnv -> HscEnv) -> IO ()
-modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h
-
-- -----------------------------------------------------------------------------
-- Flags & settings
nodeMapElts :: NodeMap a -> [a]
nodeMapElts = eltsFM
-ms_mod_name :: ModSummary -> ModuleName
-ms_mod_name = moduleName . ms_mod
-
-- If there are {-# SOURCE #-} imports between strongly connected
-- components in the topological sort, then those imports can
-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
getBindings :: Session -> IO [TyThing]
-getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC)
+getBindings s = withSession s $ \hsc_env ->
+ -- we have to implement the shadowing behaviour of ic_tmp_ids here
+ -- (see InteractiveContext) and the quickest way is to use an OccEnv.
+ let
+ tmp_ids = reverse (ic_tmp_ids (hsc_IC hsc_env))
+ env = mkOccEnv [ (nameOccName (idName id), id) | id <- tmp_ids ]
+ in
+ return (map AnId (occEnvElts env))
getPrintUnqual :: Session -> IO PrintUnqualified
getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC)
text "is not loaded"))
err -> let msg = cannotFindModule dflags mod_name err in
throwDyn (CmdLineError (showSDoc msg))
-
-#ifdef GHCI
-
--- | 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
- ic = hsc_IC hsc_env
- gbl_rdrenv = ic_rn_gbl_env ic
- ids = typeEnvIds (ic_type_env ic)
- gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
- lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
- --
- return (gbl_names ++ lcl_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 :: 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
- -- ^ 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
- ThreadId -- thread running the computation
- (MVar ()) -- breakMVar
- (MVar Status) -- statusMVar
- [Name] -- [Name] to bind on completion
- InteractiveContext -- IC on completion
- InteractiveContext -- IC to restore on resumption
- [Name] -- [Name] to remove from the link env
-
--- We need to track two InteractiveContexts:
--- - the IC before runStmt, which is restored on each resume
--- - the IC binding the results of the original statement, which
--- will be the IC when runStmt returns with RunOk.
-
--- | 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_IC, names, hval) -> do
-
- -- 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
- withBreakAction breakMVar statusMVar $ do
-
- let thing_to_run = unsafeCoerce# hval :: IO [HValue]
- status <- sandboxIO statusMVar thing_to_run
- handleRunStatus ref new_IC names (hsc_IC hsc_env)
- breakMVar statusMVar status
-
-handleRunStatus ref final_ic final_names resume_ic breakMVar statusMVar status =
- case status of
- -- did we hit a breakpoint or did we complete?
- (Break apStack info tid) -> do
- hsc_env <- readIORef ref
- mod_info <- getHomeModuleInfo hsc_env (moduleName (breakInfo_module info))
- let breaks = minf_modBreaks (expectJust "handlRunStatus" mod_info)
- let index = breakInfo_number info
- occs = modBreaks_vars breaks ! index
- span = modBreaks_locs breaks ! index
- (new_hsc_env, names) <- extendEnvironment hsc_env apStack span
- (breakInfo_vars info)
- (breakInfo_resty info) occs
- writeIORef ref new_hsc_env
- let res = ResumeHandle breakMVar statusMVar final_names
- final_ic resume_ic names
- return (RunBreak tid names info res)
- (Complete either_hvals) ->
- case either_hvals of
- Left e -> return (RunException e)
- Right hvals -> do
- hsc_env <- readIORef ref
- writeIORef ref hsc_env{hsc_IC=final_ic}
- Linker.extendLinkEnv (zip final_names hvals)
- return (RunOk final_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)
-
-withBreakAction breakMVar statusMVar io
- = bracket setBreakAction resetBreakAction (\_ -> io)
- where
- setBreakAction = do
- stablePtr <- newStablePtr onBreak
- poke breakPointIOAction stablePtr
- return stablePtr
-
- onBreak info apStack = do
- tid <- myThreadId
- putMVar statusMVar (Break apStack info tid)
- takeMVar breakMVar
-
- resetBreakAction stablePtr = do
- poke breakPointIOAction noBreakStablePtr
- freeStablePtr stablePtr
-
-noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
-noBreakAction info apStack = putStrLn "*** Ignoring breakpoint"
-
-resume :: Session -> ResumeHandle -> IO RunResult
-resume (Session ref) res@(ResumeHandle breakMVar statusMVar
- final_names final_ic resume_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 = resume_ic }
- Linker.deleteFromLinkEnv names
-
- withBreakAction breakMVar statusMVar $ do
- putMVar breakMVar () -- this awakens the stopped thread...
- status <- takeMVar statusMVar -- and wait for the result
- handleRunStatus ref final_ic final_names resume_ic
- breakMVar statusMVar 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 unsafe "rts_getApStackVal"
- getApStackVal :: StablePtr a -> Int -> IO (StablePtr b)
-
-getIdValFromApStack :: a -> Int -> IO HValue
-getIdValFromApStack apStack stackDepth = do
- apSptr <- newStablePtr apStack
- resultSptr <- getApStackVal apSptr (stackDepth - 1)
- result <- deRefStablePtr resultSptr
- freeStablePtr apSptr
- freeStablePtr resultSptr
- return (unsafeCoerce# result)
-
-extendEnvironment
- :: HscEnv
- -> a -- the AP_STACK object built by the interpreter
- -> SrcSpan
- -> [(Id, Int)] -- free variables and offsets into the AP_STACK
- -> Type
- -> [OccName] -- names for the variables (from the source code)
- -> IO (HscEnv, [Name])
-extendEnvironment hsc_env apStack span idsOffsets result_ty occs = do
-
- -- filter out any unboxed ids; we can't bind these at the prompt
- let pointers = filter (\(id,_) -> isPointer id) idsOffsets
- isPointer id | PtrRep <- idPrimRep id = True
- | otherwise = False
-
- let (ids, offsets) = unzip pointers
- hValues <- mapM (getIdValFromApStack apStack) offsets
- new_ids <- zipWithM mkNewId occs ids
- let names = map idName 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_fs = FSLIT("_result")
- result_name = mkInternalName (getUnique result_fs)
- (mkVarOccFS result_fs) (srcSpanStart span)
- result_id = Id.mkLocalId 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
- -- be randomly unified with other types. These type variables
- -- can only be resolved by type reconstruction in RtClosureInspect
- -- - tidy the type variables
- -- - globalise the Id (Ids are supposed to be Global, apparently).
- --
- let all_ids | isPointer result_id = result_id : ids
- | otherwise = ids
- (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
- (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
- new_tyvars = unionVarSets tyvarss
- new_ids = zipWith setIdType all_ids tidy_tys
- global_ids = map (globaliseId VanillaGlobal) new_ids
-
- let ictxt = extendInteractiveContext (hsc_IC hsc_env)
- global_ids new_tyvars
-
- Linker.extendLinkEnv (zip names hValues)
- Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
- return (hsc_env{hsc_IC = ictxt}, result_name:names)
- where
- mkNewId :: OccName -> Id -> IO Id
- mkNewId occ id = do
- let uniq = idUnique id
- loc = nameSrcLoc (idName id)
- name = mkInternalName uniq occ loc
- ty = tidyTopType (idType id)
- new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
- return new_id
-
-skolemiseTy :: Type -> (Type, TyVarSet)
-skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
- where env = mkVarEnv (zip tyvars new_tyvar_tys)
- subst = mkTvSubst emptyInScopeSet env
- tyvars = varSetElems (tyVarsOfType ty)
- new_tyvars = map skolemiseTyVar tyvars
- new_tyvar_tys = map mkTyVarTy new_tyvars
-
-skolemiseTyVar :: TyVar -> TyVar
-skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
- (SkolemTv RuntimeUnkSkol)
-
------------------------------------------------------------------------------
--- 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))
-
-obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term
-obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
-
-obtainTerm :: Session -> Bool -> Id -> IO (Maybe Term)
-obtainTerm sess force id = withSession sess $ \hsc_env -> do
- mb_v <- Linker.getHValue (varName id)
- case mb_v of
- Just v -> fmap Just$ cvObtainTerm hsc_env force (Just$ idType id) v
- Nothing -> return Nothing
-
-#endif /* GHCI */
hscStmt -- Compile a stmt all the way to an HValue, but don't run it
:: HscEnv
-> String -- The statement
- -> IO (Maybe (InteractiveContext, [Name], HValue))
+ -> IO (Maybe ([Id], HValue))
hscStmt hsc_env stmt
= do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
; case maybe_tc_result of {
Nothing -> return Nothing ;
- Just (new_ic, bound_names, tc_expr) -> do {
-
+ Just (ids, tc_expr) -> do {
-- Desugar it
- ; let rdr_env = ic_rn_gbl_env new_ic
- type_env = ic_type_env new_ic
+ ; let rdr_env = ic_rn_gbl_env icontext
+ type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
; mb_ds_expr <- deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
; case mb_ds_expr of {
; let src_span = srcLocSpan interactiveSrcLoc
; hval <- compileExpr hsc_env src_span ds_expr
- ; return (Just (new_ic, bound_names, hval))
+ ; return (Just (ids, hval))
}}}}}}}
hscTcExpr -- Typecheck an expression (but don't run it)
\begin{code}
module HscTypes (
-- * Sessions and compilation state
- Session(..), HscEnv(..), hscEPS,
+ Session(..), withSession, modifySession,
+ HscEnv(..), hscEPS,
FinderCache, FindResult(..), ModLocationCache,
Target(..), TargetId(..), pprTarget, pprTargetId,
ModuleGraph, emptyMG,
ModDetails(..), emptyModDetails,
ModGuts(..), CgGuts(..), ModImports(..), ForeignStubs(..),
- ModSummary(..), showModMsg, isBootSummary,
+ ModSummary(..), ms_mod_name, showModMsg, isBootSummary,
msHsFilePath, msHiFilePath, msObjFilePath,
HscSource(..), isHsBoot, hscSourceString, -- Re-exported from DriverPhases
#ifdef GHCI
import ByteCodeAsm ( CompiledByteCode )
+import {-# SOURCE #-} InteractiveEval ( Resume )
#endif
import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv,
import StringBuffer ( StringBuffer )
import System.Time ( ClockTime )
-import Data.IORef ( IORef, readIORef )
+import Data.IORef
import Data.Array ( Array, array )
\end{code}
-- constituting the current program or library, the context for
-- interactive evaluation, and various caches.
newtype Session = Session (IORef HscEnv)
+
+withSession :: Session -> (HscEnv -> IO a) -> IO a
+withSession (Session ref) f = do h <- readIORef ref; f h
+
+modifySession :: Session -> (HscEnv -> HscEnv) -> IO ()
+modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h
\end{code}
HscEnv is like Session, except that some of the fields are immutable.
ic_rn_gbl_env :: GlobalRdrEnv, -- The cached GlobalRdrEnv, built from
-- ic_toplev_scope and ic_exports
- ic_type_env :: TypeEnv, -- Type env for names bound during
- -- interaction. NB. the names from
- -- these Ids are used to populate
- -- the LocalRdrEnv used during
- -- typechecking of a statement, so
- -- there should be no duplicate
- -- names in here.
+ ic_tmp_ids :: [Id], -- Names bound during interaction.
+ -- Earlier Ids shadow
+ -- later ones with the same OccName.
ic_tyvars :: TyVarSet -- skolem type variables free in
- -- ic_type_env. These arise at
+ -- ic_tmp_ids. These arise at
-- breakpoints in a polymorphic
-- context, where we have only partial
-- type information.
+
+#ifdef GHCI
+ , ic_resume :: [Resume] -- the stack of breakpoint contexts
+#endif
}
+
emptyInteractiveContext
= InteractiveContext { ic_toplev_scope = [],
ic_exports = [],
ic_rn_gbl_env = emptyGlobalRdrEnv,
- ic_type_env = emptyTypeEnv,
- ic_tyvars = emptyVarSet }
+ ic_tmp_ids = [],
+ ic_tyvars = emptyVarSet
+#ifdef GHCI
+ , ic_resume = []
+#endif
+ }
icPrintUnqual :: InteractiveContext -> PrintUnqualified
icPrintUnqual ictxt = mkPrintUnqualified (ic_rn_gbl_env ictxt)
-> TyVarSet
-> InteractiveContext
extendInteractiveContext ictxt ids tyvars
- = ictxt { ic_type_env = extendTypeEnvWithIds filtered_type_env ids,
+ = ictxt { ic_tmp_ids = ids ++ ic_tmp_ids ictxt,
ic_tyvars = ic_tyvars ictxt `unionVarSet` tyvars }
- where
- type_env = ic_type_env ictxt
- bound_names = map idName ids
- -- Remove any shadowed bindings from the type_env;
- -- we aren't allowed any duplicates because the LocalRdrEnv is
- -- build directly from the Ids in the type env in here.
- old_bound_names = map idName (typeEnvIds type_env)
- shadowed = [ n | name <- bound_names,
- n <- old_bound_names,
- nameOccName name == nameOccName n ]
- filtered_type_env = delListFromNameEnv type_env shadowed
\end{code}
%************************************************************************
ms_hspp_buf :: Maybe StringBuffer -- The actual preprocessed source, maybe.
}
+ms_mod_name :: ModSummary -> ModuleName
+ms_mod_name = moduleName . ms_mod
+
-- The ModLocation contains both the original source filename and the
-- filename of the cleaned-up source file after all preprocessing has been
-- done. The point is that the summariser will have to cpp/unlit/whatever
--- /dev/null
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2005-2007
+--
+-- Running statements interactively
+--
+-- -----------------------------------------------------------------------------
+
+module InteractiveEval (
+#ifdef GHCI
+ RunResult(..), Status(..), Resume(..),
+ runStmt, stepStmt, -- traceStmt,
+ resume, stepResume, -- traceResume,
+ abandon, abandonAll,
+ getResumeContext,
+ setContext, getContext,
+ nameSetToGlobalRdrEnv,
+ getNamesInScope,
+ getRdrNamesInScope,
+ moduleIsInterpreted,
+ getInfo,
+ exprType,
+ typeKind,
+ parseName,
+ showModule,
+ isModuleInterpreted,
+ compileExpr, dynCompileExpr,
+ lookupName,
+ obtainTerm, obtainTerm1
+#endif
+ ) where
+
+#ifdef GHCI
+
+#include "HsVersions.h"
+
+import HscMain hiding (compileExpr)
+import HscTypes
+import TcRnDriver
+import Type hiding (typeKind)
+import TcType hiding (typeKind)
+import InstEnv
+import Var hiding (setIdType)
+import Id
+import IdInfo
+import Name hiding ( varName )
+import NameSet
+import RdrName
+import VarSet
+import VarEnv
+import ByteCodeInstr
+import Linker
+import DynFlags
+import Unique
+import Module
+import Panic
+import UniqFM
+import Maybes
+import Util
+import SrcLoc
+import RtClosureInspect
+import Packages
+import BasicTypes
+import Outputable
+
+import Data.Dynamic
+import Control.Monad
+import Foreign
+import GHC.Exts
+import Data.Array
+import Control.Exception as Exception
+import Control.Concurrent
+import Data.IORef
+import Foreign.StablePtr
+
+-- -----------------------------------------------------------------------------
+-- 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
+
+data Status
+ = Break HValue BreakInfo ThreadId
+ -- ^ the computation hit a breakpoint
+ | Complete (Either Exception [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 :: ([Id], TyVarSet),
+ resumeFinalIds :: [Id], -- [Id] to bind on completion
+ resumeApStack :: HValue, -- The object from which we can get
+ -- value of the free variables.
+ resumeBreakInfo :: BreakInfo, -- the breakpoint we stopped at.
+ resumeSpan :: SrcSpan -- just a cache, otherwise it's a pain
+ -- to fetch the ModDetails & ModBreaks
+ -- to get this.
+ }
+
+getResumeContext :: Session -> IO [Resume]
+getResumeContext s = withSession s (return . ic_resume . hsc_IC)
+
+data SingleStep
+ = RunToCompletion
+ | SingleStep
+ | RunAndLogSteps
+
+isStep RunToCompletion = False
+isStep _ = True
+
+-- type History = [HistoryItem]
+--
+-- data HistoryItem = HistoryItem HValue BreakInfo
+--
+-- historyBreakInfo :: HistoryItem -> BreakInfo
+-- historyBreakInfo (HistoryItem _ bi) = bi
+--
+-- setContextToHistoryItem :: Session -> HistoryItem -> IO ()
+-- setContextToHistoryItem
+
+-- We need to track two InteractiveContexts:
+-- - the IC before runStmt, which is restored on each resume
+-- - the IC binding the results of the original statement, which
+-- will be the IC when runStmt returns with RunOk.
+
+-- | Run a statement in the current interactive context. Statement
+-- may bind multple values.
+runStmt :: Session -> String -> IO RunResult
+runStmt session expr = runStmt_ session expr RunToCompletion
+
+-- | Run a statement, stopping at the first breakpoint location encountered
+-- (regardless of whether the breakpoint is enabled).
+stepStmt :: Session -> String -> IO RunResult
+stepStmt session expr = runStmt_ session expr SingleStep
+
+-- | Run a statement, logging breakpoints passed, and stopping when either
+-- an enabled breakpoint is reached, or the statement completes.
+-- traceStmt :: Session -> String -> IO (RunResult, History)
+-- traceStmt session expr = runStmt_ session expr RunAndLogSteps
+
+runStmt_ (Session ref) expr step
+ = 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 (ids, hval) -> do
+
+ when (isStep step) $ setStepFlag
+
+ -- 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
+ withBreakAction breakMVar statusMVar $ do
+
+ let thing_to_run = unsafeCoerce# hval :: IO [HValue]
+ status <- sandboxIO statusMVar thing_to_run
+
+ let ic = hsc_IC hsc_env
+ bindings = (ic_tmp_ids ic, ic_tyvars ic)
+ handleRunStatus expr ref bindings ids breakMVar statusMVar status
+
+handleRunStatus expr ref bindings final_ids breakMVar statusMVar status =
+ case status of
+ -- did we hit a breakpoint or did we complete?
+ (Break apStack info tid) -> do
+ hsc_env <- readIORef ref
+ let
+ mod_name = moduleName (breakInfo_module info)
+ mod_details = fmap hm_details (lookupUFM (hsc_HPT hsc_env) mod_name)
+ breaks = md_modBreaks (expectJust "handlRunStatus" mod_details)
+ --
+ (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env
+ apStack info breaks
+ let
+ resume = Resume expr tid breakMVar statusMVar
+ bindings final_ids apStack info span
+ hsc_env2 = pushResume hsc_env1 resume
+ --
+ writeIORef ref hsc_env2
+ return (RunBreak tid names info)
+ (Complete either_hvals) ->
+ case either_hvals of
+ Left e -> return (RunException e)
+ Right hvals -> do
+ hsc_env <- readIORef ref
+ let final_ic = extendInteractiveContext (hsc_IC hsc_env)
+ final_ids emptyVarSet
+ -- the bound Ids never have any free TyVars
+ final_names = map idName final_ids
+ writeIORef ref hsc_env{hsc_IC=final_ic}
+ Linker.extendLinkEnv (zip final_names hvals)
+ return (RunOk final_names)
+
+{-
+traceRunStatus ref final_ids
+ breakMVar statusMVar status history = do
+ hsc_env <- readIORef ref
+ 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 apStack info tid) | not (isBreakEnabled hsc_env info) -> do
+ let history' = consBL (apStack,info) history
+ withBreakAction breakMVar statusMVar $ do
+ status <- withInterruptsSentTo
+ (do putMVar breakMVar () -- this awakens the stopped thread...
+ return tid)
+ (takeMVar statusMVar) -- and wait for the result
+
+ traceRunStatus ref final_ids
+ breakMVar statusMVar status history'
+ _other ->
+ handleRunStatus ref final_ids
+ breakMVar statusMVar status
+
+-}
+
+foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
+
+-- 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 =
+ withInterruptsSentTo
+ (forkIO (do res <- Exception.try thing
+ putMVar statusMVar (Complete res)))
+ (takeMVar statusMVar)
+
+withInterruptsSentTo :: IO ThreadId -> IO r -> IO r
+withInterruptsSentTo io get_result = do
+ ts <- takeMVar interruptTargetThread
+ child <- io
+ putMVar interruptTargetThread (child:ts)
+ get_result `finally` modifyMVar_ interruptTargetThread (return.tail)
+
+withBreakAction breakMVar statusMVar io
+ = bracket setBreakAction resetBreakAction (\_ -> io)
+ where
+ setBreakAction = do
+ stablePtr <- newStablePtr onBreak
+ poke breakPointIOAction stablePtr
+ return stablePtr
+
+ onBreak info apStack = do
+ tid <- myThreadId
+ putMVar statusMVar (Break apStack info tid)
+ takeMVar breakMVar
+
+ resetBreakAction stablePtr = do
+ poke breakPointIOAction noBreakStablePtr
+ freeStablePtr stablePtr
+
+noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
+noBreakAction info apStack = putStrLn "*** Ignoring breakpoint"
+
+resume :: Session -> IO RunResult
+resume session = resume_ session RunToCompletion
+
+stepResume :: Session -> IO RunResult
+stepResume session = resume_ session SingleStep
+
+-- traceResume :: Session -> IO RunResult
+-- traceResume session handle = resume_ session handle RunAndLogSteps
+
+resume_ :: Session -> SingleStep -> IO RunResult
+resume_ (Session ref) step
+ = do
+ hsc_env <- readIORef ref
+ let ic = hsc_IC hsc_env
+ resume = ic_resume ic
+
+ case resume of
+ [] -> throwDyn (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_ids, resume_tyvars) = resumeBindings r
+ ic' = ic { ic_tmp_ids = resume_tmp_ids,
+ ic_tyvars = resume_tyvars,
+ ic_resume = rs }
+ writeIORef ref hsc_env{ hsc_IC = ic' }
+
+ -- remove any bindings created since the breakpoint from the
+ -- linker's environment
+ let new_names = map idName (filter (`notElem` resume_tmp_ids)
+ (ic_tmp_ids ic))
+ Linker.deleteFromLinkEnv new_names
+
+
+ when (isStep step) $ setStepFlag
+ case r of
+ Resume expr tid breakMVar statusMVar bindings
+ final_ids apStack info _ -> do
+ withBreakAction breakMVar statusMVar $ do
+ status <- withInterruptsSentTo
+ (do putMVar breakMVar ()
+ -- this awakens the stopped thread...
+ return tid)
+ (takeMVar statusMVar)
+ -- and wait for the result
+ handleRunStatus expr ref bindings final_ids
+ breakMVar statusMVar status
+
+-- -----------------------------------------------------------------------------
+-- After stopping at a breakpoint, add free variables to the environment
+
+bindLocalsAtBreakpoint
+ :: HscEnv
+ -> HValue
+ -> BreakInfo
+ -> ModBreaks
+ -> IO (HscEnv, [Name], SrcSpan)
+bindLocalsAtBreakpoint hsc_env apStack info breaks = do
+
+ let
+ 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
+ let pointers = filter (\(id,_) -> isPointer id) vars
+ isPointer id | PtrRep <- idPrimRep id = True
+ | otherwise = False
+
+ let (ids, offsets) = unzip pointers
+ hValues <- mapM (getIdValFromApStack apStack) offsets
+ new_ids <- zipWithM mkNewId occs ids
+ let names = map idName 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_fs = FSLIT("_result")
+ result_name = mkInternalName (getUnique result_fs)
+ (mkVarOccFS result_fs) (srcSpanStart span)
+ result_id = Id.mkLocalId 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
+ -- be randomly unified with other types. These type variables
+ -- can only be resolved by type reconstruction in RtClosureInspect
+ -- - tidy the type variables
+ -- - globalise the Id (Ids are supposed to be Global, apparently).
+ --
+ let all_ids | isPointer result_id = result_id : ids
+ | otherwise = ids
+ (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
+ (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
+ new_tyvars = unionVarSets tyvarss
+ new_ids = zipWith setIdType all_ids tidy_tys
+ global_ids = map (globaliseId VanillaGlobal) new_ids
+
+ let ictxt0 = hsc_IC hsc_env
+ ictxt1 = extendInteractiveContext ictxt0 global_ids new_tyvars
+
+ Linker.extendLinkEnv (zip names hValues)
+ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
+ return (hsc_env{ hsc_IC = ictxt1 }, result_name:names, span)
+ where
+ mkNewId :: OccName -> Id -> IO Id
+ mkNewId occ id = do
+ let uniq = idUnique id
+ loc = nameSrcLoc (idName id)
+ name = mkInternalName uniq occ loc
+ ty = tidyTopType (idType id)
+ new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
+ return new_id
+
+skolemiseTy :: Type -> (Type, TyVarSet)
+skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
+ where env = mkVarEnv (zip tyvars new_tyvar_tys)
+ subst = mkTvSubst emptyInScopeSet env
+ tyvars = varSetElems (tyVarsOfType ty)
+ new_tyvars = map skolemiseTyVar tyvars
+ new_tyvar_tys = map mkTyVarTy new_tyvars
+
+skolemiseTyVar :: TyVar -> TyVar
+skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
+ (SkolemTv RuntimeUnkSkol)
+
+-- Todo: turn this into a primop, and provide special version(s) for
+-- unboxed things
+foreign import ccall unsafe "rts_getApStackVal"
+ getApStackVal :: StablePtr a -> Int -> IO (StablePtr b)
+
+getIdValFromApStack :: a -> Int -> IO HValue
+getIdValFromApStack apStack stackDepth = do
+ apSptr <- newStablePtr apStack
+ resultSptr <- getApStackVal apSptr (stackDepth - 1)
+ result <- deRefStablePtr resultSptr
+ freeStablePtr apSptr
+ freeStablePtr resultSptr
+ return (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 :: Session -> IO Bool
+abandon (Session ref) = do
+ hsc_env <- readIORef ref
+ let ic = hsc_IC hsc_env
+ resume = ic_resume ic
+ case resume of
+ [] -> return False
+ _:rs -> do
+ writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = rs } }
+ return True
+
+abandonAll :: Session -> IO Bool
+abandonAll (Session ref) = do
+ hsc_env <- readIORef ref
+ let ic = hsc_IC hsc_env
+ resume = ic_resume ic
+ case resume of
+ [] -> return False
+ _:rs -> do
+ writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = [] } }
+ return True
+
+-- -----------------------------------------------------------------------------
+-- 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)
+
+consBL a (BL len bound left right)
+ | len < bound = BL (len+1) bound (a:left) right
+ | null right = BL len bound [] $! tail (reverse left)
+ | otherwise = BL len bound [] $! tail right
+
+toListBL (BL _ _ left right) = left ++ reverse right
+
+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 :: 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
+ ic = hsc_IC hsc_env
+ gbl_rdrenv = ic_rn_gbl_env ic
+ ids = ic_tmp_ids ic
+ gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv))
+ lcl_names = map (mkRdrUnqual.nameOccName.idName) ids
+ --
+ return (gbl_names ++ lcl_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 :: 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 (ids, hval) -> do
+ -- Run it!
+ hvals <- (unsafeCoerce# hval) :: IO [HValue]
+
+ case (ids,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 (ids, hvals) -> do
+ vals <- (unsafeCoerce# hvals :: IO [Dynamic])
+ case (ids,vals) of
+ (_:[], v:[]) -> return (Just v)
+ _ -> panic "dynCompileExpr"
+
+-----------------------------------------------------------------------------
+-- 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))
+
+obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term
+obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
+
+obtainTerm :: Session -> Bool -> Id -> IO (Maybe Term)
+obtainTerm sess force id = withSession sess $ \hsc_env -> do
+ mb_v <- Linker.getHValue (varName id)
+ case mb_v of
+ Just v -> fmap Just$ cvObtainTerm hsc_env force (Just$ idType id) v
+ Nothing -> return Nothing
+
+#endif /* GHCI */
--- /dev/null
+module InteractiveEval (Resume) where
+
+data Resume
import ErrUtils
import Id
import Var
-import VarSet
import Module
import UniqFM
import Name
tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $
- tcExtendIdEnv (typeEnvIds (ic_type_env icxt)) $
+ tcExtendIdEnv (reverse (ic_tmp_ids icxt)) $
-- tcExtendIdEnv does lots:
-- - it extends the local type env (tcl_env) with the given Ids,
-- - it extends the local rdr env (tcl_rdr) with the Names from
-- - it adds the free tyvars of the Ids to the tcl_tyvars
-- set.
--
- -- We should have no Ids with the same name in the
- -- ic_type_env, otherwise we'll end up with shadowing in the
- -- tcl_rdr, and it's random which one will be in scope.
+ -- earlier ids in ic_tmp_ids must shadow later ones with the same
+ -- OccName, but tcExtendIdEnv has the opposite behaviour, hence the
+ -- reverse above.
- do { traceTc (text "setIC" <+> ppr (ic_type_env icxt))
+ do { traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt))
; thing_inside }
\end{code}
tcRnStmt :: HscEnv
-> InteractiveContext
-> LStmt RdrName
- -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
- -- The returned [Name] is the same as the input except for
- -- ExprStmt, in which case the returned [Name] is [itName]
+ -> IO (Maybe ([Id], LHsExpr Id))
+ -- The returned [Id] is the list of new Ids bound by
+ -- this statement. It can be used to extend the
+ -- InteractiveContext via extendInteractiveContext.
--
-- The returned TypecheckedHsExpr is of type IO [ () ],
-- a list of the bound values, coerced to ().
-- up to have tidy types
global_ids = map globaliseAndTidy zonked_ids ;
- bound_names = map idName global_ids ;
-
{- ---------------------------------------------
At one stage I removed any shadowed bindings from the type_env;
they are inaccessible but might, I suppose, cause a space leak if we leave them there.
Hence this code is commented out
-------------------------------------------------- -}
-
- new_ic = extendInteractiveContext ictxt global_ids emptyVarSet ;
} ;
dumpOptTcRn Opt_D_dump_tc
(vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
text "Typechecked expr" <+> ppr zonked_expr]) ;
- returnM (new_ic, bound_names, zonked_expr)
+ returnM (global_ids, zonked_expr)
}
where
bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
projects / ghc-hetmet.git / commitdiff