X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=683bc577744cae58a233e3707ababba877684b71;hp=543d2a940d791cc3af1d9e7feff8fc66f9758ca1;hb=16887826bafb60d504f925d4aa09236c65d01121;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 543d2a9..683bc57 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -11,15 +11,15 @@ module GHC ( Session, defaultErrorHandler, defaultCleanupHandler, - init, initFromArgs, newSession, -- * Flags and settings - DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt, + DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt, + GhcMode(..), GhcLink(..), defaultObjectTarget, parseDynamicFlags, - initPackages, getSessionDynFlags, setSessionDynFlags, + parseStaticFlags, -- * Targets Target(..), TargetId(..), Phase, @@ -41,6 +41,10 @@ module GHC ( workingDirectoryChanged, checkModule, CheckedModule(..), TypecheckedSource, ParsedSource, RenamedSource, + compileToCore, + + -- * Parsing Haddock comments + parseHaddockComment, -- * Inspecting the module structure of the program ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..), @@ -75,11 +79,25 @@ module GHC ( exprType, typeKind, parseName, - RunResult(..), - runStmt, + RunResult(..), + runStmt, SingleStep(..), + resume, + Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan, + resumeHistory, resumeHistoryIx), + History(historyBreakInfo), getHistorySpan, + getResumeContext, + abandon, abandonAll, + InteractiveEval.back, + InteractiveEval.forward, showModule, - compileExpr, HValue, + isModuleInterpreted, + compileExpr, HValue, dynCompileExpr, lookupName, + obtainTerm, obtainTerm1, + modInfoModBreaks, + ModBreaks(..), BreakIndex, + BreakInfo(breakInfo_number, breakInfo_module), + BreakArray, setBreakOn, setBreakOff, getBreak, #endif -- * Abstract syntax elements @@ -93,7 +111,7 @@ module GHC ( -- ** Names Name, - nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc, + isExternalName, nameModule, pprParenSymName, nameSrcSpan, NamedThing(..), RdrName(Qual,Unqual), @@ -111,7 +129,8 @@ module GHC ( TyCon, tyConTyVars, tyConDataCons, tyConArity, isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, - synTyConDefn, synTyConRhs, + isOpenTyCon, + synTyConDefn, synTyConType, synTyConResKind, -- ** Type variables TyVar, @@ -134,7 +153,8 @@ module GHC ( instanceDFunId, pprInstance, pprInstanceHdr, -- ** Types and Kinds - Type, dropForAlls, splitForAllTys, funResultTy, pprParendType, + Type, dropForAlls, splitForAllTys, funResultTy, + pprParendType, pprTypeApp, Kind, PredType, ThetaType, pprThetaArrow, @@ -153,6 +173,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, @@ -166,8 +194,6 @@ module GHC ( ToDo: * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt. - * we need to expose DynFlags, so should parseDynamicFlags really be - part of this interface? * what StaticFlags should we expose, if any? -} @@ -175,95 +201,79 @@ module GHC ( #ifdef GHCI import qualified Linker -import Linker ( HValue, extendLinkEnv ) -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 VarEnv ( emptyTidyEnv ) -import GHC.Exts ( unsafeCoerce# ) +import Linker ( HValue ) +import ByteCodeInstr +import BreakArray +import NameSet +import TcRnDriver +import InteractiveEval #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, - funResultTy ) -import Id ( Id, idType, isImplicitId, isDeadBinder, - isExportedId, isLocalId, isGlobalId, - isRecordSelector, recordSelectorFieldLabel, - isPrimOpId, isFCallId, isClassOpId_maybe, - isDataConWorkId, idDataCon, - isBottomingId ) -import Var ( TyVar ) +import Packages +import NameSet +import RdrName +import HsSyn +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, tyConArity, - tyConTyVars, tyConDataCons, synTyConDefn, synTyConRhs ) -import Class ( Class, classSCTheta, classTvsFds, classMethods ) -import FunDeps ( pprFundeps ) -import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon, - dataConFieldLabels, dataConStrictMarks, - dataConIsInfix, isVanillaDataCon ) -import Name ( Name, nameModule, NamedThing(..), nameParent_maybe, - 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 SrcLoc +import Desugar +import CoreSyn +import TcRnDriver ( tcRnModule ) 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 ( newHscEnv, hscFileCheck, HscChecked(..) ) import HscTypes import DynFlags -import SysTools ( initSysTools, cleanTempFiles ) +import StaticFlags +import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept, + cleanTempDirs ) import Module import UniqFM -import PackageConfig ( PackageId ) +import UniqSet +import Unique +import PackageConfig import FiniteMap import Panic import Digraph -import Bag ( unitBag ) +import Bag ( unitBag, listToBag ) import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg, - mkPlainErrMsg, printBagOfErrors ) + mkPlainErrMsg, printBagOfErrors, printBagOfWarnings, + WarnMsg ) import qualified ErrUtils import Util import StringBuffer ( StringBuffer, hGetStringBuffer ) import Outputable -import SysTools ( cleanTempFilesExcept ) import BasicTypes -import TcType ( tcSplitSigmaTy, isDictTy ) import Maybes ( expectJust, mapCatMaybes ) +import HaddockParse +import HaddockLex ( tokenise ) import Control.Concurrent import System.Directory ( getModificationTime, doesFileExist ) -import Data.Maybe ( isJust, isNothing ) -import Data.List ( partition, nub ) +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 Control.Exception as Exception hiding (handle) import Data.IORef 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 @@ -310,56 +320,29 @@ defaultErrorHandler dflags inner = -- handling, but still get the ordinary cleanup behaviour. defaultCleanupHandler :: DynFlags -> IO a -> IO a defaultCleanupHandler dflags inner = - -- make sure we clean up after ourselves - later (unless (dopt Opt_KeepTmpFiles dflags) $ - cleanTempFiles dflags) - -- exceptions will be blocked while we clean the temporary files, - -- so there shouldn't be any difficulty if we receive further - -- signals. - inner - - --- | Initialises GHC. This must be done /once/ only. Takes the --- TopDir path without the '-B' prefix. - -init :: Maybe String -> IO () -init mbMinusB = do - -- catch ^C - main_thread <- myThreadId - putMVar interruptTargetThread [main_thread] - installSignalHandlers - - dflags0 <- initSysTools mbMinusB defaultDynFlags - writeIORef v_initDynFlags dflags0 - --- | Initialises GHC. This must be done /once/ only. Takes the --- command-line arguments. All command-line arguments which aren't --- understood by GHC will be returned. - -initFromArgs :: [String] -> IO [String] -initFromArgs args - = do init mbMinusB - return argv1 - where -- Grab the -B option if there is one - (minusB_args, argv1) = partition (prefixMatch "-B") args - mbMinusB | null minusB_args - = Nothing - | otherwise - = Just (drop 2 (last minusB_args)) - -GLOBAL_VAR(v_initDynFlags, error "initDynFlags", DynFlags) - -- stores the DynFlags between the call to init and subsequent - -- calls to newSession. + -- make sure we clean up after ourselves + 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 + -- signals. + inner + -- | 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 --- code". -newSession :: GhcMode -> IO Session -newSession mode = do - dflags0 <- readIORef v_initDynFlags - dflags <- initDynFlags dflags0 - env <- newHscEnv dflags{ ghcMode=mode } +newSession :: Maybe FilePath -> IO Session +newSession mb_top_dir = do + -- catch ^C + main_thread <- myThreadId + modifyMVar_ interruptTargetThread (return . (main_thread :)) + installSignalHandlers + + initStaticOpts + dflags0 <- initSysTools mb_top_dir defaultDynFlags + dflags <- initDynFlags dflags0 + env <- newHscEnv dflags ref <- newIORef env return (Session ref) @@ -368,12 +351,6 @@ newSession mode = 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 @@ -381,9 +358,23 @@ modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h getSessionDynFlags :: Session -> IO DynFlags getSessionDynFlags s = withSession s (return . hsc_dflags) --- | Updates the DynFlags in a Session -setSessionDynFlags :: Session -> DynFlags -> IO () -setSessionDynFlags s dflags = modifySession s (\h -> h{ hsc_dflags = dflags }) +-- | Updates the DynFlags in a Session. This also reads +-- the package database (unless it has already been read), +-- and prepares the compilers knowledge about packages. It +-- can be called again to load new packages: just add new +-- package flags to (packageFlags dflags). +-- +-- Returns a list of new packages that may need to be linked in using +-- the dynamic linker (see 'linkPackages') as a result of new package +-- flags. If you are not doing linking or doing static linking, you +-- can ignore the list of packages returned. +-- +setSessionDynFlags :: Session -> DynFlags -> IO [PackageId] +setSessionDynFlags (Session ref) dflags = do + hsc_env <- readIORef ref + (dflags', preload) <- initPackages dflags + writeIORef ref $! hsc_env{ hsc_dflags = dflags' } + return preload -- | If there is no -o option, guess the name of target executable -- by using top-level source file name as a base. @@ -486,6 +477,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 @@ -495,15 +492,13 @@ 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 showPass dflags "Chasing dependencies" - when (gmode == BatchCompile) $ - debugTraceMsg dflags 2 (hcat [ - text "Chasing modules from: ", - hcat (punctuate comma (map pprTarget targets))]) + debugTraceMsg dflags 2 (hcat [ + text "Chasing modules from: ", + hcat (punctuate comma (map pprTarget targets))]) r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots case r of @@ -553,7 +548,6 @@ load2 s@(Session ref) how_much mod_graph = do 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 @@ -575,10 +569,14 @@ load2 s@(Session ref) how_much mod_graph = do let mg2_with_srcimps :: [SCC ModSummary] mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing + -- If we can determine that any of the {-# SOURCE #-} imports + -- are definitely unnecessary, then emit a warning. + warnUnnecessarySourceImports dflags mg2_with_srcimps + + let -- check the stability property for each module. stable_mods@(stable_obj,stable_bco) - | BatchCompile <- ghci_mode = ([],[]) - | otherwise = checkStability hpt1 mg2_with_srcimps all_home_mods + = checkStability hpt1 mg2_with_srcimps all_home_mods -- prune bits of the HPT which are definitely redundant now, -- to save space. @@ -649,6 +647,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 @@ -684,13 +684,16 @@ load2 s@(Session ref) how_much mod_graph = do a_root_is_Main = any ((==main_mod).ms_mod) mod_graph do_linking = a_root_is_Main || no_hs_main - when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $ - debugTraceMsg dflags 1 (text ("Warning: output was redirected with -o, " ++ - "but no output will be generated\n" ++ - "because there is no " ++ moduleNameString (moduleName main_mod) ++ " module.")) + when (ghcLink dflags == LinkBinary + && isJust ofile && not do_linking) $ + debugTraceMsg dflags 1 $ + text ("Warning: output was redirected with -o, " ++ + "but no output will be generated\n" ++ + "because there is no " ++ + moduleNameString (moduleName main_mod) ++ " module.") -- link everything together - linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1) + linkresult <- link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) loadFinish Succeeded linkresult ref hsc_env1 @@ -720,7 +723,7 @@ load2 s@(Session ref) how_much mod_graph = do (eltsUFM (hsc_HPT hsc_env))) do -- Link everything together - linkresult <- link ghci_mode dflags False hpt4 + linkresult <- link (ghcLink dflags) dflags False hpt4 let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 } loadFinish Failed linkresult ref hsc_env4 @@ -768,7 +771,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: @@ -813,9 +817,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_modBreaks = emptyModBreaks +#endif } return (Just (CheckedModule { parsedSource = parsed, @@ -823,20 +831,51 @@ checkModule session@(Session ref) mod = do typecheckedSource = Just tc_binds, checkedModuleInfo = Just minf })) --- --------------------------------------------------------------------------- +-- | This is the way to get access to the Core bindings corresponding +-- to a module. 'compileToCore' first invokes 'checkModule' to parse and +-- typecheck the module, then desugars it and returns the resulting list +-- of Core bindings if successful. It is assumed that the given filename +-- has already been loaded. +compileToCore :: Session -> FilePath -> IO (Maybe [CoreBind]) +compileToCore session@(Session ref) fn = do + hsc_env <- readIORef ref + -- First, determine the module name. + modSummary <- summariseFile hsc_env [] fn Nothing Nothing + let mod = moduleName $ ms_mod modSummary + -- Next, parse and typecheck the module + maybeCheckedModule <- checkModule session mod + case maybeCheckedModule of + Nothing -> return Nothing + Just checkedMod -> do + let parsedMod = parsedSource checkedMod + -- Note: this typechecks the module twice (because checkModule + -- also calls tcRnModule), but arranging for checkModule to + -- return the type env would require changing a lot of data + -- structures, so I'm leaving it like that for now. + (_, maybe_tc_result) <- tcRnModule hsc_env HsSrcFile False parsedMod + -- Get the type environment from the typechecking result + case maybe_tc_result of + -- TODO: this ignores the type error messages and just returns Nothing + Nothing -> return Nothing + Just tcgEnv -> do + let dflags = hsc_dflags hsc_env + -- Finally, compile to Core and return the resulting bindings + maybeModGuts <- deSugar hsc_env (ms_location modSummary) tcgEnv + case maybeModGuts of + Nothing -> return Nothing + Just mg -> return $ Just $ mg_binds mg + -- --------------------------------------------------------------------------- -- Unloading unload :: HscEnv -> [Linkable] -> IO () unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' - = case ghcMode (hsc_dflags hsc_env) of - BatchCompile -> return () - JustTypecheck -> return () + = case ghcLink (hsc_dflags hsc_env) of #ifdef GHCI - Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables + LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables #else - Interactive -> panic "unload: no interpreter" + LinkInMemory -> panic "unload: no interpreter" #endif - other -> panic "unload: strange mode" + other -> return () -- ----------------------------------------------------------------------------- -- checkStability @@ -853,9 +892,6 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' module. So we need to know that we will definitely not be recompiling any of these modules, and we can use the object code. - NB. stability is of no importance to BatchCompile at all, only Interactive. - (ToDo: what about JustTypecheck?) - The stability check is as follows. Both stableObject and stableBCO are used during the upsweep phase later. @@ -874,7 +910,7 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' These properties embody the following ideas: - - if a module is stable: + - if a module is stable, then: - if it has been compiled in a previous pass (present in HPT) then it does not need to be compiled or re-linked. - if it has not been compiled in a previous pass, @@ -1085,95 +1121,133 @@ upsweep_mod :: HscEnv -> IO (Maybe HomeModInfo) -- Nothing => Failed upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods - = do - let - this_mod_name = ms_mod_name summary + = let + this_mod_name = ms_mod_name summary this_mod = ms_mod summary mb_obj_date = ms_obj_date summary obj_fn = ml_obj_file (ms_location summary) hs_date = ms_hs_date summary + is_stable_obj = this_mod_name `elem` stable_obj + is_stable_bco = this_mod_name `elem` stable_bco + + old_hmi = lookupUFM old_hpt this_mod_name + + -- We're using the dflags for this module now, obtained by + -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. + dflags = ms_hspp_opts summary + prevailing_target = hscTarget (hsc_dflags hsc_env) + local_target = hscTarget dflags + + -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that + -- we don't do anything dodgy: these should only work to change + -- from -fvia-C to -fasm and vice-versa, otherwise we could + -- end up trying to link object code to byte code. + target = if prevailing_target /= local_target + && (not (isObjectTarget prevailing_target) + || not (isObjectTarget local_target)) + then prevailing_target + else local_target + + -- store the corrected hscTarget into the summary + summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } } + + -- The old interface is ok if + -- a) we're compiling a source file, and the old HPT + -- entry is for a source file + -- b) we're compiling a hs-boot file + -- Case (b) allows an hs-boot file to get the interface of its + -- real source file on the second iteration of the compilation + -- manager, but that does no harm. Otherwise the hs-boot file + -- will always be recompiled + + mb_old_iface + = case old_hmi of + Nothing -> Nothing + Just hm_info | isBootSummary summary -> Just iface + | not (mi_boot iface) -> Just iface + | otherwise -> Nothing + where + 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 - - case ghcMode (hsc_dflags hsc_env) of - BatchCompile -> - case () of - -- Batch-compilating is easy: just check whether we have - -- an up-to-date object file. If we do, then the compiler - -- needs to do a recompilation check. - _ | Just obj_date <- mb_obj_date, obj_date >= hs_date -> do - linkable <- - findObjectLinkable this_mod obj_fn obj_date - compile_it (Just linkable) - - | otherwise -> - compile_it Nothing - - interactive -> - case () of - _ | is_stable_obj, isJust old_hmi -> - return old_hmi + 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 + + in + case target of + + _any + -- Regardless of whether we're generating object code or + -- byte code, we can always use an existing object file + -- if it is *stable* (see checkStability). + | is_stable_obj, isJust old_hmi -> + return old_hmi -- object is stable, and we have an entry in the -- old HPT: nothing to do - | is_stable_obj, isNothing old_hmi -> do - linkable <- - findObjectLinkable this_mod obj_fn + | is_stable_obj, isNothing old_hmi -> do + linkable <- findObjectLinkable this_mod obj_fn (expectJust "upseep1" mb_obj_date) - compile_it (Just linkable) + compile_it (Just linkable) -- object is stable, but we need to load the interface -- off disk to make a HMI. - | is_stable_bco -> - ASSERT(isJust old_hmi) -- must be in the old_hpt - return old_hmi + HscInterpreted + | is_stable_bco -> + ASSERT(isJust old_hmi) -- must be in the old_hpt + return old_hmi -- BCO is stable: nothing to do - | Just hmi <- old_hmi, - Just l <- hm_linkable hmi, not (isObjectLinkable l), - linkableTime l >= ms_hs_date summary -> - compile_it (Just l) + | Just hmi <- old_hmi, + Just l <- hm_linkable hmi, not (isObjectLinkable l), + linkableTime l >= ms_hs_date summary -> + compile_it (Just l) -- we have an old BCO that is up to date with respect -- to the source: do a recompilation check as normal. - | otherwise -> - compile_it Nothing + | otherwise -> + compile_it Nothing -- no existing code at all: we must recompile. - where - is_stable_obj = this_mod_name `elem` stable_obj - is_stable_bco = this_mod_name `elem` stable_bco - old_hmi = lookupUFM old_hpt this_mod_name + -- When generating object code, if there's an up-to-date + -- object file on the disk, then we can use it. + -- However, if the object file is new (compared to any + -- linkable we had from a previous compilation), then we + -- must discard any in-memory interface, because this + -- means the user has compiled the source file + -- separately and generated a new interface, that we must + -- read from the disk. + -- + obj | isObjectTarget obj, + Just obj_date <- mb_obj_date, obj_date >= hs_date -> do + case old_hmi of + Just hmi + | Just l <- hm_linkable hmi, + isObjectLinkable l && linkableTime l == obj_date + -> compile_it (Just l) + _otherwise -> do + linkable <- findObjectLinkable this_mod obj_fn obj_date + compile_it_discard_iface (Just linkable) + + _otherwise -> + compile_it Nothing + -- Run hsc to compile a module upsweep_compile hsc_env old_hpt this_mod summary mod_index nmods - mb_old_linkable = do - let - -- The old interface is ok if it's in the old HPT - -- a) we're compiling a source file, and the old HPT - -- entry is for a source file - -- b) we're compiling a hs-boot file - -- Case (b) allows an hs-boot file to get the interface of its - -- real source file on the second iteration of the compilation - -- manager, but that does no harm. Otherwise the hs-boot file - -- will always be recompiled - - mb_old_iface - = case lookupUFM old_hpt this_mod of - Nothing -> Nothing - Just hm_info | isBootSummary summary -> Just iface - | not (mi_boot iface) -> Just iface - | otherwise -> Nothing - where - iface = hm_iface hm_info - - compresult <- compile hsc_env summary mb_old_linkable mb_old_iface + mb_old_iface + mb_old_linkable + = do + compresult <- compile hsc_env summary mb_old_linkable mb_old_iface mod_index nmods - case compresult of + case compresult of -- Compilation failed. Compile may still have updated the PCS, tho. CompErrs -> return Nothing @@ -1243,13 +1317,29 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key) -- We use integers as the keys for the SCC algorithm nodes :: [(ModSummary, Int, [Int])] - nodes = [(s, expectJust "topSort" (lookup_key (ms_hsc_src s) (ms_mod_name s)), + nodes = [(s, expectJust "topSort" $ + lookup_key (ms_hsc_src s) (ms_mod_name s), out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++ - out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ) + out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ++ + (-- see [boot-edges] below + if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile + then [] + else case lookup_key HsBootFile (ms_mod_name s) of + Nothing -> [] + Just k -> [k]) + ) | s <- summaries , not (isBootSummary s && drop_hs_boot_nodes) ] -- Drop the hi-boot ones if told to do so + -- [boot-edges] if this is a .hs and there is an equivalent + -- .hs-boot, add a link from the former to the latter. This + -- has the effect of detecting bogus cases where the .hs-boot + -- depends on the .hs, by introducing a cycle. Additionally, + -- it ensures that we will always process the .hs-boot before + -- the .hs, and so the HomePackageTable will always have the + -- most up to date information. + key_map :: NodeMap Int key_map = listToFM ([(moduleName (ms_mod s), ms_hsc_src s) | s <- summaries] @@ -1276,8 +1366,23 @@ 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 +-- were necessary, then the edge would be part of a cycle. +warnUnnecessarySourceImports :: DynFlags -> [SCC ModSummary] -> IO () +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, + unLoc i `notElem` mods_in_this_cycle ] + + warn :: ModSummary -> Located ModuleName -> WarnMsg + warn ms (L loc mod) = + mkPlainErrMsg loc + (ptext SLIT("Warning: {-# SOURCE #-} unnecessary in import of ") + <+> quotes (ppr mod)) ----------------------------------------------------------------------------- -- Downsweep (dependency analysis) @@ -1629,7 +1734,7 @@ preprocessFile dflags src_fn mb_phase (Just (buf, time)) noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab -- ToDo: we don't have a proper line number for this error noModError dflags loc wanted_mod err - = throwDyn $ mkPlainErrMsg loc $ cantFindError dflags wanted_mod err + = throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err noHsFileErr loc path = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path @@ -1680,7 +1785,18 @@ 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) @@ -1688,9 +1804,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] +#ifdef GHCI + ,minf_modBreaks :: ModBreaks +#endif -- ToDo: this should really contain the ModIface too } -- We don't want HomeModInfo here, because a ModuleInfo applies @@ -1714,22 +1833,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_modBreaks = emptyModBreaks })) #else -- bogusly different for non-GHCI (ToDo) @@ -1743,9 +1863,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_modBreaks = md_modBreaks details +#endif })) -- | The list of top-level entities defined in a module @@ -1779,6 +1902,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 +modInfoModBreaks = minf_modBreaks +#endif + isDictonaryId :: Id -> Bool isDictonaryId id = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau } @@ -1844,271 +1971,11 @@ 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 - -- not allowed to be a home module - err -> let msg = cantFindError dflags mod_name err in + | otherwise -> throwDyn (CmdLineError (showSDoc $ + text "module" <+> pprModule m <+> + text "is not loaded")) + err -> let msg = cannotFindModule dflags mod_name err in throwDyn (CmdLineError (showSDoc msg)) - -#ifdef GHCI - --- | 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 (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 }} - - --- 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 name_set (moduleName mod) - | (Just name_set, 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" - --- ----------------------------------------------------------------------------- --- 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! --} - ------------------------------------------------------------------------------ --- show a module and it's source/object filenames - -showModule :: Session -> ModSummary -> IO String -showModule s mod_summary = withSession s $ \hsc_env -> do - 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) - where - obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info)) - -#endif /* GHCI */