newSession,
-- * Flags and settings
- DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
+ DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
+ GhcMode(..), GhcLink(..),
parseDynamicFlags,
getSessionDynFlags,
setSessionDynFlags,
modInfoInstances,
modInfoIsExportedName,
modInfoLookupName,
+#if defined(GHCI)
+ modInfoBkptSites,
+#endif
lookupGlobalName,
-- * Printing
RunResult(..),
runStmt,
showModule,
+ isModuleInterpreted,
compileExpr, HValue, dynCompileExpr,
lookupName,
+
+ getBreakpointHandler, setBreakpointHandler,
+ obtainTerm, obtainTerm1,
#endif
-- * Abstract syntax elements
instanceDFunId, pprInstance, pprInstanceHdr,
-- ** Types and Kinds
- Type, dropForAlls, splitForAllTys, funResultTy, pprParendType,
+ Type, dropForAlls, splitForAllTys, funResultTy,
+ pprParendType, pprTypeApp,
Kind,
PredType,
ThetaType, pprThetaArrow,
#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(..),
import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
import Name ( nameOccName )
import Type ( tidyType )
+import Var ( varName )
import VarEnv ( emptyTidyEnv )
-import GHC.Exts ( unsafeCoerce# )
+import GHC.Exts ( unsafeCoerce# )
+
+-- For breakpoints
+import Breakpoints ( SiteNumber, Coord, nullBkptHandler,
+ BkptHandler(..), BkptLocation, noDbgSites )
+import Linker ( initDynLinker )
+import PrelNames ( breakpointJumpName, breakpointCondJumpName,
+ breakpointAutoJumpName )
+
+import GHC.Exts ( Int(..), Ptr(..), int2Addr#, indexArray# )
+import GHC.Base ( Opaque(..) )
+import Foreign.StablePtr( deRefStablePtr, castPtrToStablePtr )
+import Foreign ( unsafePerformIO )
+import Data.Maybe ( fromMaybe)
+import qualified Linker
+
+import Data.Dynamic ( Dynamic )
+import Linker ( HValue, getHValue, extendLinkEnv )
#endif
import Packages ( initPackages )
import HsSyn
import Type ( Kind, Type, dropForAlls, PredType, ThetaType,
pprThetaArrow, pprParendType, splitForAllTys,
- funResultTy )
+ pprTypeApp, funResultTy )
import Id ( Id, idType, isImplicitId, isDeadBinder,
isExportedId, isLocalId, isGlobalId,
isRecordSelector, recordSelectorFieldLabel,
cleanTempDirs )
import Module
import UniqFM
-import PackageConfig ( PackageId, stringToPackageId )
+import PackageConfig ( PackageId, stringToPackageId, mainPackageId )
import FiniteMap
import Panic
import Digraph
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
inner
+#if defined(GHCI)
+GLOBAL_VAR(v_bkptLinkEnv, [], [(Name, HValue)])
+ -- stores the current breakpoint handler to help setContext to
+ -- restore it after a context change
+#endif
+
-- | 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)
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
-- 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.
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
md_exports details,
minf_rdr_env = Just rdr_env,
minf_instances = md_insts details
+#ifdef GHCI
+ ,minf_dbg_sites = noDbgSites
+#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
minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
minf_instances :: [Instance]
+#ifdef GHCI
+ ,minf_dbg_sites :: [(SiteNumber,Coord)]
+#endif
-- ToDo: this should really contain the ModIface too
}
-- We don't want HomeModInfo here, because a ModuleInfo applies
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_dbg_sites = noDbgSites
}))
#else
-- bogusly different for non-GHCI (ToDo)
minf_exports = availsToNameSet (md_exports details),
minf_rdr_env = mi_globals $! hm_iface hmi,
minf_instances = md_insts details
+#ifdef GHCI
+ ,minf_dbg_sites = md_dbg_sites 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
+modInfoBkptSites = minf_dbg_sites
+#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
writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
ic_exports = export_mods,
ic_rn_gbl_env = all_env }}
-
+ reinstallBreakpointHandlers sess
-- Make a GlobalRdrEnv based on the exports of the modules only.
mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
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
+
-}
+
-----------------------------------------------------------------------------
-- 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))
+-----------------------------------------------------------------------------
+-- Breakpoint handlers
+
+getBreakpointHandler :: Session -> IO (Maybe (BkptHandler Module))
+getBreakpointHandler session = getSessionDynFlags session >>= return . bkptHandler
+
+setBreakpointHandler :: Session -> BkptHandler Module -> IO ()
+setBreakpointHandler session handler = do
+ dflags <- getSessionDynFlags session
+ setSessionDynFlags session dflags{ bkptHandler = Just handler }
+ let linkEnv = [ ( breakpointJumpName
+ , unsafeCoerce# (jumpFunction session handler))
+ , ( breakpointCondJumpName
+ , unsafeCoerce# (jumpCondFunction session handler))
+ , ( breakpointAutoJumpName
+ , unsafeCoerce# (jumpAutoFunction session handler))
+ ]
+ writeIORef v_bkptLinkEnv linkEnv
+ dflags <- getSessionDynFlags session
+ reinstallBreakpointHandlers session
+
+reinstallBreakpointHandlers :: Session -> IO ()
+reinstallBreakpointHandlers session = do
+ dflags <- getSessionDynFlags session
+ let mode = ghcMode dflags
+ when (ghcLink dflags == LinkInMemory) $ do
+ linkEnv <- readIORef v_bkptLinkEnv
+ initDynLinker dflags
+ extendLinkEnv linkEnv
+
+-----------------------------------------------------------------------
+-- Jump functions
+
+type SiteInfo = (String, SiteNumber)
+jumpFunction, jumpAutoFunction :: Session -> BkptHandler Module -> SiteInfo -> (Int, [Opaque], String) -> b -> b
+jumpCondFunction :: Session -> BkptHandler Module -> SiteInfo -> (Int, [Opaque], String) -> Bool -> b -> b
+jumpFunctionM :: Session -> BkptHandler a -> BkptLocation a -> (Int, [Opaque], String) -> b -> IO b
+
+jumpCondFunction _ _ _ _ False b = b
+jumpCondFunction session handler site args True b
+ = jumpFunction session handler site args b
+
+jumpFunction session handler siteInfo args b
+ | site <- mkSite siteInfo
+ = unsafePerformIO $ jumpFunctionM session handler site args b
+
+jumpFunctionM session handler site (I# idsPtr, wrapped_hValues, locmsg) b =
+ do
+ ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
+ let hValues = unsafeCoerce# b : [unsafeCoerce# hv | O hv <- wrapped_hValues]
+ handleBreakpoint handler session (zip ids hValues) site locmsg b
+
+jumpAutoFunction session handler siteInfo args b
+ | site <- mkSite siteInfo
+ = unsafePerformIO $ do
+ break <- isAutoBkptEnabled handler session site
+ if break
+ then jumpFunctionM session handler site args b
+ else return b
+
+jumpStepByStepFunction session handler siteInfo args b
+ | site <- mkSite siteInfo
+ = unsafePerformIO $ do
+ jumpFunctionM session handler site args b
+
+mkSite :: SiteInfo -> BkptLocation Module
+mkSite ( modName, sitenum) =
+ (mkModule mainPackageId (mkModuleName modName), sitenum)
+
+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 <- 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