X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=ef9fd02c2c01aab5690b588ad32fcaf6d5034a8d;hb=8d5364c135b7d40ae62c63ff9e65c684a1712694;hp=250187afbe16b2640e544a0697289d58fbdde7e9;hpb=0bb19f30a4d773f4dd2f88bc5a3c2bdde2e74df0;p=ghc-hetmet.git diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 250187a..ef9fd02 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -40,6 +40,9 @@ module GHC ( checkModule, CheckedModule(..), TypecheckedSource, ParsedSource, RenamedSource, + -- * Parsing Haddock comments + parseHaddockComment, + -- * Inspecting the module structure of the program ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..), getModuleGraph, @@ -56,6 +59,9 @@ module GHC ( modInfoInstances, modInfoIsExportedName, modInfoLookupName, +#if defined(GHCI) + modInfoBkptSites, +#endif lookupGlobalName, -- * Printing @@ -78,6 +84,9 @@ module GHC ( showModule, compileExpr, HValue, dynCompileExpr, lookupName, + + getBreakpointHandler, setBreakpointHandler, + obtainTerm, #endif -- * Abstract syntax elements @@ -91,7 +100,7 @@ module GHC ( -- ** Names Name, - nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc, + nameModule, pprParenSymName, nameSrcLoc, NamedThing(..), RdrName(Qual,Unqual), @@ -171,9 +180,6 @@ module GHC ( #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(..), @@ -183,7 +189,25 @@ import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType ) 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 ) @@ -191,7 +215,7 @@ import NameSet ( NameSet, nameSetToList, elemNameSet ) import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..), globalRdrEnvElts, extendGlobalRdrEnv, emptyGlobalRdrEnv ) -import HsSyn +import HsSyn import Type ( Kind, Type, dropForAlls, PredType, ThetaType, pprThetaArrow, pprParendType, splitForAllTys, funResultTy ) @@ -201,7 +225,7 @@ import Id ( Id, idType, isImplicitId, isDeadBinder, 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, @@ -212,8 +236,7 @@ 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 ) @@ -244,6 +267,8 @@ import Outputable 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 ) @@ -255,6 +280,7 @@ 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) @@ -321,6 +347,12 @@ defaultCleanupHandler dflags inner = 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 @@ -329,7 +361,7 @@ newSession :: GhcMode -> Maybe FilePath -> IO Session 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 @@ -475,6 +507,12 @@ setGlobalTypeScope session ids 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 @@ -643,6 +681,8 @@ load2 s@(Session ref) how_much mod_graph = do 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 @@ -762,7 +802,8 @@ data CheckedModule = -- 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: @@ -807,9 +848,13 @@ checkModule session@(Session ref) mod = do (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, @@ -1716,9 +1761,12 @@ getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC) -- | 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 @@ -1742,22 +1790,23 @@ getModuleInfo s mdl = withSession s $ \hsc_env -> do 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) @@ -1771,9 +1820,12 @@ getHomeModuleInfo hsc_env mdl = 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 @@ -1807,6 +1859,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 } @@ -1892,7 +1948,7 @@ setContext :: Session -> [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 @@ -1903,7 +1959,7 @@ setContext (Session ref) toplev_mods export_mods = do 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 @@ -1911,8 +1967,8 @@ mkExportEnv hsc_env mods = do 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 @@ -2162,4 +2218,78 @@ showModule s mod_summary = withSession s $ \hsc_env -> do 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 */