Session,
defaultErrorHandler,
defaultCleanupHandler,
- init, initFromArgs,
newSession,
-- * Flags and settings
DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
parseDynamicFlags,
- initPackages,
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,
modInfoInstances,
modInfoIsExportedName,
modInfoLookupName,
+#if defined(GHCI)
+ modInfoBkptSites,
+#endif
lookupGlobalName,
-- * Printing
RunResult(..),
runStmt,
showModule,
- compileExpr, HValue,
+ isModuleInterpreted,
+ compileExpr, HValue, dynCompileExpr,
lookupName,
+
+ getBreakpointHandler, setBreakpointHandler,
+ obtainTerm, obtainTerm1,
#endif
-- * Abstract syntax elements
-- ** Names
Name,
- nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc,
+ nameModule, pprParenSymName, nameSrcLoc,
NamedThing(..),
RdrName(Qual,Unqual),
TyCon,
tyConTyVars, tyConDataCons, tyConArity,
isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
- synTyConDefn, synTyConRhs,
+ isOpenTyCon,
+ synTyConDefn, synTyConType, synTyConResKind,
-- ** Type variables
TyVar,
instanceDFunId, pprInstance, pprInstanceHdr,
-- ** Types and Kinds
- Type, dropForAlls, splitForAllTys, funResultTy, pprParendType,
+ Type, dropForAlls, splitForAllTys, funResultTy,
+ pprParendType, pprTypeApp,
Kind,
PredType,
ThetaType, pprThetaArrow,
ToDo:
* inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
- * we need to expose DynFlags, so should parseDynamicFlags really be
- part of this interface?
* what StaticFlags should we expose, if any?
-}
#include "HsVersions.h"
#ifdef GHCI
-import qualified Linker
-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 RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..),
globalRdrEnvElts, extendGlobalRdrEnv,
emptyGlobalRdrEnv )
-import HsSyn
+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,
import Var ( TyVar )
import TysPrim ( alphaTyVars )
import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
- isPrimTyCon, isFunTyCon, tyConArity,
- tyConTyVars, tyConDataCons, synTyConDefn, synTyConRhs )
+ 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 Name ( Name, nameModule, NamedThing(..), nameSrcLoc )
import OccName ( parenSymOcc )
import NameEnv ( nameEnvElts )
import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
cleanTempDirs )
import Module
import UniqFM
-import PackageConfig ( PackageId )
+import PackageConfig ( PackageId, stringToPackageId )
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 ( parseHaddockParagraphs, parseHaddockString )
+import HaddockLex ( tokenise )
import Control.Concurrent
import System.Directory ( getModificationTime, doesFileExist )
inner
--- | Initialises GHC. This must be done /once/ only. Takes the
--- TopDir path without the '-B' prefix.
-
-init :: Maybe String -> IO ()
-init mbMinusB = do
- -- catch ^C
- main_thread <- myThreadId
- putMVar interruptTargetThread [main_thread]
- installSignalHandlers
-
- dflags0 <- initSysTools mbMinusB defaultDynFlags
- writeIORef v_initDynFlags dflags0
-
--- | Initialises GHC. This must be done /once/ only. Takes the
--- command-line arguments. All command-line arguments which aren't
--- understood by GHC will be returned.
-
-initFromArgs :: [String] -> IO [String]
-initFromArgs args
- = do init mbMinusB
- return argv1
- where -- Grab the -B option if there is one
- (minusB_args, argv1) = partition (prefixMatch "-B") args
- mbMinusB | null minusB_args
- = Nothing
- | otherwise
- = Just (drop 2 (last minusB_args))
-
-GLOBAL_VAR(v_initDynFlags, error "initDynFlags", DynFlags)
- -- stores the DynFlags between the call to init and subsequent
- -- calls to newSession.
+#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 -> IO Session
-newSession mode = do
- dflags0 <- readIORef v_initDynFlags
- dflags <- initDynFlags dflags0
+newSession :: GhcMode -> Maybe FilePath -> IO Session
+newSession mode mb_top_dir = do
+ -- catch ^C
+ main_thread <- myThreadId
+ modifyMVar_ interruptTargetThread (return . (main_thread :))
+ installSignalHandlers
+
+ dflags0 <- initSysTools mb_top_dir defaultDynFlags
+ dflags <- initDynFlags dflags0
env <- newHscEnv dflags{ ghcMode=mode }
ref <- newIORef env
return (Session ref)
getSessionDynFlags :: Session -> IO DynFlags
getSessionDynFlags s = withSession s (return . hsc_dflags)
--- | Updates the DynFlags in a Session
-setSessionDynFlags :: Session -> DynFlags -> IO ()
-setSessionDynFlags s dflags = modifySession s (\h -> h{ hsc_dflags = dflags })
+-- | Updates the DynFlags in a Session. This also reads
+-- the package database (unless it has already been read),
+-- and prepares the compilers knowledge about packages. It
+-- can be called again to load new packages: just add new
+-- package flags to (packageFlags dflags).
+--
+-- Returns a list of new packages that may need to be linked in using
+-- the dynamic linker (see 'linkPackages') as a result of new package
+-- flags. If you are not doing linking or doing static linking, you
+-- can ignore the list of packages returned.
+--
+setSessionDynFlags :: Session -> DynFlags -> IO [PackageId]
+setSessionDynFlags (Session ref) dflags = do
+ hsc_env <- readIORef ref
+ (dflags', preload) <- initPackages dflags
+ writeIORef ref $! hsc_env{ hsc_dflags = dflags' }
+ return preload
-- | If there is no -o option, guess the name of target executable
-- by using top-level source file name as a base.
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
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 = ([],[])
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
-- 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_dbg_sites = noDbgSites
+#endif
}
return (Just (CheckedModule {
parsedSource = parsed,
-- 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_dbg_sites :: [(SiteNumber,Coord)]
+#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_dbg_sites = noDbgSites
}))
#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_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 }
-> [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
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
_ -> 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
-- 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))
+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 (mode == Interactive) $ do
+ linkEnv <- readIORef v_bkptLinkEnv
+ initDynLinker dflags
+ extendLinkEnv linkEnv
+
+type SiteInfo = (String, String, SiteNumber)
+jumpFunction, jumpAutoFunction :: Session -> BkptHandler Module -> Int -> [Opaque]
+ -> SiteInfo -> String -> b -> b
+jumpCondFunction :: Session -> BkptHandler Module -> Int -> [Opaque]
+ -> SiteInfo -> String -> Bool -> b -> b
+jumpFunctionM :: Session -> BkptHandler a -> Int -> [Opaque] -> BkptLocation a
+ -> String -> b -> IO b
+
+jumpCondFunction _ _ _ _ _ _ False b = b
+jumpCondFunction session handler ptr hValues siteInfo locmsg True b
+ = jumpFunction session handler ptr hValues siteInfo locmsg b
+
+jumpFunction session handler ptr hValues siteInfo locmsg b
+ | site <- mkSite siteInfo
+ = unsafePerformIO $ jumpFunctionM session handler ptr hValues site locmsg b
+
+jumpFunctionM session handler (I# idsPtr) wrapped_hValues site locmsg b =
+ do
+ ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
+ ASSERT (length ids == length wrapped_hValues) return ()
+ let hValues = [unsafeCoerce# hv | O hv <- wrapped_hValues]
+ handleBreakpoint handler session (zip ids hValues) site locmsg b
+
+jumpAutoFunction session handler ptr hValues siteInfo locmsg b
+ | site <- mkSite siteInfo
+ = unsafePerformIO $ do
+ break <- isAutoBkptEnabled handler session site
+ if break
+ then jumpFunctionM session handler ptr hValues site locmsg b
+ else return b
+
+jumpStepByStepFunction session handler ptr hValues siteInfo locmsg b
+ | site <- mkSite siteInfo
+ = unsafePerformIO $ do
+ jumpFunctionM session handler ptr hValues site locmsg b
+
+mkSite :: SiteInfo -> BkptLocation Module
+mkSite (pkgName, modName, sitenum) =
+ (mkModule (stringToPackageId pkgName) (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