newSession,
-- * Flags and settings
- DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
+ DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
+ GhcMode(..), GhcLink(..),
parseDynamicFlags,
getSessionDynFlags,
setSessionDynFlags,
checkModule, CheckedModule(..),
TypecheckedSource, ParsedSource, RenamedSource,
+ -- * Parsing Haddock comments
+ parseHaddockComment,
+
-- * Inspecting the module structure of the program
ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
getModuleGraph,
exprType,
typeKind,
parseName,
- RunResult(..),
+ RunResult(..), ResumeHandle,
runStmt,
+ resume,
showModule,
+ isModuleInterpreted,
compileExpr, HValue, dynCompileExpr,
lookupName,
+ obtainTerm, obtainTerm1,
+ ModBreaks(..), BreakIndex,
+ BreakInfo(breakInfo_number, breakInfo_module),
+ BreakArray, setBreakOn, setBreakOff, getBreak,
+ modInfoModBreaks,
#endif
-- * Abstract syntax elements
-- ** Names
Name,
- nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc,
+ nameModule, pprParenSymName, nameSrcLoc,
NamedThing(..),
RdrName(Qual,Unqual),
instanceDFunId, pprInstance, pprInstanceHdr,
-- ** Types and Kinds
- Type, dropForAlls, splitForAllTys, funResultTy, pprParendType,
+ Type, dropForAlls, splitForAllTys, funResultTy,
+ pprParendType, pprTypeApp,
Kind,
PredType,
ThetaType, pprThetaArrow,
-- ** Source locations
SrcLoc, pprDefnLoc,
+ mkSrcLoc, isGoodSrcLoc,
+ srcLocFile, srcLocLine, srcLocCol,
+ SrcSpan,
+ mkSrcSpan, srcLocSpan,
+ srcSpanStart, srcSpanEnd,
+ srcSpanFile,
+ srcSpanStartLine, srcSpanEndLine,
+ srcSpanStartCol, srcSpanEndCol,
-- * Exceptions
GhcException(..), showGhcException,
#include "HsVersions.h"
#ifdef GHCI
-import qualified Linker
-import Data.Dynamic ( Dynamic )
-import Linker ( HValue, extendLinkEnv )
+import RtClosureInspect ( cvObtainTerm, Term )
import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo,
tcRnLookupName, getModuleExports )
-import RdrName ( plusGlobalRdrEnv, Provenance(..),
- ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
- mkGlobalRdrEnv )
-import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
-import Name ( nameOccName )
-import Type ( tidyType )
-import VarEnv ( emptyTidyEnv )
-import GHC.Exts ( unsafeCoerce# )
+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
#endif
-import Packages ( initPackages )
-import NameSet ( NameSet, nameSetToList, elemNameSet )
-import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..),
- globalRdrEnvElts, extendGlobalRdrEnv,
- emptyGlobalRdrEnv )
-import HsSyn
-import Type ( Kind, Type, dropForAlls, PredType, ThetaType,
- pprThetaArrow, pprParendType, splitForAllTys,
- funResultTy )
-import Id ( Id, idType, isImplicitId, isDeadBinder,
- isExportedId, isLocalId, isGlobalId,
- isRecordSelector, recordSelectorFieldLabel,
- isPrimOpId, isFCallId, isClassOpId_maybe,
- isDataConWorkId, idDataCon,
- isBottomingId )
-import Var ( TyVar )
+import Packages
+import NameSet
+import RdrName
+import HsSyn
+import Type hiding (typeKind)
+import TcType hiding (typeKind)
+import Id
+import Var hiding (setIdType)
+import VarEnv
+import VarSet
import TysPrim ( alphaTyVars )
-import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
- isPrimTyCon, isFunTyCon, isOpenTyCon, tyConArity,
- tyConTyVars, tyConDataCons, synTyConDefn,
- synTyConType, synTyConResKind )
-import Class ( Class, classSCTheta, classTvsFds, classMethods )
-import FunDeps ( pprFundeps )
-import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
- dataConFieldLabels, dataConStrictMarks,
- dataConIsInfix, isVanillaDataCon )
-import Name ( Name, nameModule, NamedThing(..), nameParent_maybe,
- nameSrcLoc )
+import TyCon
+import Class
+import FunDeps
+import DataCon
+import Name hiding ( varName )
import OccName ( parenSymOcc )
-import NameEnv ( nameEnvElts )
+import NameEnv
import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
import SrcLoc
import DriverPipeline
import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
import HeaderInfo ( getImports, getOptions )
import Finder
-import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) )
+import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) )
import HscTypes
import DynFlags
import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
cleanTempDirs )
import Module
import UniqFM
-import PackageConfig ( PackageId, stringToPackageId )
+import PackageConfig
import FiniteMap
import Panic
import Digraph
-import Bag ( unitBag )
+import Bag ( unitBag, listToBag )
import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg,
- mkPlainErrMsg, printBagOfErrors )
+ mkPlainErrMsg, printBagOfErrors, printBagOfWarnings,
+ WarnMsg )
import qualified ErrUtils
import Util
import StringBuffer ( StringBuffer, hGetStringBuffer )
import BasicTypes
import TcType ( tcSplitSigmaTy, isDictTy )
import Maybes ( expectJust, mapCatMaybes )
+import HaddockParse
+import HaddockLex ( tokenise )
+import PrelNames
+import Unique
+import Data.Array
import Control.Concurrent
import System.Directory ( getModificationTime, doesFileExist )
-import Data.Maybe ( isJust, isNothing )
-import Data.List ( partition, nub )
+import Data.Maybe
+import Data.List
import qualified Data.List as List
-import Control.Monad ( unless, when )
+import Control.Monad
import System.Exit ( exitWith, ExitCode(..) )
import System.Time ( ClockTime )
import Control.Exception as Exception hiding (handle)
defaultCleanupHandler :: DynFlags -> IO a -> IO a
defaultCleanupHandler dflags inner =
-- make sure we clean up after ourselves
- later (unless (dopt Opt_KeepTmpFiles dflags) $
- do cleanTempFiles dflags
- cleanTempDirs dflags
+ later (do cleanTempFiles dflags
+ cleanTempDirs dflags
)
-- exceptions will be blocked while we clean the temporary files,
-- so there shouldn't be any difficulty if we receive further
-- | Starts a new session. A session consists of a set of loaded
-- modules, a set of options (DynFlags), and an interactive context.
--- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed
--- code".
-newSession :: GhcMode -> Maybe FilePath -> IO Session
-newSession mode mb_top_dir = do
+newSession :: Maybe FilePath -> IO Session
+newSession mb_top_dir = do
-- catch ^C
main_thread <- myThreadId
- putMVar interruptTargetThread [main_thread]
+ modifyMVar_ interruptTargetThread (return . (main_thread :))
installSignalHandlers
dflags0 <- initSysTools mb_top_dir defaultDynFlags
dflags <- initDynFlags dflags0
- env <- newHscEnv dflags{ ghcMode=mode }
+ env <- newHscEnv dflags
ref <- newIORef env
return (Session ref)
hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
-- -----------------------------------------------------------------------------
+-- Parsing Haddock comments
+
+parseHaddockComment :: String -> Either String (HsDoc RdrName)
+parseHaddockComment string = parseHaddockParagraphs (tokenise string)
+
+-- -----------------------------------------------------------------------------
-- Loading the program
-- Perform a dependency analysis starting from the current targets
hsc_env <- readIORef ref
let
dflags = hsc_dflags hsc_env
- gmode = ghcMode (hsc_dflags hsc_env)
targets = hsc_targets hsc_env
old_graph = hsc_mod_graph hsc_env
showPass dflags "Chasing dependencies"
- when (gmode == BatchCompile) $
- debugTraceMsg dflags 2 (hcat [
- text "Chasing modules from: ",
- hcat (punctuate comma (map pprTarget targets))])
+ debugTraceMsg dflags 2 (hcat [
+ text "Chasing modules from: ",
+ hcat (punctuate comma (map pprTarget targets))])
r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
case r of
let hpt1 = hsc_HPT hsc_env
let dflags = hsc_dflags hsc_env
- let ghci_mode = ghcMode dflags -- this never changes
-- The "bad" boot modules are the ones for which we have
-- B.hs-boot in the module graph, but no B.hs
let mg2_with_srcimps :: [SCC ModSummary]
mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
+ -- If we can determine that any of the {-# SOURCE #-} imports
+ -- are definitely unnecessary, then emit a warning.
+ warnUnnecessarySourceImports dflags mg2_with_srcimps
+
+ let
-- check the stability property for each module.
stable_mods@(stable_obj,stable_bco)
- | BatchCompile <- ghci_mode = ([],[])
- | otherwise = checkStability hpt1 mg2_with_srcimps all_home_mods
+ = checkStability hpt1 mg2_with_srcimps all_home_mods
-- prune bits of the HPT which are definitely redundant now,
-- to save space.
let cleanup = cleanTempFilesExcept dflags
(ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
+ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
+ 2 (ppr mg))
(upsweep_ok, hsc_env1, modsUpswept)
<- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
pruned_hpt stable_mods cleanup mg
a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
do_linking = a_root_is_Main || no_hs_main
- when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $
- debugTraceMsg dflags 1 (text ("Warning: output was redirected with -o, " ++
- "but no output will be generated\n" ++
- "because there is no " ++ moduleNameString (moduleName main_mod) ++ " module."))
+ when (ghcLink dflags == LinkBinary
+ && isJust ofile && not do_linking) $
+ debugTraceMsg dflags 1 $
+ text ("Warning: output was redirected with -o, " ++
+ "but no output will be generated\n" ++
+ "because there is no " ++
+ moduleNameString (moduleName main_mod) ++ " module.")
-- link everything together
- linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1)
+ linkresult <- link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
loadFinish Succeeded linkresult ref hsc_env1
(eltsUFM (hsc_HPT hsc_env))) do
-- Link everything together
- linkresult <- link ghci_mode dflags False hpt4
+ linkresult <- link (ghcLink dflags) dflags False hpt4
let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
loadFinish Failed linkresult ref hsc_env4
-- fields within CheckedModule.
type ParsedSource = Located (HsModule RdrName)
-type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name])
+type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
+ Maybe (HsDoc Name), HaddockModInfo Name)
type TypecheckedSource = LHsBinds Id
-- NOTE:
(Just (tc_binds, rdr_env, details))) -> do
let minf = ModuleInfo {
minf_type_env = md_types details,
- minf_exports = md_exports details,
+ minf_exports = availsToNameSet $
+ md_exports details,
minf_rdr_env = Just rdr_env,
minf_instances = md_insts details
+#ifdef GHCI
+ ,minf_modBreaks = emptyModBreaks
+#endif
}
return (Just (CheckedModule {
parsedSource = parsed,
unload :: HscEnv -> [Linkable] -> IO ()
unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
- = case ghcMode (hsc_dflags hsc_env) of
- BatchCompile -> return ()
- JustTypecheck -> return ()
+ = case ghcLink (hsc_dflags hsc_env) of
#ifdef GHCI
- Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables
+ LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables
#else
- Interactive -> panic "unload: no interpreter"
+ LinkInMemory -> panic "unload: no interpreter"
#endif
- other -> panic "unload: strange mode"
+ other -> return ()
-- -----------------------------------------------------------------------------
-- checkStability
module. So we need to know that we will definitely not be recompiling
any of these modules, and we can use the object code.
- NB. stability is of no importance to BatchCompile at all, only Interactive.
- (ToDo: what about JustTypecheck?)
-
The stability check is as follows. Both stableObject and
stableBCO are used during the upsweep phase later.
These properties embody the following ideas:
- - if a module is stable:
+ - if a module is stable, then:
- if it has been compiled in a previous pass (present in HPT)
then it does not need to be compiled or re-linked.
- if it has not been compiled in a previous pass,
-> IO (Maybe HomeModInfo) -- Nothing => Failed
upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
- = do
- let
- this_mod_name = ms_mod_name summary
+ = let
+ this_mod_name = ms_mod_name summary
this_mod = ms_mod summary
mb_obj_date = ms_obj_date summary
obj_fn = ml_obj_file (ms_location summary)
hs_date = ms_hs_date summary
+ is_stable_obj = this_mod_name `elem` stable_obj
+ is_stable_bco = this_mod_name `elem` stable_bco
+
+ old_hmi = lookupUFM old_hpt this_mod_name
+
+ -- We're using the dflags for this module now, obtained by
+ -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
+ dflags = ms_hspp_opts summary
+ prevailing_target = hscTarget (hsc_dflags hsc_env)
+ local_target = hscTarget dflags
+
+ -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that
+ -- we don't do anything dodgy: these should only work to change
+ -- from -fvia-C to -fasm and vice-versa, otherwise we could
+ -- end up trying to link object code to byte code.
+ target = if prevailing_target /= local_target
+ && (not (isObjectTarget prevailing_target)
+ || not (isObjectTarget local_target))
+ then prevailing_target
+ else local_target
+
+ -- store the corrected hscTarget into the summary
+ summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }
+
+ -- The old interface is ok if
+ -- a) we're compiling a source file, and the old HPT
+ -- entry is for a source file
+ -- b) we're compiling a hs-boot file
+ -- Case (b) allows an hs-boot file to get the interface of its
+ -- real source file on the second iteration of the compilation
+ -- manager, but that does no harm. Otherwise the hs-boot file
+ -- will always be recompiled
+
+ mb_old_iface
+ = case old_hmi of
+ Nothing -> Nothing
+ Just hm_info | isBootSummary summary -> Just iface
+ | not (mi_boot iface) -> Just iface
+ | otherwise -> Nothing
+ where
+ iface = hm_iface hm_info
+
compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
compile_it = upsweep_compile hsc_env old_hpt this_mod_name
- summary mod_index nmods
-
- case ghcMode (hsc_dflags hsc_env) of
- BatchCompile ->
- case () of
- -- Batch-compilating is easy: just check whether we have
- -- an up-to-date object file. If we do, then the compiler
- -- needs to do a recompilation check.
- _ | Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
- linkable <-
- findObjectLinkable this_mod obj_fn obj_date
- compile_it (Just linkable)
-
- | otherwise ->
- compile_it Nothing
-
- interactive ->
- case () of
- _ | is_stable_obj, isJust old_hmi ->
- return old_hmi
+ summary' mod_index nmods mb_old_iface
+
+ compile_it_discard_iface
+ = upsweep_compile hsc_env old_hpt this_mod_name
+ summary' mod_index nmods Nothing
+
+ in
+ case target of
+
+ _any
+ -- Regardless of whether we're generating object code or
+ -- byte code, we can always use an existing object file
+ -- if it is *stable* (see checkStability).
+ | is_stable_obj, isJust old_hmi ->
+ return old_hmi
-- object is stable, and we have an entry in the
-- old HPT: nothing to do
- | is_stable_obj, isNothing old_hmi -> do
- linkable <-
- findObjectLinkable this_mod obj_fn
+ | is_stable_obj, isNothing old_hmi -> do
+ linkable <- findObjectLinkable this_mod obj_fn
(expectJust "upseep1" mb_obj_date)
- compile_it (Just linkable)
+ compile_it (Just linkable)
-- object is stable, but we need to load the interface
-- off disk to make a HMI.
- | is_stable_bco ->
- ASSERT(isJust old_hmi) -- must be in the old_hpt
- return old_hmi
+ HscInterpreted
+ | is_stable_bco ->
+ ASSERT(isJust old_hmi) -- must be in the old_hpt
+ return old_hmi
-- BCO is stable: nothing to do
- | Just hmi <- old_hmi,
- Just l <- hm_linkable hmi, not (isObjectLinkable l),
- linkableTime l >= ms_hs_date summary ->
- compile_it (Just l)
+ | Just hmi <- old_hmi,
+ Just l <- hm_linkable hmi, not (isObjectLinkable l),
+ linkableTime l >= ms_hs_date summary ->
+ compile_it (Just l)
-- we have an old BCO that is up to date with respect
-- to the source: do a recompilation check as normal.
- | otherwise ->
- compile_it Nothing
+ | otherwise ->
+ compile_it Nothing
-- no existing code at all: we must recompile.
- where
- is_stable_obj = this_mod_name `elem` stable_obj
- is_stable_bco = this_mod_name `elem` stable_bco
- old_hmi = lookupUFM old_hpt this_mod_name
+ -- When generating object code, if there's an up-to-date
+ -- object file on the disk, then we can use it.
+ -- However, if the object file is new (compared to any
+ -- linkable we had from a previous compilation), then we
+ -- must discard any in-memory interface, because this
+ -- means the user has compiled the source file
+ -- separately and generated a new interface, that we must
+ -- read from the disk.
+ --
+ obj | isObjectTarget obj,
+ Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
+ case old_hmi of
+ Just hmi
+ | Just l <- hm_linkable hmi,
+ isObjectLinkable l && linkableTime l == obj_date
+ -> compile_it (Just l)
+ _otherwise -> do
+ linkable <- findObjectLinkable this_mod obj_fn obj_date
+ compile_it_discard_iface (Just linkable)
+
+ _otherwise ->
+ compile_it Nothing
+
-- Run hsc to compile a module
upsweep_compile hsc_env old_hpt this_mod summary
mod_index nmods
- mb_old_linkable = do
- let
- -- The old interface is ok if it's in the old HPT
- -- a) we're compiling a source file, and the old HPT
- -- entry is for a source file
- -- b) we're compiling a hs-boot file
- -- Case (b) allows an hs-boot file to get the interface of its
- -- real source file on the second iteration of the compilation
- -- manager, but that does no harm. Otherwise the hs-boot file
- -- will always be recompiled
-
- mb_old_iface
- = case lookupUFM old_hpt this_mod of
- Nothing -> Nothing
- Just hm_info | isBootSummary summary -> Just iface
- | not (mi_boot iface) -> Just iface
- | otherwise -> Nothing
- where
- iface = hm_iface hm_info
-
- compresult <- compile hsc_env summary mb_old_linkable mb_old_iface
+ mb_old_iface
+ mb_old_linkable
+ = do
+ compresult <- compile hsc_env summary mb_old_linkable mb_old_iface
mod_index nmods
- case compresult of
+ case compresult of
-- Compilation failed. Compile may still have updated the PCS, tho.
CompErrs -> return Nothing
-- We use integers as the keys for the SCC algorithm
nodes :: [(ModSummary, Int, [Int])]
- nodes = [(s, expectJust "topSort" (lookup_key (ms_hsc_src s) (ms_mod_name s)),
+ nodes = [(s, expectJust "topSort" $
+ lookup_key (ms_hsc_src s) (ms_mod_name s),
out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++
- out_edge_keys HsSrcFile (map unLoc (ms_imps s)) )
+ out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ++
+ (-- see [boot-edges] below
+ if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
+ then []
+ else case lookup_key HsBootFile (ms_mod_name s) of
+ Nothing -> []
+ Just k -> [k])
+ )
| s <- summaries
, not (isBootSummary s && drop_hs_boot_nodes) ]
-- Drop the hi-boot ones if told to do so
+ -- [boot-edges] if this is a .hs and there is an equivalent
+ -- .hs-boot, add a link from the former to the latter. This
+ -- has the effect of detecting bogus cases where the .hs-boot
+ -- depends on the .hs, by introducing a cycle. Additionally,
+ -- it ensures that we will always process the .hs-boot before
+ -- the .hs, and so the HomePackageTable will always have the
+ -- most up to date information.
+
key_map :: NodeMap Int
key_map = listToFM ([(moduleName (ms_mod s), ms_hsc_src s)
| s <- summaries]
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
+-- were necessary, then the edge would be part of a cycle.
+warnUnnecessarySourceImports :: DynFlags -> [SCC ModSummary] -> IO ()
+warnUnnecessarySourceImports dflags sccs =
+ printBagOfWarnings dflags (listToBag (concat (map (check.flattenSCC) sccs)))
+ where check ms =
+ let mods_in_this_cycle = map ms_mod_name ms in
+ [ warn m i | m <- ms, i <- ms_srcimps m,
+ unLoc i `notElem` mods_in_this_cycle ]
+
+ warn :: ModSummary -> Located ModuleName -> WarnMsg
+ warn ms (L loc mod) =
+ mkPlainErrMsg loc
+ (ptext SLIT("Warning: {-# SOURCE #-} unnecessary in import of ")
+ <+> quotes (ppr mod))
+
-----------------------------------------------------------------------------
-- Downsweep (dependency analysis)
-- | Container for information about a 'Module'.
data ModuleInfo = ModuleInfo {
minf_type_env :: TypeEnv,
- minf_exports :: NameSet,
+ minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
minf_instances :: [Instance]
+#ifdef GHCI
+ ,minf_modBreaks :: ModBreaks
+#endif
-- ToDo: this should really contain the ModIface too
}
-- We don't want HomeModInfo here, because a ModuleInfo applies
getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getPackageModuleInfo hsc_env mdl = do
#ifdef GHCI
- (_msgs, mb_names) <- getModuleExports hsc_env mdl
- case mb_names of
+ (_msgs, mb_avails) <- getModuleExports hsc_env mdl
+ case mb_avails of
Nothing -> return Nothing
- Just names -> do
+ Just avails -> do
eps <- readIORef (hsc_EPS hsc_env)
let
+ names = availsToNameSet avails
pte = eps_PTE eps
- n_list = nameSetToList names
- tys = [ ty | name <- n_list,
+ tys = [ ty | name <- concatMap availNames avails,
Just ty <- [lookupTypeEnv pte name] ]
--
return (Just (ModuleInfo {
minf_type_env = mkTypeEnv tys,
minf_exports = names,
minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
- minf_instances = error "getModuleInfo: instances for package module unimplemented"
+ minf_instances = error "getModuleInfo: instances for package module unimplemented",
+ minf_modBreaks = emptyModBreaks
}))
#else
-- bogusly different for non-GHCI (ToDo)
let details = hm_details hmi
return (Just (ModuleInfo {
minf_type_env = md_types details,
- minf_exports = md_exports details,
+ minf_exports = availsToNameSet (md_exports details),
minf_rdr_env = mi_globals $! hm_iface hmi,
minf_instances = md_insts details
+#ifdef GHCI
+ ,minf_modBreaks = md_modBreaks details
+#endif
}))
-- | The list of top-level entities defined in a module
return $! lookupType (hsc_dflags hsc_env)
(hsc_HPT hsc_env) (eps_PTE eps) name
+#ifdef GHCI
+modInfoModBreaks = minf_modBreaks
+#endif
+
isDictonaryId :: Id -> Bool
isDictonaryId id
= case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau }
case lookupUFM hpt mod_name of
Just mod_info -> return (mi_module (hm_iface mod_info))
_not_a_home_module -> do
- res <- findImportedModule hsc_env mod_name Nothing
+ res <- findImportedModule hsc_env mod_name maybe_pkg
case res of
Found _ m | modulePackageId m /= this_pkg -> return m
| otherwise -> throwDyn (CmdLineError (showSDoc $
-> [Module] -- entire top level scope of these modules
-> [Module] -- exports only of these modules
-> IO ()
-setContext (Session ref) toplev_mods export_mods = do
+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
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 name_set (moduleName mod)
- | (Just name_set, mod) <- zip mb_name_sets mods ]
+ gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
+ | (Just avails, mod) <- zip mb_name_sets mods ]
--
return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
= RunOk [Name] -- ^ names bound by this evaluation
| RunFailed -- ^ statement failed compilation
| RunException Exception -- ^ statement raised an exception
-
--- | Run a statement in the current interactive context. Statemenet
+ | 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
+ (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
case maybe_stuff of
Nothing -> return RunFailed
- Just (new_hsc_env, names, hval) -> do
-
- let thing_to_run = unsafeCoerce# hval :: IO [HValue]
- either_hvals <- sandboxIO thing_to_run
-
+ 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
+ stablePtr <- setBreakAction breakMVar statusMVar
+
+ 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 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 -> do
- -- on error, keep the *old* interactive context,
- -- so that 'it' is not bound to something
- -- that doesn't exist.
- return (RunException e)
-
+ Left e -> return (RunException e)
Right hvals -> do
- -- Get the newly bound things, and bind them.
- -- Don't need to delete any shadowed bindings;
- -- the new ones override the old ones.
- extendLinkEnv (zip names hvals)
-
- writeIORef ref new_hsc_env
- return (RunOk names)
+ 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 :: IO a -> IO (Either Exception a)
-sandboxIO thing = do
- m <- newEmptyMVar
+sandboxIO :: MVar Status -> IO [HValue] -> IO Status
+sandboxIO statusMVar thing = do
ts <- takeMVar interruptTargetThread
- child <- forkIO (do res <- Exception.try thing; putMVar m res)
+ child <- forkIO (do res <- Exception.try thing; putMVar statusMVar (Complete res))
putMVar interruptTargetThread (child:ts)
- takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail)
+ takeMVar statusMVar `finally` modifyMVar_ interruptTargetThread (return.tail)
+
+setBreakAction breakMVar statusMVar = do
+ stablePtr <- newStablePtr onBreak
+ poke breakPointIOAction stablePtr
+ return stablePtr
+ where onBreak ids apStack = do
+ tid <- myThreadId
+ putMVar statusMVar (Break apStack ids tid)
+ takeMVar breakMVar
+
+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
+
+ stablePtr <- setBreakAction breakMVar statusMVar
+ 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 final_ic final_names resume_ic
+ breakMVar statusMVar status
{-
-- This version of sandboxIO runs the expression in a completely new
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 -- 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
+ idsVals <- mapM (getIdValFromApStack apStack) idsOffsets
+ let (ids, hValues) = unzip idsVals
+ 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 = result_id : 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 -> do
+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 (showModMsg (hscTarget (hsc_dflags hsc_env)) (not obj_linkable) mod_summary)
+ 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 */
projects / ghc-hetmet.git / blobdiff