modInfoInstances,
modInfoIsExportedName,
modInfoLookupName,
+#if defined(GHCI)
+ modInfoBkptSites,
+#endif
lookupGlobalName,
-- * Printing
showModule,
compileExpr, HValue, dynCompileExpr,
lookupName,
+
+ getBreakpointHandler, setBreakpointHandler,
+ obtainTerm,
#endif
-- * Abstract syntax elements
#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 )
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 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
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,
minf_type_env :: TypeEnv,
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
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 }
-> [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
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