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
showModule,
compileExpr, HValue, dynCompileExpr,
lookupName,
+
+ getBreakpointHandler, setBreakpointHandler,
+ obtainTerm,
#endif
-- * Abstract syntax elements
-- ** Names
Name,
- nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc,
+ nameModule, pprParenSymName, nameSrcLoc,
NamedThing(..),
RdrName(Qual,Unqual),
#include "HsVersions.h"
#ifdef GHCI
-import qualified Linker
-import Data.Dynamic ( Dynamic )
-import Linker ( HValue, extendLinkEnv )
import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo,
tcRnLookupName, getModuleExports )
import RdrName ( plusGlobalRdrEnv, Provenance(..),
import Name ( nameOccName )
import Type ( tidyType )
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 RtClosureInspect ( cvObtainTerm, Term )
+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 )
isPrimOpId, isFCallId, isClassOpId_maybe,
isDataConWorkId, idDataCon,
isBottomingId )
-import Var ( TyVar )
+import Var ( TyVar, varName )
import TysPrim ( alphaTyVars )
import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
isPrimTyCon, isFunTyCon, isOpenTyCon, tyConArity,
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 )
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 )
import System.Time ( ClockTime )
import Control.Exception as Exception hiding (handle)
import Data.IORef
+import Data.Traversable ( traverse )
import System.IO
import System.IO.Error ( isDoesNotExistError )
import Prelude hiding (init)
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
newSession mode 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
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 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,
-- | 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]
+ 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
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)
+
+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