X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=d34b0f3b5b7a9aeaac6c4f9e0553f07835f7d799;hb=85174045bbcc05adb28447d423794d1f087da59e;hp=c292cf013d2abd1ce253507642215d68486a197d;hpb=ead424357937b23f30295608b467aacbc3a8a8bc;p=ghc-hetmet.git diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index c292cf0..d34b0f3 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -59,6 +59,9 @@ module GHC ( modInfoInstances, modInfoIsExportedName, modInfoLookupName, +#if defined(GHCI) + modInfoBkptSites, +#endif lookupGlobalName, -- * Printing @@ -79,11 +82,12 @@ module GHC ( RunResult(..), runStmt, showModule, + isModuleInterpreted, compileExpr, HValue, dynCompileExpr, lookupName, getBreakpointHandler, setBreakpointHandler, - obtainTerm, + obtainTerm, obtainTerm1, #endif -- * Abstract syntax elements @@ -139,7 +143,8 @@ module GHC ( instanceDFunId, pprInstance, pprInstanceHdr, -- ** Types and Kinds - Type, dropForAlls, splitForAllTys, funResultTy, pprParendType, + Type, dropForAlls, splitForAllTys, funResultTy, + pprParendType, pprTypeApp, Kind, PredType, ThetaType, pprThetaArrow, @@ -177,6 +182,7 @@ module GHC ( #include "HsVersions.h" #ifdef GHCI +import RtClosureInspect ( cvObtainTerm, Term ) import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo, tcRnLookupName, getModuleExports ) import RdrName ( plusGlobalRdrEnv, Provenance(..), @@ -185,6 +191,7 @@ 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# ) @@ -203,7 +210,6 @@ import Data.Maybe ( fromMaybe) import qualified Linker import Data.Dynamic ( Dynamic ) -import RtClosureInspect ( cvObtainTerm, Term ) import Linker ( HValue, getHValue, extendLinkEnv ) #endif @@ -215,14 +221,14 @@ import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..), 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, isPrimOpId, isFCallId, isClassOpId_maybe, isDataConWorkId, idDataCon, isBottomingId ) -import Var ( TyVar, varName ) +import Var ( TyVar ) import TysPrim ( alphaTyVars ) import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, isOpenTyCon, tyConArity, @@ -249,7 +255,7 @@ import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept, cleanTempDirs ) import Module import UniqFM -import PackageConfig ( PackageId, stringToPackageId ) +import PackageConfig ( PackageId, stringToPackageId, mainPackageId ) import FiniteMap import Panic import Digraph @@ -277,7 +283,6 @@ import System.Exit ( exitWith, ExitCode(..) ) 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) @@ -334,9 +339,8 @@ defaultErrorHandler dflags inner = 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 @@ -849,6 +853,9 @@ checkModule session@(Session ref) mod = do 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, @@ -1758,6 +1765,9 @@ data ModuleInfo = ModuleInfo { 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 @@ -1796,7 +1806,8 @@ getPackageModuleInfo hsc_env mdl = do 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) @@ -1813,6 +1824,9 @@ getHomeModuleInfo hsc_env mdl = 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 @@ -1846,6 +1860,10 @@ modInfoLookupName s minf name = withSession s $ \hsc_env -> do 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 } @@ -1911,7 +1929,7 @@ findModule' hsc_env mod_name maybe_pkg = 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 $ @@ -2188,19 +2206,31 @@ sandboxIO thing = do 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 @@ -2228,48 +2258,53 @@ reinstallBreakpointHandlers session = do 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 +----------------------------------------------------------------------- +-- Jump functions -jumpCondFunction _ _ _ _ _ _ False b = b -jumpCondFunction session handler ptr hValues siteInfo locmsg True b - = jumpFunction session handler ptr hValues siteInfo locmsg b +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 -jumpFunction session handler ptr hValues siteInfo locmsg 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 ptr hValues site locmsg b + = unsafePerformIO $ jumpFunctionM session handler site args b -jumpFunctionM session handler (I# idsPtr) wrapped_hValues site locmsg b = +jumpFunctionM session handler site (I# idsPtr, wrapped_hValues, locmsg) b = do ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr))) - ASSERT (length ids == length wrapped_hValues) return () - let hValues = [unsafeCoerce# hv | O hv <- wrapped_hValues] + let hValues = unsafeCoerce# b : [unsafeCoerce# hv | O hv <- wrapped_hValues] handleBreakpoint handler session (zip ids hValues) site locmsg b -jumpAutoFunction session handler ptr hValues siteInfo locmsg b +jumpAutoFunction session handler siteInfo args b | site <- mkSite siteInfo = unsafePerformIO $ do break <- isAutoBkptEnabled handler session site if break - then jumpFunctionM session handler ptr hValues site locmsg b + then jumpFunctionM session handler site args b else return b -jumpStepByStepFunction session handler ptr hValues siteInfo locmsg b +jumpStepByStepFunction session handler siteInfo args b | site <- mkSite siteInfo = unsafePerformIO $ do - jumpFunctionM session handler ptr hValues site locmsg b + jumpFunctionM session handler site args b mkSite :: SiteInfo -> BkptLocation Module -mkSite (pkgName, modName, sitenum) = - (mkModule (stringToPackageId pkgName) (mkModuleName modName), sitenum) +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 -> - getHValue (varName id) >>= traverse (cvObtainTerm hsc_env force Nothing) +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 */