X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FGHC.hs;h=6ce921de3f27e98c8a59ab7c5975da80217d79c5;hb=e7da484086a7be73dbd0747b945fe63e7cd53ed0;hp=8cf3c2474ecc266ae833ad8c942625c6eda96603;hpb=069370a53a92a68a6df163f07cec47b3d62632e7;p=ghc-hetmet.git diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index 8cf3c24..6ce921d 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -17,36 +17,52 @@ module GHC ( -- * Flags and settings DynFlags(..), DynFlag(..), GhcMode(..), HscTarget(..), dopt, parseDynamicFlags, + initPackages, getSessionDynFlags, setSessionDynFlags, setMsgHandler, -- * Targets - Target(..), + Target(..), TargetId(..), setTargets, getTargets, addTarget, + removeTarget, guessTarget, - -- * Loading/compiling the program + -- * Loading\/compiling the program depanal, - load, SuccessFlag(..), -- also does depanal + load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal + loadMsgs, workingDirectoryChanged, + checkModule, CheckedModule(..), + TypecheckedSource, ParsedSource, -- * Inspecting the module structure of the program ModuleGraph, ModSummary(..), getModuleGraph, + isLoaded, topSortModuleGraph, + -- * Inspecting modules + ModuleInfo, + getModuleInfo, + modInfoTyThings, + modInfoTopLevelScope, + modInfoPrintUnqualified, + modInfoExports, + lookupName, + -- * Interactive evaluation getBindings, getPrintUnqual, #ifdef GHCI setContext, getContext, + getNamesInScope, moduleIsInterpreted, getInfo, GetInfoResult, exprType, typeKind, - lookupName, + parseName, RunResult(..), runStmt, browseModule, @@ -55,14 +71,44 @@ module GHC ( #endif -- * Abstract syntax elements + + -- ** Modules Module, mkModule, pprModule, + + -- ** Names + Name, + + -- ** Identifiers + Id, idType, + isImplicitId, isDeadBinder, + isSpecPragmaId, isExportedId, isLocalId, isGlobalId, + isRecordSelector, + isPrimOpId, isFCallId, + isDataConWorkId, idDataCon, + isBottomingId, isDictonaryId, + + -- ** Type constructors + TyCon, + isClassTyCon, isSynTyCon, isNewTyCon, + + -- ** Data constructors + DataCon, + + -- ** Classes + Class, + classSCTheta, classTvsFds, + + -- ** Types and Kinds Type, dropForAlls, Kind, - Name, Id, TyCon, Class, DataCon, + + -- ** Entities TyThing(..), - idType, - -- used by DriverMkDepend: + -- * Exceptions + GhcException(..), showGhcException, + + -- * Miscellaneous sessionHscEnv, cyclicModuleErr, ) where @@ -85,9 +131,9 @@ module GHC ( import qualified Linker import Linker ( HValue, extendLinkEnv ) import NameEnv ( lookupNameEnv ) -import TcRnDriver ( mkExportEnv, getModuleContents ) -import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv ) -import HscMain ( hscGetInfo, GetInfoResult, +import TcRnDriver ( mkExportEnv, getModuleContents, tcRnLookupRdrName ) +import RdrName ( plusGlobalRdrEnv ) +import HscMain ( hscGetInfo, GetInfoResult, hscParseIdentifier, hscStmt, hscTcExpr, hscKcType ) import Type ( tidyType ) import VarEnv ( emptyTidyEnv ) @@ -95,19 +141,30 @@ import GHC.Exts ( unsafeCoerce# ) import IfaceSyn ( IfaceDecl ) #endif +import Packages ( initPackages ) +import NameSet ( NameSet, nameSetToList ) +import RdrName ( GlobalRdrEnv ) +import HsSyn ( HsModule, LHsBinds ) import Type ( Kind, Type, dropForAlls ) -import Id ( Id, idType ) -import TyCon ( TyCon ) -import Class ( Class ) +import Id ( Id, idType, isImplicitId, isDeadBinder, + isSpecPragmaId, isExportedId, isLocalId, isGlobalId, + isRecordSelector, + isPrimOpId, isFCallId, + isDataConWorkId, idDataCon, + isBottomingId ) +import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon ) +import Class ( Class, classSCTheta, classTvsFds ) import DataCon ( DataCon ) -import Name ( Name ) +import Name ( Name, getName, nameModule_maybe ) +import RdrName ( RdrName, gre_name, globalRdrEnvElts ) import NameEnv ( nameEnvElts ) -import DriverPipeline ( preprocess, compile, CompResult(..), link ) -import DriverPhases ( isHaskellSrcFilename ) +import SrcLoc ( Located(..), mkSrcLoc, srcLocSpan ) +import DriverPipeline +import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) import GetImports ( getImports ) import Packages ( isHomePackage ) import Finder -import HscMain ( newHscEnv ) +import HscMain ( newHscEnv, hscFileCheck, HscResult(..) ) import HscTypes import DynFlags import StaticFlags @@ -115,21 +172,27 @@ import SysTools ( initSysTools, cleanTempFiles ) import Module import FiniteMap import Panic -import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs ) -import ErrUtils ( showPass ) +import Digraph +import ErrUtils ( showPass, Messages, putMsg, debugTraceMsg ) import qualified ErrUtils import Util -import StringBuffer ( hGetStringBuffer ) +import StringBuffer ( StringBuffer, hGetStringBuffer ) import Outputable import SysTools ( cleanTempFilesExcept ) -import BasicTypes ( SuccessFlag(..), succeeded ) +import BasicTypes ( SuccessFlag(..), succeeded, failed ) import Maybes ( orElse, expectJust, mapCatMaybes ) +import TcType ( tcSplitSigmaTy, isDictTy ) +import Bag ( unitBag, emptyBag ) +import FastString ( mkFastString ) import Directory ( getModificationTime, doesFileExist ) -import Maybe ( isJust, fromJust ) +import Maybe ( isJust, isNothing, fromJust, fromMaybe, catMaybes ) +import Maybes ( expectJust ) import List ( partition, nub ) +import qualified List import Monad ( unless, when, foldM ) import System ( exitWith, ExitCode(..) ) +import Time ( ClockTime ) import EXCEPTION as Exception hiding (handle) import DATA_IOREF import IO @@ -149,10 +212,10 @@ defaultErrorHandler inner = hFlush stdout case exception of -- an IO exception probably isn't our fault, so don't panic - IOException _ -> hPutStrLn stderr (show exception) + IOException _ -> putMsg (show exception) AsyncException StackOverflow -> - hPutStrLn stderr "stack overflow: use +RTS -K to increase it" - _other -> hPutStr stderr (show (Panic (show exception))) + putMsg "stack overflow: use +RTS -K to increase it" + _other -> putMsg (show (Panic (show exception))) exitWith (ExitFailure 1) ) $ @@ -162,7 +225,7 @@ defaultErrorHandler inner = case dyn of PhaseFailed _ code -> exitWith code Interrupted -> exitWith (ExitFailure 1) - _ -> do hPutStrLn stderr (show (dyn :: GhcException)) + _ -> do putMsg (show (dyn :: GhcException)) exitWith (ExitFailure 1) ) $ inner @@ -206,7 +269,7 @@ GLOBAL_VAR(v_initDynFlags, error "initDynFlags", DynFlags) -- | 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 +-- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed -- code". newSession :: GhcMode -> IO Session newSession mode = do @@ -252,7 +315,7 @@ setMsgHandler = ErrUtils.setMsgHandler -- | Sets the targets for this session. Each target may be a module name -- or a filename. The targets correspond to the set of root modules for --- the program/library. Unloading the current program is achieved by +-- the program\/library. Unloading the current program is achieved by -- setting the current set of targets to be empty, followed by load. setTargets :: Session -> [Target] -> IO () setTargets s targets = modifySession s (\h -> h{ hsc_targets = targets }) @@ -261,13 +324,17 @@ setTargets s targets = modifySession s (\h -> h{ hsc_targets = targets }) getTargets :: Session -> IO [Target] getTargets s = withSession s (return . hsc_targets) --- Add another target, or update an existing target with new content. +-- | Add another target addTarget :: Session -> Target -> IO () addTarget s target = modifySession s (\h -> h{ hsc_targets = target : hsc_targets h }) --- Remove a target --- removeTarget :: Session -> Module -> IO () +-- | Remove a target +removeTarget :: Session -> TargetId -> IO () +removeTarget s target_id + = modifySession s (\h -> h{ hsc_targets = filter (hsc_targets h) }) + where + filter targets = [ t | t@(Target id _) <- targets, id /= target_id ] -- Attempts to guess what Target a string refers to. This function implements -- the --make/GHCi command-line syntax for filenames: @@ -295,22 +362,6 @@ guessTarget file -- ----------------------------------------------------------------------------- -- Loading the program --- | The result of load. -data LoadResult - = LoadOk Errors -- ^ all specified targets were loaded successfully. - | LoadFailed Errors -- ^ not all modules were loaded. - -type Errors = [String] - -{- -data ErrMsg = ErrMsg { - errMsgSeverity :: Severity, -- warning, error, etc. - errMsgSpans :: [SrcSpan], - errMsgShortDoc :: Doc, - errMsgExtraInfo :: Doc - } --} - -- Perform a dependency analysis starting from the current targets -- and update the session with the new module graph. depanal :: Session -> [Module] -> IO () @@ -323,22 +374,51 @@ depanal (Session ref) excluded_mods = do old_graph = hsc_mod_graph hsc_env showPass dflags "Chasing dependencies" - when (verbosity dflags >= 1 && gmode == BatchCompile) $ - hPutStrLn stderr (showSDoc (hcat [ + when (gmode == BatchCompile) $ + debugTraceMsg dflags 1 (showSDoc (hcat [ text "Chasing modules from: ", hcat (punctuate comma (map pprTarget targets))])) graph <- downsweep hsc_env old_graph excluded_mods writeIORef ref hsc_env{ hsc_mod_graph=graph } +{- +-- | The result of load. +data LoadResult + = LoadOk Errors -- ^ all specified targets were loaded successfully. + | LoadFailed Errors -- ^ not all modules were loaded. + +type Errors = [String] + +data ErrMsg = ErrMsg { + errMsgSeverity :: Severity, -- warning, error, etc. + errMsgSpans :: [SrcSpan], + errMsgShortDoc :: Doc, + errMsgExtraInfo :: Doc + } +-} + +data LoadHowMuch + = LoadAllTargets + | LoadUpTo Module + | LoadDependenciesOf Module -- | Try to load the program. If a Module is supplied, then just -- attempt to load up to this target. If no Module is supplied, -- then try to load all targets. -load :: Session -> Maybe Module -> IO SuccessFlag -load s@(Session ref) maybe_mod{-ToDo-} +load :: Session -> LoadHowMuch -> IO SuccessFlag +load session how_much = + loadMsgs session how_much ErrUtils.printErrorsAndWarnings + +-- | Version of 'load' that takes a callback function to be invoked +-- on compiler errors and warnings as they occur during compilation. +loadMsgs :: Session -> LoadHowMuch -> (Messages-> IO ()) -> IO SuccessFlag +loadMsgs s@(Session ref) how_much msg_act = do - -- dependency analysis first + -- Dependency analysis first. Note that this fixes the module graph: + -- even if we don't get a fully successful upsweep, the full module + -- graph is still retained in the Session. We can tell which modules + -- were successfully loaded by inspecting the Session's HPT. depanal s [] hsc_env <- readIORef ref @@ -359,72 +439,37 @@ load s@(Session ref) maybe_mod{-ToDo-} not (ms_mod s `elem` all_home_mods)] ASSERT( null bad_boot_mods ) return () - -- Topologically sort the module graph - -- mg2 should be cycle free; but it includes hi-boot ModSummary nodes - let mg2 :: [SCC ModSummary] - mg2 = topSortModuleGraph False mod_graph - -- mg2_with_srcimps drops the hi-boot nodes, returning a -- graph with cycles. Among other things, it is used for -- backing out partially complete cycles following a failed -- upsweep, and for removing from hpt all the modules -- not in strict downwards closure, during calls to compile. let mg2_with_srcimps :: [SCC ModSummary] - mg2_with_srcimps = topSortModuleGraph True mod_graph - - -- Sort out which linkables we wish to keep in the unlinked image. - -- See getValidLinkables below for details. - (valid_old_linkables, new_linkables) - <- getValidLinkables ghci_mode (hptLinkables hpt1) - all_home_mods mg2_with_srcimps - - -- putStrLn (showSDoc (vcat [ppr valid_old_linkables, ppr new_linkables])) - - -- The new_linkables are .o files we found on the disk, presumably - -- as a result of a GHC run "on the side". So we'd better forget - -- everything we know abouut those modules! - let old_hpt = delModuleEnvList hpt1 (map linkableModule new_linkables) - - -- When (verb >= 2) $ - -- putStrLn (showSDoc (text "Valid linkables:" - -- <+> ppr valid_linkables)) - - -- Figure out a stable set of modules which can be retained - -- the top level envs, to avoid upsweeping them. Goes to a - -- bit of trouble to avoid upsweeping module cycles. - -- - -- Construct a set S of stable modules like this: - -- Travel upwards, over the sccified graph. For each scc - -- of modules ms, add ms to S only if: - -- 1. All home imports of ms are either in ms or S - -- 2. A valid old linkable exists for each module in ms - - -- mg2_with_srcimps has no hi-boot nodes, - -- and hence neither does stable_mods - stable_summaries <- preUpsweep valid_old_linkables - all_home_mods [] mg2_with_srcimps - let stable_mods = map ms_mod stable_summaries - stable_linkables = filter (\m -> linkableModule m `elem` stable_mods) - valid_old_linkables - - stable_hpt = filterModuleEnv is_stable_hm hpt1 - is_stable_hm hm_info = mi_module (hm_iface hm_info) `elem` stable_mods - - upsweep_these - = filter (\scc -> any (`notElem` stable_mods) - (map ms_mod (flattenSCC scc))) - mg2 - - when (verb >= 2) $ - hPutStrLn stderr (showSDoc (text "Stable modules:" - <+> sep (map (text.moduleUserString) stable_mods))) + mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing + + -- 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 + + -- prune bits of the HPT which are definitely redundant now, + -- to save space. + pruned_hpt = pruneHomePackageTable hpt1 + (flattenSCCs mg2_with_srcimps) + stable_mods + + evaluate pruned_hpt + + debugTraceMsg dflags 2 (showSDoc (text "Stable obj:" <+> ppr stable_obj $$ + text "Stable BCO:" <+> ppr stable_bco)) -- Unload any modules which are going to be re-linked this time around. + let stable_linkables = [ linkable + | m <- stable_obj++stable_bco, + Just hmi <- [lookupModuleEnv pruned_hpt m], + Just linkable <- [hm_linkable hmi] ] unload hsc_env stable_linkables - -- We can now glom together our linkable sets - let valid_linkables = valid_old_linkables ++ new_linkables - -- We could at this point detect cycles which aren't broken by -- a source-import, and complain immediately, but it seems better -- to let upsweep_mods do this, so at least some useful work gets @@ -435,26 +480,56 @@ load s@(Session ref) maybe_mod{-ToDo-} -- Now do the upsweep, calling compile for each module in -- turn. Final result is version 3 of everything. + -- Topologically sort the module graph, this time including hi-boot + -- nodes, and possibly just including the portion of the graph + -- reachable from the module specified in the 2nd argument to load. + -- This graph should be cycle-free. + -- If we're restricting the upsweep to a portion of the graph, we + -- also want to retain everything that is still stable. + let full_mg :: [SCC ModSummary] + full_mg = topSortModuleGraph False mod_graph Nothing + + maybe_top_mod = case how_much of + LoadUpTo m -> Just m + LoadDependenciesOf m -> Just m + _ -> Nothing + + partial_mg0 :: [SCC ModSummary] + partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod + + -- LoadDependenciesOf m: we want the upsweep to stop just + -- short of the specified module (unless the specified module + -- is stable). + partial_mg + | LoadDependenciesOf mod <- how_much + = ASSERT( case last partial_mg0 of + AcyclicSCC ms -> ms_mod ms == mod; _ -> False ) + List.init partial_mg0 + | otherwise + = partial_mg0 + + stable_mg = + [ AcyclicSCC ms + | AcyclicSCC ms <- full_mg, + ms_mod ms `elem` stable_obj++stable_bco, + ms_mod ms `notElem` [ ms_mod ms' | + AcyclicSCC ms' <- partial_mg ] ] + + mg = stable_mg ++ partial_mg + -- clean up between compilations let cleanup = cleanTempFilesExcept dflags - (ppFilesFromSummaries (flattenSCCs mg2)) + (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps)) - (upsweep_ok, hsc_env3, modsUpswept) - <- upsweep_mods (hsc_env { hsc_HPT = stable_hpt }) - (old_hpt, valid_linkables) - cleanup upsweep_these - - -- At this point, modsUpswept and newLis should have the same - -- length, so there is one new (or old) linkable for each - -- mod which was processed (passed to compile). + (upsweep_ok, hsc_env1, modsUpswept) + <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable }) + pruned_hpt stable_mods cleanup msg_act mg -- Make modsDone be the summaries for each home module now -- available; this should equal the domain of hpt3. - -- (NOT STRICTLY TRUE if an interactive session was started - -- with some object on disk ???) -- Get in in a roughly top .. bottom order (hence reverse). - let modsDone = reverse modsUpswept ++ stable_summaries + let modsDone = reverse modsUpswept -- Try and do linking in some form, depending on whether the -- upsweep was completely or only partially successful. @@ -463,8 +538,7 @@ load s@(Session ref) maybe_mod{-ToDo-} then -- Easy; just relink it all. - do when (verb >= 2) $ - hPutStrLn stderr "Upsweep completely successful." + do debugTraceMsg dflags 2 "Upsweep completely successful." -- Clean up after ourselves cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone) @@ -485,24 +559,21 @@ load s@(Session ref) maybe_mod{-ToDo-} mod_graph do_linking = a_root_is_Main || no_hs_main - when (ghci_mode == BatchCompile && isJust ofile && not do_linking - && verb > 0) $ - hPutStrLn stderr ("Warning: output was redirected with -o, " ++ + when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $ + debugTraceMsg dflags 1 ("Warning: output was redirected with -o, " ++ "but no output will be generated\n" ++ "because there is no " ++ main_mod ++ " module.") -- link everything together - linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env3) + linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1) - let hsc_env4 = hsc_env3{ hsc_mod_graph = modsDone } - loadFinish Succeeded linkresult ref hsc_env4 + loadFinish Succeeded linkresult ref hsc_env1 else -- Tricky. We need to back out the effects of compiling any -- half-done cycles, both so as to clean up the top level envs -- and to avoid telling the interactive linker to link them. - do when (verb >= 2) $ - hPutStrLn stderr "Upsweep partially successful." + do debugTraceMsg dflags 2 "Upsweep partially successful." let modsDone_names = map ms_mod modsDone @@ -514,16 +585,19 @@ load s@(Session ref) maybe_mod{-ToDo-} modsDone let hpt4 = retainInTopLevelEnvs (map ms_mod mods_to_keep) - (hsc_HPT hsc_env3) + (hsc_HPT hsc_env1) -- Clean up after ourselves cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep) + -- there should be no Nothings where linkables should be, now + ASSERT(all (isJust.hm_linkable) + (moduleEnvElts (hsc_HPT hsc_env))) do + -- Link everything together linkresult <- link ghci_mode dflags False hpt4 - let hsc_env4 = hsc_env3{ hsc_mod_graph = mods_to_keep, - hsc_HPT = hpt4 } + let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 } loadFinish Failed linkresult ref hsc_env4 -- Finish up after a load. @@ -540,6 +614,7 @@ loadFinish all_ok Succeeded ref hsc_env = do writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext } return all_ok + -- Forget the current program, but retain the persistent info in HscEnv discardProg :: HscEnv -> HscEnv discardProg hsc_env @@ -552,219 +627,230 @@ discardProg hsc_env -- source file, but that doesn't do any harm. ppFilesFromSummaries summaries = [ fn | Just fn <- map ms_hspp_file summaries ] ------------------------------------------------------------------------------ +-- ----------------------------------------------------------------------------- +-- Check module + +data CheckedModule = + CheckedModule { parsedSource :: ParsedSource, + -- ToDo: renamedSource + typecheckedSource :: Maybe TypecheckedSource, + checkedModuleInfo :: Maybe ModuleInfo + } + +type ParsedSource = Located (HsModule RdrName) +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 +-- successful, it returns the abstract syntax for the module. +checkModule :: Session -> Module -> (Messages -> IO ()) + -> IO (Maybe CheckedModule) +checkModule session@(Session ref) mod msg_act = do + -- load up the dependencies first + r <- loadMsgs session (LoadDependenciesOf mod) msg_act + if (failed r) then return Nothing else do + + -- now parse & typecheck the module + hsc_env <- readIORef ref + let mg = hsc_mod_graph hsc_env + case [ ms | ms <- mg, ms_mod ms == mod ] of + [] -> return Nothing + (ms:_) -> do + -- Add in the OPTIONS from the source file This is nasty: + -- we've done this once already, in the compilation manager + -- It might be better to cache the flags in the + -- ml_hspp_file field, say + let dflags0 = hsc_dflags hsc_env + hspp_buf = expectJust "GHC.checkModule" (ms_hspp_buf ms) + opts = getOptionsFromStringBuffer hspp_buf + (dflags1,leftovers) <- parseDynamicFlags dflags0 (map snd opts) + if (not (null leftovers)) + then do let filename = fromJust (ml_hs_file (ms_location ms)) + msg_act (optionsErrorMsgs leftovers opts filename) + return Nothing + else do + + r <- hscFileCheck hsc_env{hsc_dflags=dflags1} msg_act ms + case r of + HscFail -> + return Nothing + HscChecked parsed Nothing -> + return (Just (CheckedModule parsed Nothing Nothing)) + HscChecked parsed (Just (tc_binds, rdr_env, details)) -> do + let minf = ModuleInfo { + minf_details = details, + minf_rdr_env = Just rdr_env + } + return (Just (CheckedModule { + parsedSource = parsed, + typecheckedSource = Just tc_binds, + checkedModuleInfo = Just minf })) + +-- --------------------------------------------------------------------------- -- Unloading unload :: HscEnv -> [Linkable] -> IO () unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' = case ghcMode (hsc_dflags hsc_env) of - BatchCompile -> return () + BatchCompile -> return () + JustTypecheck -> return () #ifdef GHCI Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables #else Interactive -> panic "unload: no interpreter" #endif other -> panic "unload: strange mode" - ------------------------------------------------------------------------------ --- getValidLinkables --- For each module (or SCC of modules), we take: --- --- - an on-disk linkable, if this is the first time around and one --- is available. --- --- - the old linkable, otherwise (and if one is available). --- --- and we throw away the linkable if it is older than the source file. --- In interactive mode, we also ignore the on-disk linkables unless --- all of the dependents of this SCC also have on-disk linkables (we --- can't have dynamically loaded objects that depend on interpreted --- modules in GHCi). --- --- If a module has a valid linkable, then it may be STABLE (see below), --- and it is classified as SOURCE UNCHANGED for the purposes of calling --- compile. --- --- ToDo: this pass could be merged with the preUpsweep. --- --- **************** --- CAREFUL! This pass operates on the cyclic version of --- the module graph (topSortModuleGraph True), whereas the upsweep operates on --- the non-cyclic (topSortModuleGraph False) version of the graph. --- **************** - -getValidLinkables - :: GhcMode - -> [Linkable] -- old linkables - -> [Module] -- all home modules - -> [SCC ModSummary] -- all modules in the program, dependency order - -> IO ( [Linkable], -- still-valid linkables - [Linkable] -- new linkables we just found on the disk - -- presumably generated by separate run of ghc - ) - -getValidLinkables mode old_linkables all_home_mods module_graph - = do { -- Process the SCCs in bottom-to-top order - -- (foldM works left-to-right) - ls <- foldM (getValidLinkablesSCC mode old_linkables all_home_mods) - [] module_graph - ; return (partition_it ls [] []) } - where - partition_it [] valid new = (valid,new) - partition_it ((l,b):ls) valid new - | b = partition_it ls valid (l:new) - | otherwise = partition_it ls (l:valid) new - - -getValidLinkablesSCC - :: GhcMode - -> [Linkable] -- old linkables - -> [Module] -- all home modules - -> [(Linkable,Bool)] - -> SCC ModSummary - -> IO [(Linkable,Bool)] - -getValidLinkablesSCC mode old_linkables all_home_mods new_linkables scc0 - = let - scc = flattenSCC scc0 - scc_names = map ms_mod scc - home_module m = m `elem` all_home_mods && m `notElem` scc_names - scc_allhomeimps = nub (filter home_module (concatMap ms_imps scc)) - -- NB. ms_imps, not ms_allimps above. We don't want to - -- force a module's SOURCE imports to be already compiled for - -- its object linkable to be valid. - - -- The new_linkables is only the *valid* linkables below here - has_object m = case findModuleLinkable_maybe (map fst new_linkables) m of - Nothing -> False - Just l -> isObjectLinkable l - - objects_allowed = mode == BatchCompile || all has_object scc_allhomeimps - in do - - new_linkables' - <- foldM (getValidLinkable old_linkables objects_allowed) [] scc - - -- since an scc can contain only all objects or no objects at all, - -- we have to check whether we got all objects or not, and re-do - -- the linkable check if not. - new_linkables' <- - if objects_allowed - && not (all isObjectLinkable (map fst new_linkables')) - then foldM (getValidLinkable old_linkables False) [] scc - else return new_linkables' - - return (new_linkables ++ new_linkables') - - -getValidLinkable :: [Linkable] -> Bool -> [(Linkable,Bool)] -> ModSummary - -> IO [(Linkable,Bool)] - -- True <=> linkable is new; i.e. freshly discovered on the disk - -- presumably generated 'on the side' - -- by a separate GHC run -getValidLinkable old_linkables objects_allowed new_linkables summary - -- 'objects_allowed' says whether we permit this module to - -- have a .o-file linkable. We only permit it if all the - -- modules it depends on also have .o files; a .o file can't - -- link to a bytecode module - = do let mod_name = ms_mod summary - - maybe_disk_linkable - <- if (not objects_allowed) - then return Nothing - - else findLinkable mod_name (ms_location summary) - - let old_linkable = findModuleLinkable_maybe old_linkables mod_name - - new_linkables' = - case (old_linkable, maybe_disk_linkable) of - (Nothing, Nothing) -> [] - - -- new object linkable just appeared - (Nothing, Just l) -> up_to_date l True - - (Just l, Nothing) - | isObjectLinkable l -> [] - -- object linkable disappeared! In case we need to - -- relink the module, disregard the old linkable and - -- just interpret the module from now on. - | otherwise -> up_to_date l False - -- old byte code linkable - - (Just l, Just l') - | not (isObjectLinkable l) -> up_to_date l False - -- if the previous linkable was interpreted, then we - -- ignore a newly compiled version, because the version - -- numbers in the interface file will be out-of-sync with - -- our internal ones. - | linkableTime l' > linkableTime l -> up_to_date l' True - | linkableTime l' == linkableTime l -> up_to_date l False - | otherwise -> [] - -- on-disk linkable has been replaced by an older one! - -- again, disregard the previous one. - - up_to_date l b - | linkableTime l < ms_hs_date summary = [] - | otherwise = [(l,b)] - -- why '<' rather than '<=' above? If the filesystem stores +-- ----------------------------------------------------------------------------- +-- checkStability + +{- + Stability tells us which modules definitely do not need to be recompiled. + There are two main reasons for having stability: + + - avoid doing a complete upsweep of the module graph in GHCi when + modules near the bottom of the tree have not changed. + + - to tell GHCi when it can load object code: we can only load object code + for a module when we also load object code fo all of the imports of the + 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. + + ------------------- + stable m = stableObject m || stableBCO m + + stableObject m = + all stableObject (imports m) + && old linkable does not exist, or is == on-disk .o + && date(on-disk .o) > date(.hs) + + stableBCO m = + all stable (imports m) + && date(BCO) > date(.hs) + ------------------- + + These properties embody the following ideas: + + - if a module is stable: + - 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, + then we only need to read its .hi file from disk and + link it to produce a ModDetails. + + - if a modules is not stable, we will definitely be at least + re-linking, and possibly re-compiling it during the upsweep. + All non-stable modules can (and should) therefore be unlinked + before the upsweep. + + - Note that objects are only considered stable if they only depend + on other objects. We can't link object code against byte code. +-} + +checkStability + :: HomePackageTable -- HPT from last compilation + -> [SCC ModSummary] -- current module graph (cyclic) + -> [Module] -- all home modules + -> ([Module], -- stableObject + [Module]) -- stableBCO + +checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs + where + checkSCC (stable_obj, stable_bco) scc0 + | stableObjects = (scc_mods ++ stable_obj, stable_bco) + | stableBCOs = (stable_obj, scc_mods ++ stable_bco) + | otherwise = (stable_obj, stable_bco) + where + scc = flattenSCC scc0 + scc_mods = map ms_mod scc + home_module m = m `elem` all_home_mods && m `notElem` scc_mods + + scc_allimps = nub (filter home_module (concatMap ms_allimps scc)) + -- all imports outside the current SCC, but in the home pkg + + stable_obj_imps = map (`elem` stable_obj) scc_allimps + stable_bco_imps = map (`elem` stable_bco) scc_allimps + + stableObjects = + and stable_obj_imps + && all object_ok scc + + stableBCOs = + and (zipWith (||) stable_obj_imps stable_bco_imps) + && all bco_ok scc + + object_ok ms + | Just t <- ms_obj_date ms = t >= ms_hs_date ms + && same_as_prev t + | otherwise = False + where + same_as_prev t = case lookupModuleEnv hpt (ms_mod ms) of + Nothing -> True + Just hmi | Just l <- hm_linkable hmi + -> isObjectLinkable l && t == linkableTime l + -- why '>=' rather than '>' above? If the filesystem stores -- times to the nearset second, we may occasionally find that -- the object & source have the same modification time, -- especially if the source was automatically generated -- and compiled. Using >= is slightly unsafe, but it matches -- make's behaviour. - return (new_linkables' ++ new_linkables) + bco_ok ms + = case lookupModuleEnv hpt (ms_mod ms) of + Nothing -> False + Just hmi | Just l <- hm_linkable hmi -> + not (isObjectLinkable l) && + linkableTime l >= ms_hs_date ms +ms_allimps :: ModSummary -> [Module] +ms_allimps ms = ms_srcimps ms ++ ms_imps ms -hptLinkables :: HomePackageTable -> [Linkable] --- Get all the linkables from the home package table, one for each module --- Once the HPT is up to date, these are the ones we should link -hptLinkables hpt = map hm_linkable (moduleEnvElts hpt) +-- ----------------------------------------------------------------------------- +-- Prune the HomePackageTable +-- Before doing an upsweep, we can throw away: +-- +-- - For non-stable modules: +-- - all ModDetails, all linked code +-- - all unlinked code that is out of date with respect to +-- the source file +-- +-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the +-- space at the end of the upsweep, because the topmost ModDetails of the +-- old HPT holds on to the entire type environment from the previous +-- compilation. + +pruneHomePackageTable + :: HomePackageTable + -> [ModSummary] + -> ([Module],[Module]) + -> HomePackageTable + +pruneHomePackageTable hpt summ (stable_obj, stable_bco) + = mapModuleEnv prune hpt + where prune hmi + | is_stable modl = hmi' + | otherwise = hmi'{ hm_details = emptyModDetails } + where + modl = mi_module (hm_iface hmi) + hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms + = hmi{ hm_linkable = Nothing } + | otherwise + = hmi + where ms = expectJust "prune" (lookupModuleEnv ms_map modl) ------------------------------------------------------------------------------ --- Do a pre-upsweep without use of "compile", to establish a --- (downward-closed) set of stable modules for which we won't call compile. - --- a stable module: --- * has a valid linkable (see getValidLinkables above) --- * depends only on stable modules --- * has an interface in the HPT (interactive mode only) - -preUpsweep :: [Linkable] -- new valid linkables - -> [Module] -- names of all mods encountered in downsweep - -> [ModSummary] -- accumulating stable modules - -> [SCC ModSummary] -- scc-ified mod graph, including src imps - -> IO [ModSummary] -- stable modules - -preUpsweep valid_lis all_home_mods stable [] = return stable -preUpsweep valid_lis all_home_mods stable (scc0:sccs) - = do let scc = flattenSCC scc0 - scc_allhomeimps :: [Module] - scc_allhomeimps - = nub (filter (`elem` all_home_mods) (concatMap ms_allimps scc)) - all_imports_in_scc_or_stable - = all in_stable_or_scc scc_allhomeimps - scc_mods = map ms_mod scc - stable_names = scc_mods ++ map ms_mod stable - in_stable_or_scc m = m `elem` stable_names - - -- now we check for valid linkables: each module in the SCC must - -- have a valid linkable (see getValidLinkables above). - has_valid_linkable scc_mod - = isJust (findModuleLinkable_maybe valid_lis scc_mod) - - scc_is_stable = all_imports_in_scc_or_stable - && all has_valid_linkable scc_mods - - if scc_is_stable - then preUpsweep valid_lis all_home_mods (scc ++ stable) sccs - else preUpsweep valid_lis all_home_mods stable sccs + ms_map = mkModuleEnv [(ms_mod ms, ms) | ms <- summ] -ms_allimps :: ModSummary -> [Module] -ms_allimps ms = ms_srcimps ms ++ ms_imps ms + is_stable m = m `elem` stable_obj || m `elem` stable_bco + +-- ----------------------------------------------------------------------------- -- Return (names of) all those in modsDone who are part of a cycle -- as defined by theGraph. @@ -786,33 +872,45 @@ findPartiallyCompletedCycles modsDone theGraph then mods_in_this_cycle ++ chewed_rest else chewed_rest +-- ----------------------------------------------------------------------------- +-- The upsweep + +-- This is where we compile each module in the module graph, in a pass +-- from the bottom to the top of the graph. --- Compile multiple modules, stopping as soon as an error appears. -- There better had not be any cyclic groups here -- we check for them. -upsweep_mods :: HscEnv -- Includes initially-empty HPT - -> (HomePackageTable, [Linkable]) -- HPT and valid linkables from last time round - -> IO () -- How to clean up unwanted tmp files - -> [SCC ModSummary] -- Mods to do (the worklist) - -> IO (SuccessFlag, - HscEnv, -- With an updated HPT - [ModSummary]) -- Mods which succeeded - -upsweep_mods hsc_env oldUI cleanup - [] + +upsweep + :: HscEnv -- Includes initially-empty HPT + -> HomePackageTable -- HPT from last time round (pruned) + -> ([Module],[Module]) -- stable modules (see checkStability) + -> IO () -- How to clean up unwanted tmp files + -> (Messages -> IO ()) -- Compiler error message callback + -> [SCC ModSummary] -- Mods to do (the worklist) + -> IO (SuccessFlag, + HscEnv, -- With an updated HPT + [ModSummary]) -- Mods which succeeded + +upsweep hsc_env old_hpt stable_mods cleanup msg_act mods + = upsweep' hsc_env old_hpt stable_mods cleanup msg_act mods 1 (length mods) + +upsweep' hsc_env old_hpt stable_mods cleanup msg_act + [] _ _ = return (Succeeded, hsc_env, []) -upsweep_mods hsc_env oldUI cleanup - (CyclicSCC ms:_) - = do hPutStrLn stderr (showSDoc (cyclicModuleErr ms)) +upsweep' hsc_env old_hpt stable_mods cleanup msg_act + (CyclicSCC ms:_) _ _ + = do putMsg (showSDoc (cyclicModuleErr ms)) return (Failed, hsc_env, []) -upsweep_mods hsc_env oldUI@(old_hpt, old_linkables) cleanup - (AcyclicSCC mod:mods) +upsweep' hsc_env old_hpt stable_mods cleanup msg_act + (AcyclicSCC mod:mods) mod_index nmods = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ -- show (map (moduleUserString.moduleName.mi_module.hm_iface) -- (moduleEnvElts (hsc_HPT hsc_env))) - mb_mod_info <- upsweep_mod hsc_env oldUI mod + mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods msg_act mod + mod_index nmods cleanup -- Remove unwanted tmp files between compilations @@ -822,36 +920,104 @@ upsweep_mods hsc_env oldUI@(old_hpt, old_linkables) cleanup { let this_mod = ms_mod mod -- Add new info to hsc_env - hpt1 = extendModuleEnv (hsc_HPT hsc_env) this_mod mod_info + hpt1 = extendModuleEnv (hsc_HPT hsc_env) + this_mod mod_info hsc_env1 = hsc_env { hsc_HPT = hpt1 } - -- Space-saving: delete the old HPT entry and - -- linkable for mod BUT if mod is a hs-boot - -- node, don't delete it For the linkable this - -- is dead right: the linkable relates only to - -- the main Haskell source file. For the + + -- 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) - oldUI1 | isBootSummary mod = oldUI - | otherwise - = (delModuleEnv old_hpt this_mod, - delModuleLinkable old_linkables this_mod) + old_hpt1 | isBootSummary mod = old_hpt + | otherwise = delModuleEnv old_hpt this_mod - ; (restOK, hsc_env2, modOKs) <- upsweep_mods hsc_env1 oldUI1 cleanup mods - ; return (restOK, hsc_env2, mod:modOKs) } + ; (restOK, hsc_env2, modOKs) + <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup + msg_act mods (mod_index+1) nmods + ; return (restOK, hsc_env2, mod:modOKs) + } -- Compile a single module. Always produce a Linkable for it if -- successful. If no compilation happened, return the old Linkable. upsweep_mod :: HscEnv - -> (HomePackageTable, UnlinkedImage) + -> HomePackageTable + -> ([Module],[Module]) + -> (Messages -> IO ()) -> ModSummary + -> Int -- index of module + -> Int -- total number of modules -> IO (Maybe HomeModInfo) -- Nothing => Failed -upsweep_mod hsc_env (old_hpt, old_linkables) summary +upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) msg_act summary mod_index nmods = do - let this_mod = ms_mod summary - + let + 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 + + compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo) + compile_it = upsweep_compile hsc_env old_hpt this_mod + msg_act 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 + -- 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 + (expectJust "upseep1" mb_obj_date) + 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 + -- 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) + -- 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 + -- no existing code at all: we must recompile. + where + is_stable_obj = this_mod `elem` stable_obj + is_stable_bco = this_mod `elem` stable_bco + + old_hmi = lookupModuleEnv old_hpt this_mod + +-- Run hsc to compile a module +upsweep_compile hsc_env old_hpt this_mod msg_act 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 @@ -861,7 +1027,7 @@ upsweep_mod hsc_env (old_hpt, old_linkables) summary -- manager, but that does no harm. Otherwise the hs-boot file -- will always be recompiled - mb_old_iface + mb_old_iface = case lookupModuleEnv old_hpt this_mod of Nothing -> Nothing Just hm_info | isBootSummary summary -> Just iface @@ -870,37 +1036,27 @@ upsweep_mod hsc_env (old_hpt, old_linkables) summary where iface = hm_iface hm_info - maybe_old_linkable = findModuleLinkable_maybe old_linkables this_mod - source_unchanged = isJust maybe_old_linkable - - old_linkable = expectJust "upsweep_mod:old_linkable" maybe_old_linkable - - have_object - | Just l <- maybe_old_linkable, isObjectLinkable l = True - | otherwise = False + compresult <- compile hsc_env msg_act summary mb_old_linkable mb_old_iface + mod_index nmods - compresult <- compile hsc_env summary source_unchanged have_object mb_old_iface + case compresult of + -- Compilation failed. Compile may still have updated the PCS, tho. + CompErrs -> return Nothing - case compresult of - - -- 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 maybe_new_linkable - -> do let - new_linkable = maybe_new_linkable `orElse` old_linkable - new_info = HomeModInfo { hm_iface = new_iface, + -- 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) - -- Compilation failed. Compile may still have updated the PCS, tho. - CompErrs -> return Nothing -- Filter modules in the HPT retainInTopLevelEnvs :: [Module] -> HomePackageTable -> HomePackageTable retainInTopLevelEnvs keep_these hpt - = mkModuleEnv [ (mod, fromJust mb_mod_info) + = mkModuleEnv [ (mod, expectJust "retain" mb_mod_info) | mod <- keep_these , let mb_mod_info = lookupModuleEnv hpt mod , isJust mb_mod_info ] @@ -911,8 +1067,13 @@ retainInTopLevelEnvs keep_these hpt topSortModuleGraph :: Bool -- Drop hi-boot nodes? (see below) -> [ModSummary] + -> Maybe Module -> [SCC ModSummary] -- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes +-- The resulting list of strongly-connected-components is in topologically +-- sorted order, starting with the module(s) at the bottom of the +-- dependency graph (ie compile them first) and ending with the ones at +-- the top. -- -- Drop hi-boot nodes (first boolean arg)? -- @@ -923,8 +1084,24 @@ topSortModuleGraph -- the a source-import of Foo is an import of Foo -- The resulting graph has no hi-boot nodes, but can by cyclic -topSortModuleGraph drop_hs_boot_nodes summaries - = stronglyConnComp nodes +topSortModuleGraph drop_hs_boot_nodes summaries Nothing + = stronglyConnComp (fst (moduleGraphNodes drop_hs_boot_nodes summaries)) +topSortModuleGraph drop_hs_boot_nodes summaries (Just mod) + = stronglyConnComp (map vertex_fn (reachable graph root)) + where + -- restrict the graph to just those modules reachable from + -- the specified module. We do this by building a graph with + -- the full set of nodes, and determining the reachable set from + -- the specified node. + (nodes, lookup_key) = moduleGraphNodes drop_hs_boot_nodes summaries + (graph, vertex_fn, key_fn) = graphFromEdges' nodes + root + | Just key <- lookup_key HsSrcFile mod, Just v <- key_fn key = v + | otherwise = throwDyn (ProgramError "module does not exist") + +moduleGraphNodes :: Bool -> [ModSummary] + -> ([(ModSummary, Int, [Int])], HscSource -> Module -> Maybe Int) +moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key) where -- Drop hs-boot nodes by using HsSrcFile as the key hs_boot_key | drop_hs_boot_nodes = HsSrcFile @@ -932,7 +1109,7 @@ topSortModuleGraph drop_hs_boot_nodes summaries -- We use integers as the keys for the SCC algorithm nodes :: [(ModSummary, Int, [Int])] - nodes = [(s, fromJust (lookup_key (ms_hsc_src s) (ms_mod s)), + nodes = [(s, expectJust "topSort" (lookup_key (ms_hsc_src s) (ms_mod s)), out_edge_keys hs_boot_key (ms_srcimps s) ++ out_edge_keys HsSrcFile (ms_imps s) ) | s <- summaries @@ -1013,7 +1190,6 @@ downsweep hsc_env old_summaries excl_mods loop (concatMap msDeps rootSummaries) (mkNodeMap rootSummaries) where - dflags = hsc_dflags hsc_env roots = hsc_targets hsc_env old_summary_map :: NodeMap ModSummary @@ -1022,11 +1198,11 @@ downsweep hsc_env old_summaries excl_mods getRootSummary :: Target -> IO ModSummary getRootSummary (Target (TargetFile file) maybe_buf) = do exists <- doesFileExist file - if exists then summariseFile hsc_env file else do + if exists then summariseFile hsc_env file maybe_buf else do throwDyn (CmdLineError ("can't find file: " ++ file)) getRootSummary (Target (TargetModule modl) maybe_buf) = do maybe_summary <- summarise hsc_env emptyNodeMap Nothing False - modl excl_mods + modl maybe_buf excl_mods case maybe_summary of Nothing -> packageModErr modl Just s -> return s @@ -1044,7 +1220,7 @@ downsweep hsc_env old_summaries excl_mods many -> multiRootsErr modl many where modl = ms_mod summ dups = - [ fromJust (ml_hs_file (ms_location summ')) + [ expectJust "checkDup" (ml_hs_file (ms_location summ')) | summ' <- summaries, ms_mod summ' == modl ] loop :: [(FilePath,Module,IsBootInterface)] @@ -1059,7 +1235,7 @@ downsweep hsc_env old_summaries excl_mods | key `elemFM` done = loop ss done | otherwise = do { mb_s <- summarise hsc_env old_summary_map (Just cur_path) is_boot - wanted_mod excl_mods + wanted_mod Nothing excl_mods ; case mb_s of Nothing -> loop ss done Just s -> loop (msDeps s ++ ss) @@ -1097,21 +1273,18 @@ msDeps s = concat [ [(f, m, True), (f,m,False)] | m <- ms_srcimps s] -- a summary. The finder is used to locate the file in which the module -- resides. -summariseFile :: HscEnv -> FilePath -> IO ModSummary +summariseFile :: HscEnv -> FilePath + -> Maybe (StringBuffer,ClockTime) + -> IO ModSummary -- Used for Haskell source only, I think -- We know the file name, and we know it exists, -- but we don't necessarily know the module name (might differ) -summariseFile hsc_env file +summariseFile hsc_env file maybe_buf = do let dflags = hsc_dflags hsc_env - (dflags', hspp_fn) <- preprocess dflags file - -- The dflags' contains the OPTIONS pragmas + (dflags', hspp_fn, buf) + <- preprocessFile dflags file maybe_buf - -- Read the file into a buffer. We're going to cache - -- this buffer in the ModLocation (ml_hspp_buf) so that it - -- doesn't have to be slurped again when hscMain parses the - -- file later. - buf <- hGetStringBuffer hspp_fn (srcimps,the_imps,mod) <- getImports dflags' buf hspp_fn -- Make a ModLocation for this file @@ -1121,13 +1294,19 @@ summariseFile hsc_env file -- to findModule will find it, even if it's not on any search path addHomeModuleToFinder hsc_env mod location - src_timestamp <- getModificationTime file + src_timestamp <- case maybe_buf of + Just (_,t) -> return t + Nothing -> getModificationTime file + + obj_timestamp <- modificationTimeIfExists (ml_obj_file location) + return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile, ms_location = location, ms_hspp_file = Just hspp_fn, ms_hspp_buf = Just buf, ms_srcimps = srcimps, ms_imps = the_imps, - ms_hs_date = src_timestamp }) + ms_hs_date = src_timestamp, + ms_obj_date = obj_timestamp }) -- Summarise a module, and pick up source and timestamp. summarise :: HscEnv @@ -1135,78 +1314,123 @@ summarise :: HscEnv -> Maybe FilePath -- Importing module (for error messages) -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Module -- Imported module to be summarised + -> Maybe (StringBuffer, ClockTime) -> [Module] -- Modules to exclude -> IO (Maybe ModSummary) -- Its new summary -summarise hsc_env old_summary_map cur_mod is_boot wanted_mod excl_mods +summarise hsc_env old_summary_map cur_mod is_boot wanted_mod maybe_buf excl_mods | wanted_mod `elem` excl_mods = return Nothing | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src) - = do { -- Find its new timestamp; all the + = do -- Find its new timestamp; all the -- ModSummaries in the old map have valid ml_hs_files - let location = ms_location old_summary - src_fn = fromJust (ml_hs_file location) - - ; src_timestamp <- getModificationTime src_fn + let location = ms_location old_summary + src_fn = expectJust "summarise" (ml_hs_file location) -- return the cached summary if the source didn't change - ; if ms_hs_date old_summary == src_timestamp - then return (Just old_summary) - else new_summary location - } + src_timestamp <- case maybe_buf of + Just (_,t) -> return t + Nothing -> getModificationTime src_fn + + if ms_hs_date old_summary == src_timestamp + then do -- update the object-file timestamp + obj_timestamp <- getObjTimestamp location is_boot + return (Just old_summary{ ms_obj_date = obj_timestamp }) + else + -- source changed: re-summarise + new_summary location src_fn maybe_buf src_timestamp | otherwise - = do { found <- findModule hsc_env wanted_mod True {-explicit-} - ; case found of + = do found <- findModule hsc_env wanted_mod True {-explicit-} + case found of Found location pkg - | not (isHomePackage pkg) -> return Nothing + | not (isHomePackage pkg) -> return Nothing -- Drop external-pkg - | isJust (ml_hs_file location) -> new_summary location + | isJust (ml_hs_file location) -> just_found location -- Home package err -> noModError dflags cur_mod wanted_mod err -- Not found - } where dflags = hsc_dflags hsc_env hsc_src = if is_boot then HsBootFile else HsSrcFile - new_summary location - = do { -- Adjust location to point to the hs-boot source file, + just_found location = do + -- Adjust location to point to the hs-boot source file, -- hi file, object file, when is_boot says so - let location' | is_boot = addBootSuffixLocn location - | otherwise = location - src_fn = fromJust (ml_hs_file location') + let location' | is_boot = addBootSuffixLocn location + | otherwise = location + src_fn = expectJust "summarise2" (ml_hs_file location') -- Check that it exists - -- It might have been deleted since the Finder last found it - ; exists <- doesFileExist src_fn - ; if exists then return () else noHsFileErr cur_mod src_fn + -- It might have been deleted since the Finder last found it + maybe_t <- modificationTimeIfExists src_fn + case maybe_t of + Nothing -> noHsFileErr cur_mod src_fn + Just t -> new_summary location' src_fn Nothing t + + new_summary location src_fn maybe_bug src_timestamp + = do -- Preprocess the source file and get its imports -- The dflags' contains the OPTIONS pragmas - ; (dflags', hspp_fn) <- preprocess dflags src_fn - ; buf <- hGetStringBuffer hspp_fn - ; (srcimps, the_imps, mod_name) <- getImports dflags' buf hspp_fn + (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn maybe_buf + (srcimps, the_imps, mod_name) <- getImports dflags' buf hspp_fn - ; when (mod_name /= wanted_mod) $ + when (mod_name /= wanted_mod) $ throwDyn (ProgramError (showSDoc (text src_fn <> text ": file name does not match module name" <+> quotes (ppr mod_name)))) - -- Find its timestamp, and return the summary - ; src_timestamp <- getModificationTime src_fn - ; return (Just ( ModSummary { ms_mod = wanted_mod, - ms_hsc_src = hsc_src, - ms_location = location', - ms_hspp_file = Just hspp_fn, - ms_hspp_buf = Just buf, - ms_srcimps = srcimps, - ms_imps = the_imps, - ms_hs_date = src_timestamp })) - } + -- Find the object timestamp, and return the summary + obj_timestamp <- getObjTimestamp location is_boot + + return (Just ( ModSummary { ms_mod = wanted_mod, + ms_hsc_src = hsc_src, + ms_location = location, + ms_hspp_file = Just hspp_fn, + ms_hspp_buf = Just buf, + ms_srcimps = srcimps, + ms_imps = the_imps, + ms_hs_date = src_timestamp, + ms_obj_date = obj_timestamp })) + + +getObjTimestamp location is_boot + = if is_boot then return Nothing + else modificationTimeIfExists (ml_obj_file location) + + +preprocessFile :: DynFlags -> FilePath -> Maybe (StringBuffer,ClockTime) + -> IO (DynFlags, FilePath, StringBuffer) +preprocessFile dflags src_fn Nothing + = do + (dflags', hspp_fn) <- preprocess dflags src_fn + buf <- hGetStringBuffer hspp_fn + return (dflags', hspp_fn, buf) + +preprocessFile dflags src_fn (Just (buf, time)) + = do + -- case we bypass the preprocessing stage? + let + local_opts = getOptionsFromStringBuffer buf + -- + (dflags', errs) <- parseDynamicFlags dflags (map snd local_opts) + + let + needs_preprocessing + | Unlit _ <- startPhase src_fn = True + -- note: local_opts is only required if there's no Unlit phase + | dopt Opt_Cpp dflags' = True + | dopt Opt_Pp dflags' = True + | otherwise = False + + when needs_preprocessing $ + ghcError (ProgramError "buffer needs preprocesing; interactive check disabled") + + return (dflags', src_fn, buf) ----------------------------------------------------------------------------- @@ -1263,33 +1487,93 @@ workingDirectoryChanged s = withSession s $ \hsc_env -> -- ----------------------------------------------------------------------------- -- inspecting the session --- | Get the module dependency graph. After a 'load', this will contain --- only the modules that were successfully loaded. +-- | Get the module dependency graph. getModuleGraph :: Session -> IO ModuleGraph -- ToDo: DiGraph ModSummary getModuleGraph s = withSession s (return . hsc_mod_graph) +isLoaded :: Session -> Module -> IO Bool +isLoaded s m = withSession s $ \hsc_env -> + return $! isJust (lookupModuleEnv (hsc_HPT hsc_env) m) + getBindings :: Session -> IO [TyThing] getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC) getPrintUnqual :: Session -> IO PrintUnqualified getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC) +#ifdef GHCI +-- | 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 +#endif + +-- | 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 -> do + case lookupTypeEnv (ic_type_env (hsc_IC hsc_env)) name of + Just tt -> return (Just tt) + Nothing -> do + eps <- readIORef (hsc_EPS hsc_env) + return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name + +-- | Container for information about a 'Module'. +data ModuleInfo = ModuleInfo { + minf_details :: ModDetails, + minf_rdr_env :: Maybe GlobalRdrEnv + } + -- ToDo: this should really contain the ModIface too + -- We don't want HomeModInfo here, because a ModuleInfo applies + -- to package modules too. + +-- | Request information about a loaded 'Module' +getModuleInfo :: Session -> Module -> IO (Maybe ModuleInfo) +getModuleInfo s mdl = withSession s $ \hsc_env -> do + case lookupModuleEnv (hsc_HPT hsc_env) mdl of + Nothing -> return Nothing + Just hmi -> + return (Just (ModuleInfo { + minf_details = hm_details hmi, + minf_rdr_env = mi_globals $! hm_iface hmi + })) + + -- ToDo: we should be able to call getModuleInfo on a package module, + -- even one that isn't loaded yet. + +-- | The list of top-level entities defined in a module +modInfoTyThings :: ModuleInfo -> [TyThing] +modInfoTyThings minf = typeEnvElts (md_types (minf_details minf)) + +modInfoTopLevelScope :: ModuleInfo -> Maybe [Name] +modInfoTopLevelScope minf + = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf) + +modInfoExports :: ModuleInfo -> [Name] +modInfoExports minf = nameSetToList $! (md_exports $! minf_details minf) + +modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified +modInfoPrintUnqualified minf = fmap unQualInScope (minf_rdr_env minf) + +isDictonaryId :: Id -> Bool +isDictonaryId id + = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau } + #if 0 -getModuleInfo :: Session -> Module -> IO ModuleInfo data ObjectCode = ByteCode | BinaryCode FilePath -data ModuleInfo = ModuleInfo { - lm_modulename :: Module, - lm_summary :: ModSummary, - lm_interface :: ModIface, - lm_tc_code :: Maybe TypecheckedCode, - lm_rn_code :: Maybe RenamedCode, - lm_obj :: Maybe ObjectCode - } - type TypecheckedCode = HsTypecheckedGroup type RenamedCode = [HsGroup Name] @@ -1358,7 +1642,6 @@ setContext (Session ref) toplevs exports = do hsc_env <- readIORef ref let old_ic = hsc_IC hsc_env hpt = hsc_HPT hsc_env - dflags = hsc_dflags hsc_env mapM_ (checkModuleExists hsc_env hpt) exports export_env <- mkExportEnv hsc_env exports @@ -1408,9 +1691,15 @@ moduleIsInterpreted s modl = withSession s $ \h -> _not_a_home_module -> return False -- | Looks up an identifier in the current interactive context (for :info) +{-# DEPRECATED getInfo "we should be using parseName/lookupName instead" #-} getInfo :: Session -> String -> IO [GetInfoResult] getInfo s id = withSession s $ \hsc_env -> hscGetInfo hsc_env id +-- | 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)))) + -- ----------------------------------------------------------------------------- -- Getting the type of an expression @@ -1437,14 +1726,6 @@ typeKind s str = withSession s $ \hsc_env -> do Just kind -> return (Just kind) ----------------------------------------------------------------------------- --- lookupName: returns the TyThing for a Name in the interactive context. --- ToDo: should look it up in the full environment - -lookupName :: Session -> Name -> IO (Maybe TyThing) -lookupName s name = withSession s $ \hsc_env -> do - return $! lookupNameEnv (ic_type_env (hsc_IC hsc_env)) name - ------------------------------------------------------------------------------ -- cmCompileExpr: compile an expression and deliver an HValue compileExpr :: Session -> String -> IO (Maybe HValue) @@ -1544,6 +1825,7 @@ foreign import "rts_evalStableIO" {- safe -} -- --------------------------------------------------------------------------- -- cmBrowseModule: get all the TyThings defined in a module +{-# DEPRECATED browseModule "we should be using getModuleInfo instead" #-} browseModule :: Session -> Module -> Bool -> IO [IfaceDecl] browseModule s modl exports_only = withSession s $ \hsc_env -> do mb_decls <- getModuleContents hsc_env modl exports_only @@ -1561,6 +1843,6 @@ showModule s mod_summary = withSession s $ \hsc_env -> do Nothing -> panic "missing linkable" Just mod_info -> return (showModMsg obj_linkable mod_summary) where - obj_linkable = isObjectLinkable (hm_linkable mod_info) + obj_linkable = isObjectLinkable (fromJust (hm_linkable mod_info)) #endif /* GHCI */