X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=00a9339d1575d3ccd33e3888f49231b0e0216d65;hp=eb2ca8e3dd1bab79726e31e6a8e7a4f69962d8a7;hb=1377a164d381adf7e311458f16963548733fcbff;hpb=3c22606bf3114747deeae0a8a1d5832ee834d9d1 diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index eb2ca8e..00a9339 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -15,10 +15,11 @@ module GHC ( -- * Flags and settings DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt, - GhcMode(..), GhcLink(..), + GhcMode(..), GhcLink(..), defaultObjectTarget, parseDynamicFlags, getSessionDynFlags, setSessionDynFlags, + parseStaticFlags, -- * Targets Target(..), TargetId(..), Phase, @@ -38,8 +39,10 @@ module GHC ( depanal, load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal workingDirectoryChanged, - checkModule, CheckedModule(..), + checkModule, checkAndLoadModule, CheckedModule(..), TypecheckedSource, ParsedSource, RenamedSource, + compileToCore, compileToCoreModule, compileToCoreSimplified, + compileCoreToObj, -- * Parsing Haddock comments parseHaddockComment, @@ -55,15 +58,12 @@ module GHC ( getModuleInfo, modInfoTyThings, modInfoTopLevelScope, - modInfoPrintUnqualified, - modInfoExports, + modInfoExports, modInfoInstances, modInfoIsExportedName, modInfoLookupName, -#if defined(GHCI) - modInfoBkptSites, -#endif lookupGlobalName, + mkPrintUnqualifiedForModule, -- * Printing PrintUnqualified, alwaysQualify, @@ -75,20 +75,32 @@ module GHC ( setContext, getContext, getNamesInScope, getRdrNamesInScope, + getGRE, moduleIsInterpreted, getInfo, exprType, typeKind, parseName, - RunResult(..), - runStmt, + RunResult(..), + runStmt, SingleStep(..), + resume, + Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan, + resumeHistory, resumeHistoryIx), + History(historyBreakInfo, historyEnclosingDecl), + GHC.getHistorySpan, getHistoryModule, + getResumeContext, + abandon, abandonAll, + InteractiveEval.back, + InteractiveEval.forward, showModule, isModuleInterpreted, - compileExpr, HValue, dynCompileExpr, + InteractiveEval.compileExpr, HValue, dynCompileExpr, lookupName, - - getBreakpointHandler, setBreakpointHandler, - obtainTerm, obtainTerm1, + GHC.obtainTerm, GHC.obtainTerm1, GHC.obtainTermB, reconstructType, + modInfoModBreaks, + ModBreaks(..), BreakIndex, + BreakInfo(breakInfo_number, breakInfo_module), + BreakArray, setBreakOn, setBreakOff, getBreak, #endif -- * Abstract syntax elements @@ -102,7 +114,7 @@ module GHC ( -- ** Names Name, - nameModule, pprParenSymName, nameSrcLoc, + isExternalName, nameModule, pprParenSymName, nameSrcSpan, NamedThing(..), RdrName(Qual,Unqual), @@ -144,8 +156,8 @@ module GHC ( instanceDFunId, pprInstance, pprInstanceHdr, -- ** Types and Kinds - Type, dropForAlls, splitForAllTys, funResultTy, - pprParendType, pprTypeApp, + Type, splitForAllTys, funResultTy, + pprParendType, pprTypeApp, Kind, PredType, ThetaType, pprThetaArrow, @@ -164,6 +176,14 @@ module GHC ( -- ** Source locations SrcLoc, pprDefnLoc, + mkSrcLoc, isGoodSrcLoc, noSrcLoc, + srcLocFile, srcLocLine, srcLocCol, + SrcSpan, + mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan, + srcSpanStart, srcSpanEnd, + srcSpanFile, + srcSpanStartLine, srcSpanEndLine, + srcSpanStartCol, srcSpanEndCol, -- * Exceptions GhcException(..), showGhcException, @@ -183,80 +203,54 @@ module GHC ( #include "HsVersions.h" #ifdef GHCI -import RtClosureInspect ( cvObtainTerm, Term ) -import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo, - tcRnLookupName, getModuleExports ) -import RdrName ( plusGlobalRdrEnv, Provenance(..), - ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), - mkGlobalRdrEnv ) -import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType ) -import Name ( nameOccName ) -import Type ( tidyType ) -import Var ( varName ) -import VarEnv ( emptyTidyEnv ) -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 ) +import Linker ( HValue ) +import ByteCodeInstr +import BreakArray +import NameSet +import InteractiveEval +import TcRnDriver #endif -import Packages ( initPackages ) -import NameSet ( NameSet, nameSetToList, elemNameSet ) -import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..), - globalRdrEnvElts, extendGlobalRdrEnv, - emptyGlobalRdrEnv ) -import HsSyn -import Type ( Kind, Type, dropForAlls, PredType, ThetaType, - pprThetaArrow, pprParendType, splitForAllTys, - pprTypeApp, funResultTy ) -import Id ( Id, idType, isImplicitId, isDeadBinder, - isExportedId, isLocalId, isGlobalId, - isRecordSelector, recordSelectorFieldLabel, - isPrimOpId, isFCallId, isClassOpId_maybe, - isDataConWorkId, idDataCon, - isBottomingId ) -import Var ( TyVar ) +import TcIface +import TcRnTypes hiding (LIE) +import TcRnMonad ( initIfaceCheck ) +import Packages +import NameSet +import RdrName +import qualified HsSyn -- hack as we want to reexport the whole module +import HsSyn hiding ((<.>)) +import Type hiding (typeKind) +import TcType hiding (typeKind) +import Id +import Var hiding (setIdType) import TysPrim ( alphaTyVars ) -import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon, - 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(..), nameSrcLoc ) +import TyCon +import Class +import FunDeps +import DataCon +import Name hiding ( varName ) import OccName ( parenSymOcc ) -import NameEnv ( nameEnvElts ) -import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr ) +import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr, + emptyInstEnv ) +import FamInstEnv ( emptyFamInstEnv ) import SrcLoc +import CoreSyn +import TidyPgm import DriverPipeline -import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) +import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase ) import HeaderInfo ( getImports, getOptions ) import Finder -import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) ) +import HscMain import HscTypes import DynFlags +import StaticFlags import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept, cleanTempDirs ) import Module -import UniqFM -import PackageConfig ( PackageId, stringToPackageId, mainPackageId ) +import LazyUniqFM +import UniqSet +import Unique import FiniteMap import Panic import Digraph @@ -269,30 +263,27 @@ import Util import StringBuffer ( StringBuffer, hGetStringBuffer ) import Outputable import BasicTypes -import TcType ( tcSplitSigmaTy, isDictTy ) import Maybes ( expectJust, mapCatMaybes ) -import HaddockParse ( parseHaddockParagraphs, parseHaddockString ) +import HaddockParse import HaddockLex ( tokenise ) +import FastString import Control.Concurrent -import System.Directory ( getModificationTime, doesFileExist ) -import Data.Maybe ( isJust, isNothing ) -import Data.List ( partition, nub ) +import System.Directory ( getModificationTime, doesFileExist, + getCurrentDirectory ) +import Data.Maybe +import Data.List import qualified Data.List as List -import Control.Monad ( unless, when ) +import Control.Monad import System.Exit ( exitWith, ExitCode(..) ) -import System.Time ( ClockTime ) +import System.Time ( ClockTime, getClockTime ) import Control.Exception as Exception hiding (handle) import Data.IORef +import System.FilePath import System.IO -import System.IO.Error ( isDoesNotExistError ) +import System.IO.Error ( try, isDoesNotExistError ) import Prelude hiding (init) -#if __GLASGOW_HASKELL__ < 600 -import System.IO as System.IO.Error ( try ) -#else -import System.IO.Error ( try ) -#endif -- ----------------------------------------------------------------------------- -- Exception handlers @@ -349,14 +340,9 @@ 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: explain argument [[mb_top_dir]] newSession :: Maybe FilePath -> IO Session newSession mb_top_dir = do -- catch ^C @@ -364,6 +350,7 @@ newSession mb_top_dir = do modifyMVar_ interruptTargetThread (return . (main_thread :)) installSignalHandlers + initStaticOpts dflags0 <- initSysTools mb_top_dir defaultDynFlags dflags <- initDynFlags dflags0 env <- newHscEnv dflags @@ -375,12 +362,6 @@ newSession mb_top_dir = do sessionHscEnv :: Session -> IO HscEnv sessionHscEnv (Session ref) = readIORef ref -withSession :: Session -> (HscEnv -> IO a) -> IO a -withSession (Session ref) f = do h <- readIORef ref; f h - -modifySession :: Session -> (HscEnv -> HscEnv) -> IO () -modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h - -- ----------------------------------------------------------------------------- -- Flags & settings @@ -417,7 +398,7 @@ guessOutputFile s = modifySession s $ \env -> let isMain = (== mainModIs dflags) . ms_mod [ms] <- return (filter isMain mod_graph) ml_hs_file (ms_location ms) - guessedName = fmap basenameOf mainModuleSrcPath + guessedName = fmap dropExtension mainModuleSrcPath in case outputFile dflags of Just _ -> env @@ -478,8 +459,8 @@ guessTarget file Nothing else do return (Target (TargetModule (mkModuleName file)) Nothing) where - hs_file = file `joinFileExt` "hs" - lhs_file = file `joinFileExt` "lhs" + hs_file = file <.> "hs" + lhs_file = file <.> "lhs" -- ----------------------------------------------------------------------------- -- Extending the program scope @@ -510,7 +491,10 @@ setGlobalTypeScope session ids -- Parsing Haddock comments parseHaddockComment :: String -> Either String (HsDoc RdrName) -parseHaddockComment string = parseHaddockParagraphs (tokenise string) +parseHaddockComment string = + case parseHaddockParagraphs (tokenise string) of + MyLeft x -> Left x + MyRight x -> Right x -- ----------------------------------------------------------------------------- -- Loading the program @@ -522,7 +506,6 @@ depanal (Session ref) excluded_mods allow_dup_roots = do hsc_env <- readIORef ref let dflags = hsc_dflags hsc_env - gmode = ghcMode (hsc_dflags hsc_env) targets = hsc_targets hsc_env old_graph = hsc_mod_graph hsc_env @@ -569,17 +552,24 @@ load s@(Session ref) how_much -- graph is still retained in the Session. We can tell which modules -- were successfully loaded by inspecting the Session's HPT. mb_graph <- depanal s [] False - case mb_graph of - Just mod_graph -> load2 s how_much mod_graph + case mb_graph of + Just mod_graph -> catchingFailure $ load2 s how_much mod_graph Nothing -> return Failed - + where catchingFailure f = f `Exception.catch` \e -> do + hsc_env <- readIORef ref + -- trac #1565 / test ghci021: + -- let bindings may explode if we try to use them after + -- failing to reload + writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext } + throw e + +load2 :: Session -> LoadHowMuch -> [ModSummary] -> IO SuccessFlag load2 s@(Session ref) how_much mod_graph = do guessOutputFile s hsc_env <- readIORef ref let hpt1 = hsc_HPT hsc_env let dflags = hsc_dflags hsc_env - let ghci_mode = ghcMode dflags -- this never changes -- The "bad" boot modules are the ones for which we have -- B.hs-boot in the module graph, but no B.hs @@ -587,10 +577,8 @@ load2 s@(Session ref) how_much mod_graph = do -- (see msDeps) let all_home_mods = [ms_mod_name s | s <- mod_graph, not (isBootSummary s)] -#ifdef DEBUG bad_boot_mods = [s | s <- mod_graph, isBootSummary s, not (ms_mod_name s `elem` all_home_mods)] -#endif ASSERT( null bad_boot_mods ) return () -- mg2_with_srcimps drops the hi-boot nodes, returning a @@ -659,9 +647,9 @@ load2 s@(Session ref) how_much mod_graph = do -- short of the specified module (unless the specified module -- is stable). partial_mg - | LoadDependenciesOf mod <- how_much + | LoadDependenciesOf _mod <- how_much = ASSERT( case last partial_mg0 of - AcyclicSCC ms -> ms_mod_name ms == mod; _ -> False ) + AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) List.init partial_mg0 | otherwise = partial_mg0 @@ -763,7 +751,8 @@ load2 s@(Session ref) how_much mod_graph = do -- Finish up after a load. -- If the link failed, unload everything and return. -loadFinish all_ok Failed ref hsc_env +loadFinish :: SuccessFlag -> SuccessFlag -> IORef HscEnv -> HscEnv -> IO SuccessFlag +loadFinish _all_ok Failed ref hsc_env = do unload hsc_env [] writeIORef ref $! discardProg hsc_env return Failed @@ -785,6 +774,7 @@ discardProg hsc_env -- used to fish out the preprocess output files for the purposes of -- cleaning up. The preprocessed file *might* be the same as the -- source file, but that doesn't do any harm. +ppFilesFromSummaries :: [ModSummary] -> [FilePath] ppFilesFromSummaries summaries = map ms_hspp_file summaries -- ----------------------------------------------------------------------------- @@ -794,7 +784,8 @@ data CheckedModule = CheckedModule { parsedSource :: ParsedSource, renamedSource :: Maybe RenamedSource, typecheckedSource :: Maybe TypecheckedSource, - checkedModuleInfo :: Maybe ModuleInfo + checkedModuleInfo :: Maybe ModuleInfo, + coreModule :: Maybe ModGuts } -- ToDo: improvements that could be made here: -- if the module succeeded renaming but not typechecking, @@ -821,32 +812,54 @@ type TypecheckedSource = LHsBinds Id -- | This is the way to get access to parsed and typechecked source code --- for a module. 'checkModule' loads all the dependencies of the specified --- module in the Session, and then attempts to typecheck the module. If +-- for a module. 'checkModule' attempts to typecheck the module. If -- successful, it returns the abstract syntax for the module. -checkModule :: Session -> ModuleName -> IO (Maybe CheckedModule) -checkModule session@(Session ref) mod = do - -- load up the dependencies first - r <- load session (LoadDependenciesOf mod) - if (failed r) then return Nothing else do - - -- now parse & typecheck the module +-- If compileToCore is true, it also desugars the module and returns the +-- resulting Core bindings as a component of the CheckedModule. +checkModule :: Session -> ModuleName -> Bool -> IO (Maybe CheckedModule) +checkModule (Session ref) mod compile_to_core + = do hsc_env <- readIORef ref let mg = hsc_mod_graph hsc_env case [ ms | ms <- mg, ms_mod_name ms == mod ] of [] -> return Nothing - (ms:_) -> do - mbChecked <- hscFileCheck hsc_env{hsc_dflags=ms_hspp_opts ms} ms - case mbChecked of + (ms:_) -> checkModule_ ref ms compile_to_core False + +-- | parses and typechecks a module, optionally generates Core, and also +-- loads the module into the 'Session' so that modules which depend on +-- this one may subsequently be typechecked using 'checkModule' or +-- 'checkAndLoadModule'. If you need to check more than one module, +-- you probably want to use 'checkAndLoadModule'. Constructing the +-- interface takes a little work, so it might be slightly slower than +-- 'checkModule'. +checkAndLoadModule :: Session -> ModSummary -> Bool -> IO (Maybe CheckedModule) +checkAndLoadModule (Session ref) ms compile_to_core + = checkModule_ ref ms compile_to_core True + +checkModule_ :: IORef HscEnv -> ModSummary -> Bool -> Bool + -> IO (Maybe CheckedModule) +checkModule_ ref ms compile_to_core load + = do + let mod = ms_mod_name ms + hsc_env0 <- readIORef ref + let hsc_env = hsc_env0{hsc_dflags=ms_hspp_opts ms} + mb_parsed <- parseFile hsc_env ms + case mb_parsed of Nothing -> return Nothing - Just (HscChecked parsed renamed Nothing) -> - return (Just (CheckedModule { - parsedSource = parsed, - renamedSource = renamed, - typecheckedSource = Nothing, - checkedModuleInfo = Nothing })) - Just (HscChecked parsed renamed - (Just (tc_binds, rdr_env, details))) -> do + Just rdr_module -> do + mb_typechecked <- typecheckRenameModule hsc_env ms rdr_module + case mb_typechecked of + Nothing -> return (Just CheckedModule { + parsedSource = rdr_module, + renamedSource = Nothing, + typecheckedSource = Nothing, + checkedModuleInfo = Nothing, + coreModule = Nothing }) + Just (tcg, rn_info) -> do + details <- makeSimpleDetails hsc_env tcg + + let tc_binds = tcg_binds tcg + let rdr_env = tcg_rdr_env tcg let minf = ModuleInfo { minf_type_env = md_types details, minf_exports = availsToNameSet $ @@ -854,14 +867,167 @@ checkModule session@(Session ref) mod = do minf_rdr_env = Just rdr_env, minf_instances = md_insts details #ifdef GHCI - ,minf_dbg_sites = noDbgSites + ,minf_modBreaks = emptyModBreaks #endif } + + mb_guts <- if compile_to_core + then deSugarModule hsc_env ms tcg + else return Nothing + + -- If we are loading this module so that we can typecheck + -- dependent modules, generate an interface and stuff it + -- all in the HomePackageTable. + when load $ do + (iface,_) <- makeSimpleIface hsc_env Nothing tcg details + let mod_info = HomeModInfo { + hm_iface = iface, + hm_details = details, + hm_linkable = Nothing } + let hpt_new = addToUFM (hsc_HPT hsc_env) mod mod_info + writeIORef ref hsc_env0{ hsc_HPT = hpt_new } + return (Just (CheckedModule { - parsedSource = parsed, - renamedSource = renamed, + parsedSource = rdr_module, + renamedSource = rn_info, typecheckedSource = Just tc_binds, - checkedModuleInfo = Just minf })) + checkedModuleInfo = Just minf, + coreModule = mb_guts })) + +-- | This is the way to get access to the Core bindings corresponding +-- to a module. 'compileToCore' invokes 'checkModule' to parse, typecheck, and +-- desugar the module, then returns the resulting Core module (consisting of +-- the module name, type declarations, and function declarations) if +-- successful. +compileToCoreModule :: Session -> FilePath -> IO (Maybe CoreModule) +compileToCoreModule = compileCore False + +-- | Like compileToCoreModule, but invokes the simplifier, so +-- as to return simplified and tidied Core. +compileToCoreSimplified :: Session -> FilePath -> IO (Maybe CoreModule) +compileToCoreSimplified = compileCore True + +-- | Provided for backwards-compatibility: compileToCore returns just the Core +-- bindings, but for most purposes, you probably want to call +-- compileToCoreModule. +compileToCore :: Session -> FilePath -> IO (Maybe [CoreBind]) +compileToCore session fn = do + maybeCoreModule <- compileToCoreModule session fn + return $ fmap cm_binds maybeCoreModule + +-- | Takes a CoreModule and compiles the bindings therein +-- to object code. The first argument is a bool flag indicating +-- whether to run the simplifier. +-- The resulting .o, .hi, and executable files, if any, are stored in the +-- current directory, and named according to the module name. +-- Returns True iff compilation succeeded. +-- This has only so far been tested with a single self-contained module. +compileCoreToObj :: Bool -> Session -> CoreModule -> IO Bool +compileCoreToObj simplify session cm@(CoreModule{ cm_module = mName }) = do + hscEnv <- sessionHscEnv session + dflags <- getSessionDynFlags session + currentTime <- getClockTime + cwd <- getCurrentDirectory + modLocation <- mkHiOnlyModLocation dflags (hiSuf dflags) cwd + ((moduleNameSlashes . moduleName) mName) + + let modSummary = ModSummary { ms_mod = mName, + ms_hsc_src = ExtCoreFile, + ms_location = modLocation, + -- By setting the object file timestamp to Nothing, + -- we always force recompilation, which is what we + -- want. (Thus it doesn't matter what the timestamp + -- for the (nonexistent) source file is.) + ms_hs_date = currentTime, + ms_obj_date = Nothing, + -- Only handling the single-module case for now, so no imports. + ms_srcimps = [], + ms_imps = [], + -- No source file + ms_hspp_file = "", + ms_hspp_opts = dflags, + ms_hspp_buf = Nothing + } + + mbHscResult <- evalComp + ((if simplify then hscSimplify else return) (mkModGuts cm) + >>= hscNormalIface >>= hscWriteIface >>= hscOneShot) + (CompState{ compHscEnv=hscEnv, + compModSummary=modSummary, + compOldIface=Nothing}) + return $ isJust mbHscResult + +-- Makes a "vanilla" ModGuts. +mkModGuts :: CoreModule -> ModGuts +mkModGuts coreModule = ModGuts { + mg_module = cm_module coreModule, + mg_boot = False, + mg_exports = [], + mg_deps = noDependencies, + mg_dir_imps = emptyModuleEnv, + mg_used_names = emptyNameSet, + mg_rdr_env = emptyGlobalRdrEnv, + mg_fix_env = emptyFixityEnv, + mg_types = emptyTypeEnv, + mg_insts = [], + mg_fam_insts = [], + mg_rules = [], + mg_binds = cm_binds coreModule, + mg_foreign = NoStubs, + mg_deprecs = NoDeprecs, + mg_hpc_info = emptyHpcInfo False, + mg_modBreaks = emptyModBreaks, + mg_vect_info = noVectInfo, + mg_inst_env = emptyInstEnv, + mg_fam_inst_env = emptyFamInstEnv +} + +compileCore :: Bool -> Session -> FilePath -> IO (Maybe CoreModule) +compileCore simplify session fn = do + -- First, set the target to the desired filename + target <- guessTarget fn Nothing + addTarget session target + load session LoadAllTargets + -- Then find dependencies + maybeModGraph <- depanal session [] True + case maybeModGraph of + Nothing -> return Nothing + Just modGraph -> do + case find ((== fn) . msHsFilePath) modGraph of + Just modSummary -> do + -- Now we have the module name; + -- parse, typecheck and desugar the module + let mod = ms_mod_name modSummary + maybeCheckedModule <- checkModule session mod True + case maybeCheckedModule of + Nothing -> return Nothing + Just checkedMod -> (liftM $ fmap gutsToCoreModule) $ + case (coreModule checkedMod) of + Just mg | simplify -> (sessionHscEnv session) + -- If simplify is true: simplify (hscSimplify), + -- then tidy (tidyProgram). + >>= \ hscEnv -> evalComp (hscSimplify mg) + (CompState{ compHscEnv=hscEnv, + compModSummary=modSummary, + compOldIface=Nothing}) + >>= (tidyProgram hscEnv) + >>= (return . Just . Left) + Just guts -> return $ Just $ Right guts + Nothing -> return Nothing + Nothing -> panic "compileToCoreModule: target FilePath not found in\ + module dependency graph" + where -- two versions, based on whether we simplify (thus run tidyProgram, + -- which returns a (CgGuts, ModDetails) pair, or not (in which case + -- we just have a ModGuts. + gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule + gutsToCoreModule (Left (cg, md)) = CoreModule { + cm_module = cg_module cg, cm_types = md_types md, + cm_imports = cg_dir_imps cg, cm_binds = cg_binds cg + } + gutsToCoreModule (Right mg) = CoreModule { + cm_module = mg_module mg, cm_types = mg_types mg, + cm_imports = moduleEnvKeys (mg_dir_imps mg), cm_binds = mg_binds mg + } -- --------------------------------------------------------------------------- -- Unloading @@ -873,8 +1039,10 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables #else LinkInMemory -> panic "unload: no interpreter" + -- urgh. avoid warnings: + hsc_env stable_linkables #endif - other -> return () + _other -> return () -- ----------------------------------------------------------------------------- -- checkStability @@ -1030,7 +1198,7 @@ findPartiallyCompletedCycles modsDone theGraph = chew theGraph where chew [] = [] - chew ((AcyclicSCC v):rest) = chew rest -- acyclic? not interesting. + chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting. chew ((CyclicSCC vs):rest) = let names_in_this_cycle = nub (map ms_mod vs) mods_in_this_cycle @@ -1061,19 +1229,21 @@ upsweep HscEnv, -- With an updated HPT [ModSummary]) -- Mods which succeeded -upsweep hsc_env old_hpt stable_mods cleanup mods - = upsweep' hsc_env old_hpt stable_mods cleanup mods 1 (length mods) +upsweep hsc_env old_hpt stable_mods cleanup sccs = do + (res, hsc_env, done) <- upsweep' hsc_env old_hpt [] sccs 1 (length sccs) + return (res, hsc_env, reverse done) + where -upsweep' hsc_env old_hpt stable_mods cleanup + upsweep' hsc_env _old_hpt done [] _ _ - = return (Succeeded, hsc_env, []) + = return (Succeeded, hsc_env, done) -upsweep' hsc_env old_hpt stable_mods cleanup + upsweep' hsc_env _old_hpt done (CyclicSCC ms:_) _ _ = do fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms) - return (Failed, hsc_env, []) + return (Failed, hsc_env, done) -upsweep' hsc_env old_hpt stable_mods cleanup + upsweep' hsc_env old_hpt done (AcyclicSCC mod:mods) mod_index nmods = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ -- show (map (moduleUserString.moduleName.mi_module.hm_iface) @@ -1085,28 +1255,31 @@ upsweep' hsc_env old_hpt stable_mods cleanup cleanup -- Remove unwanted tmp files between compilations case mb_mod_info of - Nothing -> return (Failed, hsc_env, []) + Nothing -> return (Failed, hsc_env, done) Just mod_info -> do - { let this_mod = ms_mod_name mod + let this_mod = ms_mod_name mod -- Add new info to hsc_env - hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info - hsc_env1 = hsc_env { hsc_HPT = hpt1 } + hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info + hsc_env1 = hsc_env { hsc_HPT = hpt1 } -- Space-saving: delete the old HPT entry -- for mod BUT if mod is a hs-boot -- node, don't delete it. For the -- interface, the HPT entry is probaby for the -- main Haskell source file. Deleting it - -- would force .. (what?? --SDM) - old_hpt1 | isBootSummary mod = old_hpt - | otherwise = delFromUFM old_hpt this_mod + -- would force the real module to be recompiled + -- every time. + old_hpt1 | isBootSummary mod = old_hpt + | otherwise = delFromUFM old_hpt this_mod + + done' = mod:done - ; (restOK, hsc_env2, modOKs) - <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup - mods (mod_index+1) nmods - ; return (restOK, hsc_env2, mod:modOKs) - } + -- fixup our HomePackageTable after we've finished compiling + -- a mutually-recursive loop. See reTypecheckLoop, below. + hsc_env2 <- reTypecheckLoop hsc_env1 mod done' + + upsweep' hsc_env2 old_hpt1 done' mods (mod_index+1) nmods -- Compile a single module. Always produce a Linkable for it if @@ -1170,12 +1343,10 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods iface = hm_iface hm_info compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo) - compile_it = upsweep_compile hsc_env old_hpt this_mod_name - summary' mod_index nmods mb_old_iface + compile_it = compile hsc_env summary' mod_index nmods mb_old_iface compile_it_discard_iface - = upsweep_compile hsc_env old_hpt this_mod_name - summary' mod_index nmods Nothing + = compile hsc_env summary' mod_index nmods Nothing in case target of @@ -1237,28 +1408,6 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods compile_it Nothing --- Run hsc to compile a module -upsweep_compile hsc_env old_hpt this_mod summary - mod_index nmods - mb_old_iface - mb_old_linkable - = do - compresult <- compile hsc_env summary mb_old_linkable mb_old_iface - mod_index nmods - - case compresult of - -- Compilation failed. Compile may still have updated the PCS, tho. - CompErrs -> return Nothing - - -- Compilation "succeeded", and may or may not have returned a new - -- linkable (depending on whether compilation was actually performed - -- or not). - CompOK new_details new_iface new_linkable - -> do let new_info = HomeModInfo { hm_iface = new_iface, - hm_details = new_details, - hm_linkable = new_linkable } - return (Just new_info) - -- Filter modules in the HPT retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable @@ -1269,6 +1418,83 @@ retainInTopLevelEnvs keep_these hpt , isJust mb_mod_info ] -- --------------------------------------------------------------------------- +-- Typecheck module loops + +{- +See bug #930. This code fixes a long-standing bug in --make. The +problem is that when compiling the modules *inside* a loop, a data +type that is only defined at the top of the loop looks opaque; but +after the loop is done, the structure of the data type becomes +apparent. + +The difficulty is then that two different bits of code have +different notions of what the data type looks like. + +The idea is that after we compile a module which also has an .hs-boot +file, we re-generate the ModDetails for each of the modules that +depends on the .hs-boot file, so that everyone points to the proper +TyCons, Ids etc. defined by the real module, not the boot module. +Fortunately re-generating a ModDetails from a ModIface is easy: the +function TcIface.typecheckIface does exactly that. + +Picking the modules to re-typecheck is slightly tricky. Starting from +the module graph consisting of the modules that have already been +compiled, we reverse the edges (so they point from the imported module +to the importing module), and depth-first-search from the .hs-boot +node. This gives us all the modules that depend transitively on the +.hs-boot module, and those are exactly the modules that we need to +re-typecheck. + +Following this fix, GHC can compile itself with --make -O2. +-} + +reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv +reTypecheckLoop hsc_env ms graph + | not (isBootSummary ms) && + any (\m -> ms_mod m == this_mod && isBootSummary m) graph + = do + let mss = reachableBackwards (ms_mod_name ms) graph + non_boot = filter (not.isBootSummary) mss + debugTraceMsg (hsc_dflags hsc_env) 2 $ + text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot) + typecheckLoop hsc_env (map ms_mod_name non_boot) + | otherwise + = return hsc_env + where + this_mod = ms_mod ms + +typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv +typecheckLoop hsc_env mods = do + new_hpt <- + fixIO $ \new_hpt -> do + let new_hsc_env = hsc_env{ hsc_HPT = new_hpt } + mds <- initIfaceCheck new_hsc_env $ + mapM (typecheckIface . hm_iface) hmis + let new_hpt = addListToUFM old_hpt + (zip mods [ hmi{ hm_details = details } + | (hmi,details) <- zip hmis mds ]) + return new_hpt + return hsc_env{ hsc_HPT = new_hpt } + where + old_hpt = hsc_HPT hsc_env + hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods + +reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary] +reachableBackwards mod summaries + = [ ms | (ms,_,_) <- map vertex_fn nodes_we_want ] + where + -- all the nodes reachable by traversing the edges backwards + -- from the root node: + nodes_we_want = reachable (transposeG graph) root + + -- the rest just sets up the graph: + (nodes, lookup_key) = moduleGraphNodes False summaries + (graph, vertex_fn, key_fn) = graphFromEdges' nodes + root + | Just key <- lookup_key HsBootFile mod, Just v <- key_fn key = v + | otherwise = panic "reachableBackwards" + +-- --------------------------------------------------------------------------- -- Topological sort of the module graph topSortModuleGraph @@ -1365,9 +1591,6 @@ mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries] nodeMapElts :: NodeMap a -> [a] nodeMapElts = eltsFM -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 @@ -1377,11 +1600,11 @@ 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, + [ warn i | m <- ms, i <- ms_srcimps m, unLoc i `notElem` mods_in_this_cycle ] - warn :: ModSummary -> Located ModuleName -> WarnMsg - warn ms (L loc mod) = + warn :: Located ModuleName -> WarnMsg + warn (L loc mod) = mkPlainErrMsg loc (ptext SLIT("Warning: {-# SOURCE #-} unnecessary in import of ") <+> quotes (ppr mod)) @@ -1551,7 +1774,7 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf (dflags', hspp_fn, buf) <- preprocessFile dflags file mb_phase maybe_buf - (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn + (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file -- Make a ModLocation for this file location <- mkHomeModLocation dflags mod_name file @@ -1581,7 +1804,7 @@ findSummaryBySourceFile summaries file = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of [] -> Nothing - (x:xs) -> Just x + (x:_) -> Just x -- Summarise a module, and pick up source and timestamp. summariseModule @@ -1671,12 +1894,13 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc -- Preprocess the source file and get its imports -- The dflags' contains the OPTIONS pragmas (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf - (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn + (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn when (mod_name /= wanted_mod) $ throwDyn $ mkPlainErrMsg mod_loc $ - text "file name does not match module name" - <+> quotes (ppr mod_name) + text "File name does not match module name:" + $$ text "Saw:" <+> quotes (ppr mod_name) + $$ text "Expected:" <+> quotes (ppr wanted_mod) -- Find the object timestamp, and return the summary obj_timestamp <- getObjTimestamp location is_boot @@ -1693,6 +1917,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc ms_obj_date = obj_timestamp })) +getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime) getObjTimestamp location is_boot = if is_boot then return Nothing else modificationTimeIfExists (ml_obj_file location) @@ -1706,13 +1931,14 @@ preprocessFile dflags src_fn mb_phase Nothing buf <- hGetStringBuffer hspp_fn return (dflags', hspp_fn, buf) -preprocessFile dflags src_fn mb_phase (Just (buf, time)) +preprocessFile dflags src_fn mb_phase (Just (buf, _time)) = do -- case we bypass the preprocessing stage? let local_opts = getOptions buf src_fn -- - (dflags', errs) <- parseDynamicFlags dflags (map unLoc local_opts) + (dflags', _errs) <- parseDynamicFlags dflags (map unLoc local_opts) + -- XXX: shouldn't we be reporting the errors? let needs_preprocessing @@ -1738,14 +1964,17 @@ noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab noModError dflags loc wanted_mod err = throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err +noHsFileErr :: SrcSpan -> String -> a noHsFileErr loc path = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path +packageModErr :: ModuleName -> a packageModErr mod = throwDyn $ mkPlainErrMsg noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "is a package module" multiRootsErr :: [ModSummary] -> IO () +multiRootsErr [] = panic "multiRootsErr" multiRootsErr summs@(summ1:_) = throwDyn $ mkPlainErrMsg noSrcSpan $ text "module" <+> quotes (ppr mod) <+> @@ -1787,10 +2016,22 @@ isLoaded s m = withSession s $ \hsc_env -> return $! isJust (lookupUFM (hsc_HPT hsc_env) m) getBindings :: Session -> IO [TyThing] -getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC) +getBindings s = withSession s $ \hsc_env -> + -- we have to implement the shadowing behaviour of ic_tmp_ids here + -- (see InteractiveContext) and the quickest way is to use an OccEnv. + let + tmp_ids = ic_tmp_ids (hsc_IC hsc_env) + filtered = foldr f (const []) tmp_ids emptyUniqSet + f id rest set + | uniq `elementOfUniqSet` set = rest set + | otherwise = AnId id : rest (addOneToUniqSet set uniq) + where uniq = getUnique (nameOccName (idName id)) + in + return filtered getPrintUnqual :: Session -> IO PrintUnqualified -getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC) +getPrintUnqual s = withSession s $ \hsc_env -> + return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env)) -- | Container for information about a 'Module'. data ModuleInfo = ModuleInfo { @@ -1799,7 +2040,7 @@ data ModuleInfo = ModuleInfo { minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod minf_instances :: [Instance] #ifdef GHCI - ,minf_dbg_sites :: [(SiteNumber,Coord)] + ,minf_modBreaks :: ModBreaks #endif -- ToDo: this should really contain the ModIface too } @@ -1822,8 +2063,8 @@ getModuleInfo s mdl = withSession s $ \hsc_env -> do -- exist... hence the isHomeModule test here. (ToDo: reinstate) getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) -getPackageModuleInfo hsc_env mdl = do #ifdef GHCI +getPackageModuleInfo hsc_env mdl = do (_msgs, mb_avails) <- getModuleExports hsc_env mdl case mb_avails of Nothing -> return Nothing @@ -1840,13 +2081,15 @@ getPackageModuleInfo hsc_env mdl = do minf_exports = names, minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl), minf_instances = error "getModuleInfo: instances for package module unimplemented", - minf_dbg_sites = noDbgSites + minf_modBreaks = emptyModBreaks })) #else +getPackageModuleInfo _hsc_env _mdl = do -- bogusly different for non-GHCI (ToDo) return Nothing #endif +getHomeModuleInfo :: HscEnv -> ModuleName -> IO (Maybe ModuleInfo) getHomeModuleInfo hsc_env mdl = case lookupUFM (hsc_HPT hsc_env) mdl of Nothing -> return Nothing @@ -1858,7 +2101,7 @@ getHomeModuleInfo hsc_env mdl = minf_rdr_env = mi_globals $! hm_iface hmi, minf_instances = md_insts details #ifdef GHCI - ,minf_dbg_sites = md_dbg_sites details + ,minf_modBreaks = getModBreaks hmi #endif })) @@ -1881,8 +2124,9 @@ modInfoInstances = minf_instances modInfoIsExportedName :: ModuleInfo -> Name -> Bool modInfoIsExportedName minf name = elemNameSet name (minf_exports minf) -modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified -modInfoPrintUnqualified minf = fmap mkPrintUnqualified (minf_rdr_env minf) +mkPrintUnqualifiedForModule :: Session -> ModuleInfo -> IO (Maybe PrintUnqualified) +mkPrintUnqualifiedForModule s minf = withSession s $ \hsc_env -> do + return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf)) modInfoLookupName :: Session -> ModuleInfo -> Name -> IO (Maybe TyThing) modInfoLookupName s minf name = withSession s $ \hsc_env -> do @@ -1894,12 +2138,13 @@ modInfoLookupName s minf name = withSession s $ \hsc_env -> do (hsc_HPT hsc_env) (eps_PTE eps) name #ifdef GHCI -modInfoBkptSites = minf_dbg_sites +modInfoModBreaks :: ModuleInfo -> ModBreaks +modInfoModBreaks = minf_modBreaks #endif isDictonaryId :: Id -> Bool isDictonaryId id - = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau } + = case tcSplitSigmaTy (idType id) of { (_tvs, _theta, tau) -> isDictTy tau } -- | Looks up a global name: that is, any top-level name in any -- visible module. Unlike 'lookupName', lookupGlobalName does not use @@ -1911,6 +2156,12 @@ lookupGlobalName s name = withSession s $ \hsc_env -> do return $! lookupType (hsc_dflags hsc_env) (hsc_HPT hsc_env) (eps_PTE eps) name +#ifdef GHCI +-- | get the GlobalRdrEnv for a session +getGRE :: Session -> IO GlobalRdrEnv +getGRE s = withSession s $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env) +#endif + -- ----------------------------------------------------------------------------- -- Misc exported utils @@ -1951,9 +2202,6 @@ getTokenStream :: Session -> Module -> IO [Located Token] -- using the algorithm that is used for an @import@ declaration. findModule :: Session -> ModuleName -> Maybe PackageId -> IO Module findModule s mod_name maybe_pkg = withSession s $ \hsc_env -> - findModule' hsc_env mod_name maybe_pkg - -findModule' hsc_env mod_name maybe_pkg = let dflags = hsc_dflags hsc_env hpt = hsc_HPT hsc_env @@ -1972,372 +2220,20 @@ findModule' hsc_env mod_name maybe_pkg = throwDyn (CmdLineError (showSDoc msg)) #ifdef GHCI +getHistorySpan :: Session -> History -> IO SrcSpan +getHistorySpan sess h = withSession sess $ \hsc_env -> + return$ InteractiveEval.getHistorySpan hsc_env h --- | Set the interactive evaluation context. --- --- Setting the context doesn't throw away any bindings; the bindings --- we've built up in the InteractiveContext simply move to the new --- module. They always shadow anything in scope in the current context. -setContext :: Session - -> [Module] -- entire top level scope of these modules - -> [Module] -- exports only of these modules - -> IO () -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 - -- - export_env <- mkExportEnv hsc_env export_mods - toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods - let all_env = foldr plusGlobalRdrEnv export_env toplev_envs - 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 -mkExportEnv hsc_env mods = do - stuff <- mapM (getModuleExports hsc_env) mods - let - (_msgs, mb_name_sets) = unzip stuff - gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod) - | (Just avails, mod) <- zip mb_name_sets mods ] - -- - return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres - -nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv -nameSetToGlobalRdrEnv names mod = - mkGlobalRdrEnv [ GRE { gre_name = name, gre_prov = vanillaProv mod } - | name <- nameSetToList names ] - -vanillaProv :: ModuleName -> Provenance --- We're building a GlobalRdrEnv as if the user imported --- all the specified modules into the global interactive module -vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] - where - decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, - is_qual = False, - is_dloc = srcLocSpan interactiveSrcLoc } - -mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv -mkTopLevEnv hpt modl - = case lookupUFM hpt (moduleName modl) of - Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++ - showSDoc (ppr modl))) - Just details -> - case mi_globals (hm_iface details) of - Nothing -> - throwDyn (ProgramError ("mkTopLevEnv: not interpreted " - ++ showSDoc (ppr modl))) - Just env -> return env - --- | Get the interactive evaluation context, consisting of a pair of the --- set of modules from which we take the full top-level scope, and the set --- of modules from which we take just the exports respectively. -getContext :: Session -> IO ([Module],[Module]) -getContext s = withSession s (\HscEnv{ hsc_IC=ic } -> - return (ic_toplev_scope ic, ic_exports ic)) - --- | Returns 'True' if the specified module is interpreted, and hence has --- its full top-level scope available. -moduleIsInterpreted :: Session -> Module -> IO Bool -moduleIsInterpreted s modl = withSession s $ \h -> - if modulePackageId modl /= thisPackage (hsc_dflags h) - then return False - else case lookupUFM (hsc_HPT h) (moduleName modl) of - Just details -> return (isJust (mi_globals (hm_iface details))) - _not_a_home_module -> return False - --- | Looks up an identifier in the current interactive context (for :info) -getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance])) -getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name - --- | Returns all names in scope in the current interactive context -getNamesInScope :: Session -> IO [Name] -getNamesInScope s = withSession s $ \hsc_env -> do - return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) - -getRdrNamesInScope :: Session -> IO [RdrName] -getRdrNamesInScope s = withSession s $ \hsc_env -> do - let env = ic_rn_gbl_env (hsc_IC hsc_env) - return (concat (map greToRdrNames (globalRdrEnvElts env))) - --- ToDo: move to RdrName -greToRdrNames :: GlobalRdrElt -> [RdrName] -greToRdrNames GRE{ gre_name = name, gre_prov = prov } - = case prov of - LocalDef -> [unqual] - Imported specs -> concat (map do_spec (map is_decl specs)) - where - occ = nameOccName name - unqual = Unqual occ - do_spec decl_spec - | is_qual decl_spec = [qual] - | otherwise = [unqual,qual] - where qual = Qual (is_as decl_spec) occ - --- | Parses a string as an identifier, and returns the list of 'Name's that --- the identifier can refer to in the current interactive context. -parseName :: Session -> String -> IO [Name] -parseName s str = withSession s $ \hsc_env -> do - maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str - case maybe_rdr_name of - Nothing -> return [] - Just (L _ rdr_name) -> do - mb_names <- tcRnLookupRdrName hsc_env rdr_name - case mb_names of - Nothing -> return [] - Just ns -> return ns - -- ToDo: should return error messages - --- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any --- entity known to GHC, including 'Name's defined using 'runStmt'. -lookupName :: Session -> Name -> IO (Maybe TyThing) -lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name - --- ----------------------------------------------------------------------------- --- Getting the type of an expression - --- | Get the type of an expression -exprType :: Session -> String -> IO (Maybe Type) -exprType s expr = withSession s $ \hsc_env -> do - maybe_stuff <- hscTcExpr hsc_env expr - case maybe_stuff of - Nothing -> return Nothing - Just ty -> return (Just tidy_ty) - where - tidy_ty = tidyType emptyTidyEnv ty - --- ----------------------------------------------------------------------------- --- Getting the kind of a type - --- | Get the kind of a type -typeKind :: Session -> String -> IO (Maybe Kind) -typeKind s str = withSession s $ \hsc_env -> do - maybe_stuff <- hscKcType hsc_env str - case maybe_stuff of - Nothing -> return Nothing - Just kind -> return (Just kind) - ------------------------------------------------------------------------------ --- cmCompileExpr: compile an expression and deliver an HValue - -compileExpr :: Session -> String -> IO (Maybe HValue) -compileExpr s expr = withSession s $ \hsc_env -> do - maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr) - case maybe_stuff of - Nothing -> return Nothing - Just (new_ic, names, hval) -> do - -- Run it! - hvals <- (unsafeCoerce# hval) :: IO [HValue] - - case (names,hvals) of - ([n],[hv]) -> return (Just hv) - _ -> 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 - = RunOk [Name] -- ^ names bound by this evaluation - | RunFailed -- ^ statement failed compilation - | RunException Exception -- ^ statement raised an exception - --- | Run a statement in the current interactive context. Statemenet --- may bind multple values. -runStmt :: Session -> String -> IO RunResult -runStmt (Session ref) expr - = do - hsc_env <- readIORef ref - - -- Turn off -fwarn-unused-bindings when running a statement, to hide - -- warnings about the implicit bindings we introduce. - let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds - hsc_env' = hsc_env{ hsc_dflags = dflags' } - - maybe_stuff <- hscStmt hsc_env' expr - - case maybe_stuff of - Nothing -> return RunFailed - Just (new_hsc_env, names, hval) -> do - - let thing_to_run = unsafeCoerce# hval :: IO [HValue] - either_hvals <- sandboxIO thing_to_run - - case either_hvals of - Left e -> do - -- on error, keep the *old* interactive context, - -- so that 'it' is not bound to something - -- that doesn't exist. - return (RunException e) - - Right hvals -> do - -- Get the newly bound things, and bind them. - -- Don't need to delete any shadowed bindings; - -- the new ones override the old ones. - extendLinkEnv (zip names hvals) - - writeIORef ref new_hsc_env - return (RunOk names) - --- When running a computation, we redirect ^C exceptions to the running --- thread. ToDo: we might want a way to continue even if the target --- thread doesn't die when it receives the exception... "this thread --- is not responding". -sandboxIO :: IO a -> IO (Either Exception a) -sandboxIO thing = do - m <- newEmptyMVar - ts <- takeMVar interruptTargetThread - child <- forkIO (do res <- Exception.try thing; putMVar m res) - putMVar interruptTargetThread (child:ts) - takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail) - -{- --- This version of sandboxIO runs the expression in a completely new --- RTS main thread. It is disabled for now because ^C exceptions --- won't be delivered to the new thread, instead they'll be delivered --- to the (blocked) GHCi main thread. - --- SLPJ: when re-enabling this, reflect a wrong-stat error as an exception - -sandboxIO :: IO a -> IO (Either Int (Either Exception a)) -sandboxIO thing = do - st_thing <- newStablePtr (Exception.try thing) - alloca $ \ p_st_result -> do - stat <- rts_evalStableIO st_thing p_st_result - freeStablePtr st_thing - if stat == 1 - then do st_result <- peek p_st_result - result <- deRefStablePtr st_result - freeStablePtr st_result - return (Right result) - else do - return (Left (fromIntegral stat)) - -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 -> - 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 (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 - -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 (ghcLink dflags == LinkInMemory) $ do - linkEnv <- readIORef v_bkptLinkEnv - initDynLinker dflags - extendLinkEnv linkEnv - ------------------------------------------------------------------------ --- Jump functions - -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 - -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 site args b - -jumpFunctionM session handler site (I# idsPtr, wrapped_hValues, locmsg) b = - do - ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr))) - let hValues = unsafeCoerce# b : [unsafeCoerce# hv | O hv <- wrapped_hValues] - handleBreakpoint handler session (zip ids hValues) site locmsg b - -jumpAutoFunction session handler siteInfo args b - | site <- mkSite siteInfo - = unsafePerformIO $ do - break <- isAutoBkptEnabled handler session site - if break - then jumpFunctionM session handler site args b - else return b - -jumpStepByStepFunction session handler siteInfo args b - | site <- mkSite siteInfo - = unsafePerformIO $ do - jumpFunctionM session handler site args b - -mkSite :: SiteInfo -> BkptLocation Module -mkSite ( modName, sitenum) = - (mkModule mainPackageId (mkModuleName modName), sitenum) +obtainTerm :: Session -> Bool -> Id -> IO Term +obtainTerm sess force id = withSession sess $ \hsc_env -> + InteractiveEval.obtainTerm hsc_env force id 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) +obtainTerm1 sess force mb_ty a = withSession sess $ \hsc_env -> + InteractiveEval.obtainTerm1 hsc_env force mb_ty a -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 +obtainTermB :: Session -> Int -> Bool -> Id -> IO Term +obtainTermB sess bound force id = withSession sess $ \hsc_env -> + InteractiveEval.obtainTermB hsc_env bound force id -#endif /* GHCI */ +#endif