--- -----------------------------------------------------------------------------\r
---\r
--- (c) The University of Glasgow, 2005\r
---\r
--- This module deals with --make\r
--- -----------------------------------------------------------------------------\r
-\r
-module GhcMake( \r
- depanal, \r
- load, LoadHowMuch(..),\r
-\r
- topSortModuleGraph, \r
-\r
- noModError, cyclicModuleErr\r
- ) where\r
-\r
-#include "HsVersions.h"\r
-\r
-#ifdef GHCI\r
-import qualified Linker ( unload )\r
-#endif\r
-\r
-import DriverPipeline\r
-import DriverPhases\r
-import GhcMonad\r
-import Module\r
-import HscTypes\r
-import ErrUtils\r
-import DynFlags\r
-import HsSyn hiding ((<.>))\r
-import Finder\r
-import HeaderInfo\r
-import TcIface ( typecheckIface )\r
-import TcRnMonad ( initIfaceCheck )\r
-import RdrName ( RdrName )\r
-\r
-import Exception ( evaluate, tryIO )\r
-import Panic\r
-import SysTools\r
-import BasicTypes\r
-import SrcLoc\r
-import Util\r
-import Digraph\r
-import Bag ( listToBag )\r
-import Maybes ( expectJust, mapCatMaybes )\r
-import StringBuffer\r
-import FastString\r
-import Outputable\r
-import UniqFM\r
-\r
-import qualified Data.Map as Map\r
-import qualified FiniteMap as Map( insertListWith)\r
-\r
-import System.Directory ( doesFileExist, getModificationTime )\r
-import System.IO ( fixIO )\r
-import System.IO.Error ( isDoesNotExistError )\r
-import System.Time ( ClockTime )\r
-import System.FilePath\r
-import Control.Monad\r
-import Data.Maybe\r
-import Data.List\r
-import qualified Data.List as List\r
-\r
--- -----------------------------------------------------------------------------\r
--- Loading the program\r
-\r
--- | Perform a dependency analysis starting from the current targets\r
--- and update the session with the new module graph.\r
---\r
--- Dependency analysis entails parsing the @import@ directives and may\r
--- therefore require running certain preprocessors.\r
---\r
--- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.\r
--- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the\r
--- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want to\r
--- changes to the 'DynFlags' to take effect you need to call this function\r
--- again.\r
---\r
-depanal :: GhcMonad m =>\r
- [ModuleName] -- ^ excluded modules\r
- -> Bool -- ^ allow duplicate roots\r
- -> m ModuleGraph\r
-depanal excluded_mods allow_dup_roots = do\r
- hsc_env <- getSession\r
- let\r
- dflags = hsc_dflags hsc_env\r
- targets = hsc_targets hsc_env\r
- old_graph = hsc_mod_graph hsc_env\r
- \r
- liftIO $ showPass dflags "Chasing dependencies"\r
- liftIO $ debugTraceMsg dflags 2 (hcat [\r
- text "Chasing modules from: ",\r
- hcat (punctuate comma (map pprTarget targets))])\r
-\r
- mod_graph <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots\r
- modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph }\r
- return mod_graph\r
-\r
--- | Describes which modules of the module graph need to be loaded.\r
-data LoadHowMuch\r
- = LoadAllTargets\r
- -- ^ Load all targets and its dependencies.\r
- | LoadUpTo ModuleName\r
- -- ^ Load only the given module and its dependencies.\r
- | LoadDependenciesOf ModuleName\r
- -- ^ Load only the dependencies of the given module, but not the module\r
- -- itself.\r
-\r
--- | Try to load the program. See 'LoadHowMuch' for the different modes.\r
---\r
--- This function implements the core of GHC's @--make@ mode. It preprocesses,\r
--- compiles and loads the specified modules, avoiding re-compilation wherever\r
--- possible. Depending on the target (see 'DynFlags.hscTarget') compilating\r
--- and loading may result in files being created on disk.\r
---\r
--- Calls the 'reportModuleCompilationResult' callback after each compiling\r
--- each module, whether successful or not.\r
---\r
--- Throw a 'SourceError' if errors are encountered before the actual\r
--- compilation starts (e.g., during dependency analysis). All other errors\r
--- are reported using the callback.\r
---\r
-load :: GhcMonad m => LoadHowMuch -> m SuccessFlag\r
-load how_much = do\r
- mod_graph <- depanal [] False\r
- load2 how_much mod_graph\r
-\r
-load2 :: GhcMonad m => LoadHowMuch -> [ModSummary]\r
- -> m SuccessFlag\r
-load2 how_much mod_graph = do\r
- guessOutputFile\r
- hsc_env <- getSession\r
-\r
- let hpt1 = hsc_HPT hsc_env\r
- let dflags = hsc_dflags hsc_env\r
-\r
- -- The "bad" boot modules are the ones for which we have\r
- -- B.hs-boot in the module graph, but no B.hs\r
- -- The downsweep should have ensured this does not happen\r
- -- (see msDeps)\r
- let all_home_mods = [ms_mod_name s \r
- | s <- mod_graph, not (isBootSummary s)]\r
- bad_boot_mods = [s | s <- mod_graph, isBootSummary s,\r
- not (ms_mod_name s `elem` all_home_mods)]\r
- ASSERT( null bad_boot_mods ) return ()\r
-\r
- -- check that the module given in HowMuch actually exists, otherwise\r
- -- topSortModuleGraph will bomb later.\r
- let checkHowMuch (LoadUpTo m) = checkMod m\r
- checkHowMuch (LoadDependenciesOf m) = checkMod m\r
- checkHowMuch _ = id\r
-\r
- checkMod m and_then\r
- | m `elem` all_home_mods = and_then\r
- | otherwise = do \r
- liftIO $ errorMsg dflags (text "no such module:" <+>\r
- quotes (ppr m))\r
- return Failed\r
-\r
- checkHowMuch how_much $ do\r
-\r
- -- mg2_with_srcimps drops the hi-boot nodes, returning a \r
- -- graph with cycles. Among other things, it is used for\r
- -- backing out partially complete cycles following a failed\r
- -- upsweep, and for removing from hpt all the modules\r
- -- not in strict downwards closure, during calls to compile.\r
- let mg2_with_srcimps :: [SCC ModSummary]\r
- mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing\r
-\r
- -- If we can determine that any of the {-# SOURCE #-} imports\r
- -- are definitely unnecessary, then emit a warning.\r
- warnUnnecessarySourceImports mg2_with_srcimps\r
-\r
- let\r
- -- check the stability property for each module.\r
- stable_mods@(stable_obj,stable_bco)\r
- = checkStability hpt1 mg2_with_srcimps all_home_mods\r
-\r
- -- prune bits of the HPT which are definitely redundant now,\r
- -- to save space.\r
- pruned_hpt = pruneHomePackageTable hpt1 \r
- (flattenSCCs mg2_with_srcimps)\r
- stable_mods\r
-\r
- _ <- liftIO $ evaluate pruned_hpt\r
-\r
- -- before we unload anything, make sure we don't leave an old\r
- -- interactive context around pointing to dead bindings. Also,\r
- -- write the pruned HPT to allow the old HPT to be GC'd.\r
- modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext,\r
- hsc_HPT = pruned_hpt }\r
-\r
- liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$\r
- text "Stable BCO:" <+> ppr stable_bco)\r
-\r
- -- Unload any modules which are going to be re-linked this time around.\r
- let stable_linkables = [ linkable\r
- | m <- stable_obj++stable_bco,\r
- Just hmi <- [lookupUFM pruned_hpt m],\r
- Just linkable <- [hm_linkable hmi] ]\r
- liftIO $ unload hsc_env stable_linkables\r
-\r
- -- We could at this point detect cycles which aren't broken by\r
- -- a source-import, and complain immediately, but it seems better\r
- -- to let upsweep_mods do this, so at least some useful work gets\r
- -- done before the upsweep is abandoned.\r
- --hPutStrLn stderr "after tsort:\n"\r
- --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))\r
-\r
- -- Now do the upsweep, calling compile for each module in\r
- -- turn. Final result is version 3 of everything.\r
-\r
- -- Topologically sort the module graph, this time including hi-boot\r
- -- nodes, and possibly just including the portion of the graph\r
- -- reachable from the module specified in the 2nd argument to load.\r
- -- This graph should be cycle-free.\r
- -- If we're restricting the upsweep to a portion of the graph, we\r
- -- also want to retain everything that is still stable.\r
- let full_mg :: [SCC ModSummary]\r
- full_mg = topSortModuleGraph False mod_graph Nothing\r
-\r
- maybe_top_mod = case how_much of\r
- LoadUpTo m -> Just m\r
- LoadDependenciesOf m -> Just m\r
- _ -> Nothing\r
-\r
- partial_mg0 :: [SCC ModSummary]\r
- partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod\r
-\r
- -- LoadDependenciesOf m: we want the upsweep to stop just\r
- -- short of the specified module (unless the specified module\r
- -- is stable).\r
- partial_mg\r
- | LoadDependenciesOf _mod <- how_much\r
- = ASSERT( case last partial_mg0 of \r
- AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )\r
- List.init partial_mg0\r
- | otherwise\r
- = partial_mg0\r
- \r
- stable_mg = \r
- [ AcyclicSCC ms\r
- | AcyclicSCC ms <- full_mg,\r
- ms_mod_name ms `elem` stable_obj++stable_bco,\r
- ms_mod_name ms `notElem` [ ms_mod_name ms' | \r
- AcyclicSCC ms' <- partial_mg ] ]\r
-\r
- mg = stable_mg ++ partial_mg\r
-\r
- -- clean up between compilations\r
- let cleanup = cleanTempFilesExcept dflags\r
- (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))\r
-\r
- liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")\r
- 2 (ppr mg))\r
-\r
- setSession hsc_env{ hsc_HPT = emptyHomePackageTable }\r
- (upsweep_ok, modsUpswept)\r
- <- upsweep pruned_hpt stable_mods cleanup mg\r
-\r
- -- Make modsDone be the summaries for each home module now\r
- -- available; this should equal the domain of hpt3.\r
- -- Get in in a roughly top .. bottom order (hence reverse).\r
-\r
- let modsDone = reverse modsUpswept\r
-\r
- -- Try and do linking in some form, depending on whether the\r
- -- upsweep was completely or only partially successful.\r
-\r
- if succeeded upsweep_ok\r
-\r
- then \r
- -- Easy; just relink it all.\r
- do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")\r
-\r
- -- Clean up after ourselves\r
- liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)\r
-\r
- -- Issue a warning for the confusing case where the user\r
- -- said '-o foo' but we're not going to do any linking.\r
- -- We attempt linking if either (a) one of the modules is\r
- -- called Main, or (b) the user said -no-hs-main, indicating\r
- -- that main() is going to come from somewhere else.\r
- --\r
- let ofile = outputFile dflags\r
- let no_hs_main = dopt Opt_NoHsMain dflags\r
- let \r
- main_mod = mainModIs dflags\r
- a_root_is_Main = any ((==main_mod).ms_mod) mod_graph\r
- do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib\r
-\r
- when (ghcLink dflags == LinkBinary \r
- && isJust ofile && not do_linking) $\r
- liftIO $ debugTraceMsg dflags 1 $\r
- text ("Warning: output was redirected with -o, " ++\r
- "but no output will be generated\n" ++\r
- "because there is no " ++ \r
- moduleNameString (moduleName main_mod) ++ " module.")\r
-\r
- -- link everything together\r
- hsc_env1 <- getSession\r
- linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)\r
-\r
- loadFinish Succeeded linkresult\r
-\r
- else \r
- -- Tricky. We need to back out the effects of compiling any\r
- -- half-done cycles, both so as to clean up the top level envs\r
- -- and to avoid telling the interactive linker to link them.\r
- do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")\r
-\r
- let modsDone_names\r
- = map ms_mod modsDone\r
- let mods_to_zap_names \r
- = findPartiallyCompletedCycles modsDone_names \r
- mg2_with_srcimps\r
- let mods_to_keep\r
- = filter ((`notElem` mods_to_zap_names).ms_mod) \r
- modsDone\r
-\r
- hsc_env1 <- getSession\r
- let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) \r
- (hsc_HPT hsc_env1)\r
-\r
- -- Clean up after ourselves\r
- liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)\r
-\r
- -- there should be no Nothings where linkables should be, now\r
- ASSERT(all (isJust.hm_linkable) \r
- (eltsUFM (hsc_HPT hsc_env))) do\r
- \r
- -- Link everything together\r
- linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4\r
-\r
- modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 }\r
- loadFinish Failed linkresult\r
-\r
--- Finish up after a load.\r
-\r
--- If the link failed, unload everything and return.\r
-loadFinish :: GhcMonad m =>\r
- SuccessFlag -> SuccessFlag\r
- -> m SuccessFlag\r
-loadFinish _all_ok Failed\r
- = do hsc_env <- getSession\r
- liftIO $ unload hsc_env []\r
- modifySession discardProg\r
- return Failed\r
-\r
--- Empty the interactive context and set the module context to the topmost\r
--- newly loaded module, or the Prelude if none were loaded.\r
-loadFinish all_ok Succeeded\r
- = do modifySession $ \hsc_env -> hsc_env{ hsc_IC = emptyInteractiveContext }\r
- return all_ok\r
-\r
-\r
--- Forget the current program, but retain the persistent info in HscEnv\r
-discardProg :: HscEnv -> HscEnv\r
-discardProg hsc_env\r
- = hsc_env { hsc_mod_graph = emptyMG, \r
- hsc_IC = emptyInteractiveContext,\r
- hsc_HPT = emptyHomePackageTable }\r
-\r
--- used to fish out the preprocess output files for the purposes of\r
--- cleaning up. The preprocessed file *might* be the same as the\r
--- source file, but that doesn't do any harm.\r
-ppFilesFromSummaries :: [ModSummary] -> [FilePath]\r
-ppFilesFromSummaries summaries = map ms_hspp_file summaries\r
-\r
--- | If there is no -o option, guess the name of target executable\r
--- by using top-level source file name as a base.\r
-guessOutputFile :: GhcMonad m => m ()\r
-guessOutputFile = modifySession $ \env ->\r
- let dflags = hsc_dflags env\r
- mod_graph = hsc_mod_graph env\r
- mainModuleSrcPath :: Maybe String\r
- mainModuleSrcPath = do\r
- let isMain = (== mainModIs dflags) . ms_mod\r
- [ms] <- return (filter isMain mod_graph)\r
- ml_hs_file (ms_location ms)\r
- name = fmap dropExtension mainModuleSrcPath\r
-\r
-#if defined(mingw32_HOST_OS)\r
- -- we must add the .exe extention unconditionally here, otherwise\r
- -- when name has an extension of its own, the .exe extension will\r
- -- not be added by DriverPipeline.exeFileName. See #2248\r
- name_exe = fmap (<.> "exe") name\r
-#else\r
- name_exe = name\r
-#endif\r
- in\r
- case outputFile dflags of\r
- Just _ -> env\r
- Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }\r
-\r
--- -----------------------------------------------------------------------------\r
-\r
--- | Prune the HomePackageTable\r
---\r
--- Before doing an upsweep, we can throw away:\r
---\r
--- - For non-stable modules:\r
--- - all ModDetails, all linked code\r
--- - all unlinked code that is out of date with respect to\r
--- the source file\r
---\r
--- This is VERY IMPORTANT otherwise we'll end up requiring 2x the\r
--- space at the end of the upsweep, because the topmost ModDetails of the\r
--- old HPT holds on to the entire type environment from the previous\r
--- compilation.\r
-\r
-pruneHomePackageTable\r
- :: HomePackageTable\r
- -> [ModSummary]\r
- -> ([ModuleName],[ModuleName])\r
- -> HomePackageTable\r
-\r
-pruneHomePackageTable hpt summ (stable_obj, stable_bco)\r
- = mapUFM prune hpt\r
- where prune hmi\r
- | is_stable modl = hmi'\r
- | otherwise = hmi'{ hm_details = emptyModDetails }\r
- where\r
- modl = moduleName (mi_module (hm_iface hmi))\r
- hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms\r
- = hmi{ hm_linkable = Nothing }\r
- | otherwise\r
- = hmi\r
- where ms = expectJust "prune" (lookupUFM ms_map modl)\r
-\r
- ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]\r
-\r
- is_stable m = m `elem` stable_obj || m `elem` stable_bco\r
-\r
--- -----------------------------------------------------------------------------\r
-\r
--- Return (names of) all those in modsDone who are part of a cycle\r
--- as defined by theGraph.\r
-findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]\r
-findPartiallyCompletedCycles modsDone theGraph\r
- = chew theGraph\r
- where\r
- chew [] = []\r
- chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting.\r
- chew ((CyclicSCC vs):rest)\r
- = let names_in_this_cycle = nub (map ms_mod vs)\r
- mods_in_this_cycle \r
- = nub ([done | done <- modsDone, \r
- done `elem` names_in_this_cycle])\r
- chewed_rest = chew rest\r
- in \r
- if notNull mods_in_this_cycle\r
- && length mods_in_this_cycle < length names_in_this_cycle\r
- then mods_in_this_cycle ++ chewed_rest\r
- else chewed_rest\r
-\r
-\r
--- ---------------------------------------------------------------------------\r
--- Unloading\r
-\r
-unload :: HscEnv -> [Linkable] -> IO ()\r
-unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'\r
- = case ghcLink (hsc_dflags hsc_env) of\r
-#ifdef GHCI\r
- LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables\r
-#else\r
- LinkInMemory -> panic "unload: no interpreter"\r
- -- urgh. avoid warnings:\r
- hsc_env stable_linkables\r
-#endif\r
- _other -> return ()\r
-\r
--- -----------------------------------------------------------------------------\r
-\r
-{- |\r
-\r
- Stability tells us which modules definitely do not need to be recompiled.\r
- There are two main reasons for having stability:\r
- \r
- - avoid doing a complete upsweep of the module graph in GHCi when\r
- modules near the bottom of the tree have not changed.\r
-\r
- - to tell GHCi when it can load object code: we can only load object code\r
- for a module when we also load object code fo all of the imports of the\r
- module. So we need to know that we will definitely not be recompiling\r
- any of these modules, and we can use the object code.\r
-\r
- The stability check is as follows. Both stableObject and\r
- stableBCO are used during the upsweep phase later.\r
-\r
-@\r
- stable m = stableObject m || stableBCO m\r
-\r
- stableObject m = \r
- all stableObject (imports m)\r
- && old linkable does not exist, or is == on-disk .o\r
- && date(on-disk .o) > date(.hs)\r
-\r
- stableBCO m =\r
- all stable (imports m)\r
- && date(BCO) > date(.hs)\r
-@\r
-\r
- These properties embody the following ideas:\r
-\r
- - if a module is stable, then:\r
-\r
- - if it has been compiled in a previous pass (present in HPT)\r
- then it does not need to be compiled or re-linked.\r
-\r
- - if it has not been compiled in a previous pass,\r
- then we only need to read its .hi file from disk and\r
- link it to produce a 'ModDetails'.\r
-\r
- - if a modules is not stable, we will definitely be at least\r
- re-linking, and possibly re-compiling it during the 'upsweep'.\r
- All non-stable modules can (and should) therefore be unlinked\r
- before the 'upsweep'.\r
-\r
- - Note that objects are only considered stable if they only depend\r
- on other objects. We can't link object code against byte code.\r
--}\r
-\r
-checkStability\r
- :: HomePackageTable -- HPT from last compilation\r
- -> [SCC ModSummary] -- current module graph (cyclic)\r
- -> [ModuleName] -- all home modules\r
- -> ([ModuleName], -- stableObject\r
- [ModuleName]) -- stableBCO\r
-\r
-checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs\r
- where\r
- checkSCC (stable_obj, stable_bco) scc0\r
- | stableObjects = (scc_mods ++ stable_obj, stable_bco)\r
- | stableBCOs = (stable_obj, scc_mods ++ stable_bco)\r
- | otherwise = (stable_obj, stable_bco)\r
- where\r
- scc = flattenSCC scc0\r
- scc_mods = map ms_mod_name scc\r
- home_module m = m `elem` all_home_mods && m `notElem` scc_mods\r
-\r
- scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))\r
- -- all imports outside the current SCC, but in the home pkg\r
- \r
- stable_obj_imps = map (`elem` stable_obj) scc_allimps\r
- stable_bco_imps = map (`elem` stable_bco) scc_allimps\r
-\r
- stableObjects = \r
- and stable_obj_imps\r
- && all object_ok scc\r
-\r
- stableBCOs = \r
- and (zipWith (||) stable_obj_imps stable_bco_imps)\r
- && all bco_ok scc\r
-\r
- object_ok ms\r
- | Just t <- ms_obj_date ms = t >= ms_hs_date ms \r
- && same_as_prev t\r
- | otherwise = False\r
- where\r
- same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of\r
- Just hmi | Just l <- hm_linkable hmi\r
- -> isObjectLinkable l && t == linkableTime l\r
- _other -> True\r
- -- why '>=' rather than '>' above? If the filesystem stores\r
- -- times to the nearset second, we may occasionally find that\r
- -- the object & source have the same modification time, \r
- -- especially if the source was automatically generated\r
- -- and compiled. Using >= is slightly unsafe, but it matches\r
- -- make's behaviour.\r
-\r
- bco_ok ms\r
- = case lookupUFM hpt (ms_mod_name ms) of\r
- Just hmi | Just l <- hm_linkable hmi ->\r
- not (isObjectLinkable l) && \r
- linkableTime l >= ms_hs_date ms\r
- _other -> False\r
-\r
--- -----------------------------------------------------------------------------\r
-\r
--- | The upsweep\r
---\r
--- This is where we compile each module in the module graph, in a pass\r
--- from the bottom to the top of the graph.\r
---\r
--- There better had not be any cyclic groups here -- we check for them.\r
-\r
-upsweep\r
- :: GhcMonad m\r
- => HomePackageTable -- ^ HPT from last time round (pruned)\r
- -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)\r
- -> IO () -- ^ How to clean up unwanted tmp files\r
- -> [SCC ModSummary] -- ^ Mods to do (the worklist)\r
- -> m (SuccessFlag,\r
- [ModSummary])\r
- -- ^ Returns:\r
- --\r
- -- 1. A flag whether the complete upsweep was successful.\r
- -- 2. The 'HscEnv' in the monad has an updated HPT\r
- -- 3. A list of modules which succeeded loading.\r
-\r
-upsweep old_hpt stable_mods cleanup sccs = do\r
- (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs)\r
- return (res, reverse done)\r
- where\r
-\r
- upsweep' _old_hpt done\r
- [] _ _\r
- = return (Succeeded, done)\r
-\r
- upsweep' _old_hpt done\r
- (CyclicSCC ms:_) _ _\r
- = do dflags <- getSessionDynFlags\r
- liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)\r
- return (Failed, done)\r
-\r
- upsweep' old_hpt done\r
- (AcyclicSCC mod:mods) mod_index nmods\r
- = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ \r
- -- show (map (moduleUserString.moduleName.mi_module.hm_iface) \r
- -- (moduleEnvElts (hsc_HPT hsc_env)))\r
- let logger _mod = defaultWarnErrLogger\r
-\r
- hsc_env <- getSession\r
- mb_mod_info\r
- <- handleSourceError\r
- (\err -> do logger mod (Just err); return Nothing) $ do\r
- mod_info <- liftIO $ upsweep_mod hsc_env old_hpt stable_mods\r
- mod mod_index nmods\r
- logger mod Nothing -- log warnings\r
- return (Just mod_info)\r
-\r
- liftIO cleanup -- Remove unwanted tmp files between compilations\r
-\r
- case mb_mod_info of\r
- Nothing -> return (Failed, done)\r
- Just mod_info -> do\r
- let this_mod = ms_mod_name mod\r
-\r
- -- Add new info to hsc_env\r
- hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info\r
- hsc_env1 = hsc_env { hsc_HPT = hpt1 }\r
-\r
- -- Space-saving: delete the old HPT entry\r
- -- for mod BUT if mod is a hs-boot\r
- -- node, don't delete it. For the\r
- -- interface, the HPT entry is probaby for the\r
- -- main Haskell source file. Deleting it\r
- -- would force the real module to be recompiled\r
- -- every time.\r
- old_hpt1 | isBootSummary mod = old_hpt\r
- | otherwise = delFromUFM old_hpt this_mod\r
-\r
- done' = mod:done\r
-\r
- -- fixup our HomePackageTable after we've finished compiling\r
- -- a mutually-recursive loop. See reTypecheckLoop, below.\r
- hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done'\r
- setSession hsc_env2\r
-\r
- upsweep' old_hpt1 done' mods (mod_index+1) nmods\r
-\r
--- | Compile a single module. Always produce a Linkable for it if\r
--- successful. If no compilation happened, return the old Linkable.\r
-upsweep_mod :: HscEnv\r
- -> HomePackageTable\r
- -> ([ModuleName],[ModuleName])\r
- -> ModSummary\r
- -> Int -- index of module\r
- -> Int -- total number of modules\r
- -> IO HomeModInfo\r
-\r
-upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods\r
- = let \r
- this_mod_name = ms_mod_name summary\r
- this_mod = ms_mod summary\r
- mb_obj_date = ms_obj_date summary\r
- obj_fn = ml_obj_file (ms_location summary)\r
- hs_date = ms_hs_date summary\r
-\r
- is_stable_obj = this_mod_name `elem` stable_obj\r
- is_stable_bco = this_mod_name `elem` stable_bco\r
-\r
- old_hmi = lookupUFM old_hpt this_mod_name\r
-\r
- -- We're using the dflags for this module now, obtained by\r
- -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.\r
- dflags = ms_hspp_opts summary\r
- prevailing_target = hscTarget (hsc_dflags hsc_env)\r
- local_target = hscTarget dflags\r
-\r
- -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that\r
- -- we don't do anything dodgy: these should only work to change\r
- -- from -fvia-C to -fasm and vice-versa, otherwise we could \r
- -- end up trying to link object code to byte code.\r
- target = if prevailing_target /= local_target\r
- && (not (isObjectTarget prevailing_target)\r
- || not (isObjectTarget local_target))\r
- then prevailing_target\r
- else local_target \r
-\r
- -- store the corrected hscTarget into the summary\r
- summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }\r
-\r
- -- The old interface is ok if\r
- -- a) we're compiling a source file, and the old HPT\r
- -- entry is for a source file\r
- -- b) we're compiling a hs-boot file\r
- -- Case (b) allows an hs-boot file to get the interface of its\r
- -- real source file on the second iteration of the compilation\r
- -- manager, but that does no harm. Otherwise the hs-boot file\r
- -- will always be recompiled\r
- \r
- mb_old_iface \r
- = case old_hmi of\r
- Nothing -> Nothing\r
- Just hm_info | isBootSummary summary -> Just iface\r
- | not (mi_boot iface) -> Just iface\r
- | otherwise -> Nothing\r
- where \r
- iface = hm_iface hm_info\r
-\r
- compile_it :: Maybe Linkable -> IO HomeModInfo\r
- compile_it mb_linkable = \r
- compile hsc_env summary' mod_index nmods \r
- mb_old_iface mb_linkable\r
-\r
- compile_it_discard_iface :: Maybe Linkable -> IO HomeModInfo\r
- compile_it_discard_iface mb_linkable =\r
- compile hsc_env summary' mod_index nmods\r
- Nothing mb_linkable\r
-\r
- -- With the HscNothing target we create empty linkables to avoid\r
- -- recompilation. We have to detect these to recompile anyway if\r
- -- the target changed since the last compile.\r
- is_fake_linkable\r
- | Just hmi <- old_hmi, Just l <- hm_linkable hmi =\r
- null (linkableUnlinked l)\r
- | otherwise =\r
- -- we have no linkable, so it cannot be fake\r
- False\r
-\r
- implies False _ = True\r
- implies True x = x\r
-\r
- in\r
- case () of\r
- _\r
- -- Regardless of whether we're generating object code or\r
- -- byte code, we can always use an existing object file\r
- -- if it is *stable* (see checkStability).\r
- | is_stable_obj, Just hmi <- old_hmi -> do\r
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5\r
- (text "skipping stable obj mod:" <+> ppr this_mod_name)\r
- return hmi\r
- -- object is stable, and we have an entry in the\r
- -- old HPT: nothing to do\r
-\r
- | is_stable_obj, isNothing old_hmi -> do\r
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5\r
- (text "compiling stable on-disk mod:" <+> ppr this_mod_name)\r
- linkable <- liftIO $ findObjectLinkable this_mod obj_fn\r
- (expectJust "upsweep1" mb_obj_date)\r
- compile_it (Just linkable)\r
- -- object is stable, but we need to load the interface\r
- -- off disk to make a HMI.\r
-\r
- | not (isObjectTarget target), is_stable_bco,\r
- (target /= HscNothing) `implies` not is_fake_linkable ->\r
- ASSERT(isJust old_hmi) -- must be in the old_hpt\r
- let Just hmi = old_hmi in do\r
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5\r
- (text "skipping stable BCO mod:" <+> ppr this_mod_name)\r
- return hmi\r
- -- BCO is stable: nothing to do\r
-\r
- | not (isObjectTarget target),\r
- Just hmi <- old_hmi,\r
- Just l <- hm_linkable hmi,\r
- not (isObjectLinkable l),\r
- (target /= HscNothing) `implies` not is_fake_linkable,\r
- linkableTime l >= ms_hs_date summary -> do\r
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5\r
- (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)\r
- compile_it (Just l)\r
- -- we have an old BCO that is up to date with respect\r
- -- to the source: do a recompilation check as normal.\r
-\r
- -- When generating object code, if there's an up-to-date\r
- -- object file on the disk, then we can use it.\r
- -- However, if the object file is new (compared to any\r
- -- linkable we had from a previous compilation), then we\r
- -- must discard any in-memory interface, because this\r
- -- means the user has compiled the source file\r
- -- separately and generated a new interface, that we must\r
- -- read from the disk.\r
- --\r
- | isObjectTarget target,\r
- Just obj_date <- mb_obj_date,\r
- obj_date >= hs_date -> do\r
- case old_hmi of\r
- Just hmi\r
- | Just l <- hm_linkable hmi,\r
- isObjectLinkable l && linkableTime l == obj_date -> do\r
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5\r
- (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)\r
- compile_it (Just l)\r
- _otherwise -> do\r
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5\r
- (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)\r
- linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date\r
- compile_it_discard_iface (Just linkable)\r
-\r
- _otherwise -> do\r
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5\r
- (text "compiling mod:" <+> ppr this_mod_name)\r
- compile_it Nothing\r
-\r
-\r
-\r
--- Filter modules in the HPT\r
-retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable\r
-retainInTopLevelEnvs keep_these hpt\r
- = listToUFM [ (mod, expectJust "retain" mb_mod_info)\r
- | mod <- keep_these\r
- , let mb_mod_info = lookupUFM hpt mod\r
- , isJust mb_mod_info ]\r
-\r
--- ---------------------------------------------------------------------------\r
--- Typecheck module loops\r
-\r
-{-\r
-See bug #930. This code fixes a long-standing bug in --make. The\r
-problem is that when compiling the modules *inside* a loop, a data\r
-type that is only defined at the top of the loop looks opaque; but\r
-after the loop is done, the structure of the data type becomes\r
-apparent.\r
-\r
-The difficulty is then that two different bits of code have\r
-different notions of what the data type looks like.\r
-\r
-The idea is that after we compile a module which also has an .hs-boot\r
-file, we re-generate the ModDetails for each of the modules that\r
-depends on the .hs-boot file, so that everyone points to the proper\r
-TyCons, Ids etc. defined by the real module, not the boot module.\r
-Fortunately re-generating a ModDetails from a ModIface is easy: the\r
-function TcIface.typecheckIface does exactly that.\r
-\r
-Picking the modules to re-typecheck is slightly tricky. Starting from\r
-the module graph consisting of the modules that have already been\r
-compiled, we reverse the edges (so they point from the imported module\r
-to the importing module), and depth-first-search from the .hs-boot\r
-node. This gives us all the modules that depend transitively on the\r
-.hs-boot module, and those are exactly the modules that we need to\r
-re-typecheck.\r
-\r
-Following this fix, GHC can compile itself with --make -O2.\r
--}\r
-\r
-reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv\r
-reTypecheckLoop hsc_env ms graph\r
- | not (isBootSummary ms) && \r
- any (\m -> ms_mod m == this_mod && isBootSummary m) graph\r
- = do\r
- let mss = reachableBackwards (ms_mod_name ms) graph\r
- non_boot = filter (not.isBootSummary) mss\r
- debugTraceMsg (hsc_dflags hsc_env) 2 $\r
- text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot)\r
- typecheckLoop hsc_env (map ms_mod_name non_boot)\r
- | otherwise\r
- = return hsc_env\r
- where\r
- this_mod = ms_mod ms\r
-\r
-typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv\r
-typecheckLoop hsc_env mods = do\r
- new_hpt <-\r
- fixIO $ \new_hpt -> do\r
- let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }\r
- mds <- initIfaceCheck new_hsc_env $ \r
- mapM (typecheckIface . hm_iface) hmis\r
- let new_hpt = addListToUFM old_hpt \r
- (zip mods [ hmi{ hm_details = details }\r
- | (hmi,details) <- zip hmis mds ])\r
- return new_hpt\r
- return hsc_env{ hsc_HPT = new_hpt }\r
- where\r
- old_hpt = hsc_HPT hsc_env\r
- hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods\r
-\r
-reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]\r
-reachableBackwards mod summaries\r
- = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]\r
- where -- the rest just sets up the graph:\r
- (graph, lookup_node) = moduleGraphNodes False summaries\r
- root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)\r
-\r
--- ---------------------------------------------------------------------------\r
--- Topological sort of the module graph\r
-\r
-type SummaryNode = (ModSummary, Int, [Int])\r
-\r
-topSortModuleGraph\r
- :: Bool\r
- -- ^ Drop hi-boot nodes? (see below)\r
- -> [ModSummary]\r
- -> Maybe ModuleName\r
- -- ^ Root module name. If @Nothing@, use the full graph.\r
- -> [SCC ModSummary]\r
--- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes\r
--- The resulting list of strongly-connected-components is in topologically\r
--- sorted order, starting with the module(s) at the bottom of the\r
--- dependency graph (ie compile them first) and ending with the ones at\r
--- the top.\r
---\r
--- Drop hi-boot nodes (first boolean arg)? \r
---\r
--- - @False@: treat the hi-boot summaries as nodes of the graph,\r
--- so the graph must be acyclic\r
---\r
--- - @True@: eliminate the hi-boot nodes, and instead pretend\r
--- the a source-import of Foo is an import of Foo\r
--- The resulting graph has no hi-boot nodes, but can be cyclic\r
-\r
-topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod\r
- = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph\r
- where\r
- (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries\r
- \r
- initial_graph = case mb_root_mod of\r
- Nothing -> graph\r
- Just root_mod ->\r
- -- restrict the graph to just those modules reachable from\r
- -- the specified module. We do this by building a graph with\r
- -- the full set of nodes, and determining the reachable set from\r
- -- the specified node.\r
- let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node\r
- | otherwise = ghcError (ProgramError "module does not exist")\r
- in graphFromEdgedVertices (seq root (reachableG graph root))\r
-\r
-summaryNodeKey :: SummaryNode -> Int\r
-summaryNodeKey (_, k, _) = k\r
-\r
-summaryNodeSummary :: SummaryNode -> ModSummary\r
-summaryNodeSummary (s, _, _) = s\r
-\r
-moduleGraphNodes :: Bool -> [ModSummary]\r
- -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)\r
-moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)\r
- where\r
- numbered_summaries = zip summaries [1..]\r
-\r
- lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode\r
- lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map\r
-\r
- lookup_key :: HscSource -> ModuleName -> Maybe Int\r
- lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)\r
-\r
- node_map :: NodeMap SummaryNode\r
- node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node)\r
- | node@(s, _, _) <- nodes ]\r
-\r
- -- We use integers as the keys for the SCC algorithm\r
- nodes :: [SummaryNode]\r
- nodes = [ (s, key, out_keys)\r
- | (s, key) <- numbered_summaries\r
- -- Drop the hi-boot ones if told to do so\r
- , not (isBootSummary s && drop_hs_boot_nodes)\r
- , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++\r
- out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++\r
- (-- see [boot-edges] below\r
- if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile \r
- then [] \r
- else case lookup_key HsBootFile (ms_mod_name s) of\r
- Nothing -> []\r
- Just k -> [k]) ]\r
-\r
- -- [boot-edges] if this is a .hs and there is an equivalent\r
- -- .hs-boot, add a link from the former to the latter. This\r
- -- has the effect of detecting bogus cases where the .hs-boot\r
- -- depends on the .hs, by introducing a cycle. Additionally,\r
- -- it ensures that we will always process the .hs-boot before\r
- -- the .hs, and so the HomePackageTable will always have the\r
- -- most up to date information.\r
-\r
- -- Drop hs-boot nodes by using HsSrcFile as the key\r
- hs_boot_key | drop_hs_boot_nodes = HsSrcFile\r
- | otherwise = HsBootFile\r
-\r
- out_edge_keys :: HscSource -> [ModuleName] -> [Int]\r
- out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms\r
- -- If we want keep_hi_boot_nodes, then we do lookup_key with\r
- -- the IsBootInterface parameter True; else False\r
-\r
-\r
-type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are \r
-type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs\r
-\r
-msKey :: ModSummary -> NodeKey\r
-msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)\r
-\r
-mkNodeMap :: [ModSummary] -> NodeMap ModSummary\r
-mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]\r
- \r
-nodeMapElts :: NodeMap a -> [a]\r
-nodeMapElts = Map.elems\r
-\r
--- | If there are {-# SOURCE #-} imports between strongly connected\r
--- components in the topological sort, then those imports can\r
--- definitely be replaced by ordinary non-SOURCE imports: if SOURCE\r
--- were necessary, then the edge would be part of a cycle.\r
-warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()\r
-warnUnnecessarySourceImports sccs = do\r
- logWarnings (listToBag (concatMap (check.flattenSCC) sccs))\r
- where check ms =\r
- let mods_in_this_cycle = map ms_mod_name ms in\r
- [ warn i | m <- ms, i <- ms_home_srcimps m,\r
- unLoc i `notElem` mods_in_this_cycle ]\r
-\r
- warn :: Located ModuleName -> WarnMsg\r
- warn (L loc mod) = \r
- mkPlainErrMsg loc\r
- (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ")\r
- <+> quotes (ppr mod))\r
-\r
------------------------------------------------------------------------------\r
--- Downsweep (dependency analysis)\r
-\r
--- Chase downwards from the specified root set, returning summaries\r
--- for all home modules encountered. Only follow source-import\r
--- links.\r
-\r
--- We pass in the previous collection of summaries, which is used as a\r
--- cache to avoid recalculating a module summary if the source is\r
--- unchanged.\r
---\r
--- The returned list of [ModSummary] nodes has one node for each home-package\r
--- module, plus one for any hs-boot files. The imports of these nodes \r
--- are all there, including the imports of non-home-package modules.\r
-\r
-downsweep :: HscEnv\r
- -> [ModSummary] -- Old summaries\r
- -> [ModuleName] -- Ignore dependencies on these; treat\r
- -- them as if they were package modules\r
- -> Bool -- True <=> allow multiple targets to have \r
- -- the same module name; this is \r
- -- very useful for ghc -M\r
- -> IO [ModSummary]\r
- -- The elts of [ModSummary] all have distinct\r
- -- (Modules, IsBoot) identifiers, unless the Bool is true\r
- -- in which case there can be repeats\r
-downsweep hsc_env old_summaries excl_mods allow_dup_roots\r
- = do\r
- rootSummaries <- mapM getRootSummary roots\r
- let root_map = mkRootMap rootSummaries\r
- checkDuplicates root_map\r
- summs <- loop (concatMap msDeps rootSummaries) root_map\r
- return summs\r
- where\r
- roots = hsc_targets hsc_env\r
-\r
- old_summary_map :: NodeMap ModSummary\r
- old_summary_map = mkNodeMap old_summaries\r
-\r
- getRootSummary :: Target -> IO ModSummary\r
- getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)\r
- = do exists <- liftIO $ doesFileExist file\r
- if exists \r
- then summariseFile hsc_env old_summaries file mb_phase \r
- obj_allowed maybe_buf\r
- else throwOneError $ mkPlainErrMsg noSrcSpan $\r
- text "can't find file:" <+> text file\r
- getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)\r
- = do maybe_summary <- summariseModule hsc_env old_summary_map False \r
- (L rootLoc modl) obj_allowed \r
- maybe_buf excl_mods\r
- case maybe_summary of\r
- Nothing -> packageModErr modl\r
- Just s -> return s\r
-\r
- rootLoc = mkGeneralSrcSpan (fsLit "<command line>")\r
-\r
- -- In a root module, the filename is allowed to diverge from the module\r
- -- name, so we have to check that there aren't multiple root files\r
- -- defining the same module (otherwise the duplicates will be silently\r
- -- ignored, leading to confusing behaviour).\r
- checkDuplicates :: NodeMap [ModSummary] -> IO ()\r
- checkDuplicates root_map \r
- | allow_dup_roots = return ()\r
- | null dup_roots = return ()\r
- | otherwise = liftIO $ multiRootsErr (head dup_roots)\r
- where\r
- dup_roots :: [[ModSummary]] -- Each at least of length 2\r
- dup_roots = filterOut isSingleton (nodeMapElts root_map)\r
-\r
- loop :: [(Located ModuleName,IsBootInterface)]\r
- -- Work list: process these modules\r
- -> NodeMap [ModSummary]\r
- -- Visited set; the range is a list because\r
- -- the roots can have the same module names\r
- -- if allow_dup_roots is True\r
- -> IO [ModSummary]\r
- -- The result includes the worklist, except\r
- -- for those mentioned in the visited set\r
- loop [] done = return (concat (nodeMapElts done))\r
- loop ((wanted_mod, is_boot) : ss) done \r
- | Just summs <- Map.lookup key done\r
- = if isSingleton summs then\r
- loop ss done\r
- else\r
- do { multiRootsErr summs; return [] }\r
- | otherwise\r
- = do mb_s <- summariseModule hsc_env old_summary_map \r
- is_boot wanted_mod True\r
- Nothing excl_mods\r
- case mb_s of\r
- Nothing -> loop ss done\r
- Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done)\r
- where\r
- key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)\r
-\r
--- XXX Does the (++) here need to be flipped?\r
-mkRootMap :: [ModSummary] -> NodeMap [ModSummary]\r
-mkRootMap summaries = Map.insertListWith (flip (++))\r
- [ (msKey s, [s]) | s <- summaries ]\r
- Map.empty\r
-\r
-msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]\r
--- (msDeps s) returns the dependencies of the ModSummary s.\r
--- A wrinkle is that for a {-# SOURCE #-} import we return\r
--- *both* the hs-boot file\r
--- *and* the source file\r
--- as "dependencies". That ensures that the list of all relevant\r
--- modules always contains B.hs if it contains B.hs-boot.\r
--- Remember, this pass isn't doing the topological sort. It's\r
--- just gathering the list of all relevant ModSummaries\r
-msDeps s = \r
- concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ] \r
- ++ [ (m,False) | m <- ms_home_imps s ] \r
-\r
-home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName]\r
-home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ]\r
- where isLocal Nothing = True\r
- isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special\r
- isLocal _ = False\r
-\r
-ms_home_allimps :: ModSummary -> [ModuleName]\r
-ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)\r
-\r
-ms_home_srcimps :: ModSummary -> [Located ModuleName]\r
-ms_home_srcimps = home_imps . ms_srcimps\r
-\r
-ms_home_imps :: ModSummary -> [Located ModuleName]\r
-ms_home_imps = home_imps . ms_imps\r
-\r
------------------------------------------------------------------------------\r
--- Summarising modules\r
-\r
--- We have two types of summarisation:\r
---\r
--- * Summarise a file. This is used for the root module(s) passed to\r
--- cmLoadModules. The file is read, and used to determine the root\r
--- module name. The module name may differ from the filename.\r
---\r
--- * Summarise a module. We are given a module name, and must provide\r
--- a summary. The finder is used to locate the file in which the module\r
--- resides.\r
-\r
-summariseFile\r
- :: HscEnv\r
- -> [ModSummary] -- old summaries\r
- -> FilePath -- source file name\r
- -> Maybe Phase -- start phase\r
- -> Bool -- object code allowed?\r
- -> Maybe (StringBuffer,ClockTime)\r
- -> IO ModSummary\r
-\r
-summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf\r
- -- we can use a cached summary if one is available and the\r
- -- source file hasn't changed, But we have to look up the summary\r
- -- by source file, rather than module name as we do in summarise.\r
- | Just old_summary <- findSummaryBySourceFile old_summaries file\r
- = do\r
- let location = ms_location old_summary\r
-\r
- -- return the cached summary if the source didn't change\r
- src_timestamp <- case maybe_buf of\r
- Just (_,t) -> return t\r
- Nothing -> liftIO $ getModificationTime file\r
- -- The file exists; we checked in getRootSummary above.\r
- -- If it gets removed subsequently, then this \r
- -- getModificationTime may fail, but that's the right\r
- -- behaviour.\r
-\r
- if ms_hs_date old_summary == src_timestamp \r
- then do -- update the object-file timestamp\r
- obj_timestamp <-\r
- if isObjectTarget (hscTarget (hsc_dflags hsc_env)) \r
- || obj_allowed -- bug #1205\r
- then liftIO $ getObjTimestamp location False\r
- else return Nothing\r
- return old_summary{ ms_obj_date = obj_timestamp }\r
- else\r
- new_summary\r
-\r
- | otherwise\r
- = new_summary\r
- where\r
- new_summary = do\r
- let dflags = hsc_dflags hsc_env\r
-\r
- (dflags', hspp_fn, buf)\r
- <- preprocessFile hsc_env file mb_phase maybe_buf\r
-\r
- (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file\r
-\r
- -- Make a ModLocation for this file\r
- location <- liftIO $ mkHomeModLocation dflags mod_name file\r
-\r
- -- Tell the Finder cache where it is, so that subsequent calls\r
- -- to findModule will find it, even if it's not on any search path\r
- mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location\r
-\r
- src_timestamp <- case maybe_buf of\r
- Just (_,t) -> return t\r
- Nothing -> liftIO $ getModificationTime file\r
- -- getMofificationTime may fail\r
-\r
- -- when the user asks to load a source file by name, we only\r
- -- use an object file if -fobject-code is on. See #1205.\r
- obj_timestamp <-\r
- if isObjectTarget (hscTarget (hsc_dflags hsc_env)) \r
- || obj_allowed -- bug #1205\r
- then liftIO $ modificationTimeIfExists (ml_obj_file location)\r
- else return Nothing\r
-\r
- return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,\r
- ms_location = location,\r
- ms_hspp_file = hspp_fn,\r
- ms_hspp_opts = dflags',\r
- ms_hspp_buf = Just buf,\r
- ms_srcimps = srcimps, ms_imps = the_imps,\r
- ms_hs_date = src_timestamp,\r
- ms_obj_date = obj_timestamp })\r
-\r
-findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary\r
-findSummaryBySourceFile summaries file\r
- = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],\r
- expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of\r
- [] -> Nothing\r
- (x:_) -> Just x\r
-\r
--- Summarise a module, and pick up source and timestamp.\r
-summariseModule\r
- :: HscEnv\r
- -> NodeMap ModSummary -- Map of old summaries\r
- -> IsBootInterface -- True <=> a {-# SOURCE #-} import\r
- -> Located ModuleName -- Imported module to be summarised\r
- -> Bool -- object code allowed?\r
- -> Maybe (StringBuffer, ClockTime)\r
- -> [ModuleName] -- Modules to exclude\r
- -> IO (Maybe ModSummary) -- Its new summary\r
-\r
-summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) \r
- obj_allowed maybe_buf excl_mods\r
- | wanted_mod `elem` excl_mods\r
- = return Nothing\r
-\r
- | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map\r
- = do -- Find its new timestamp; all the \r
- -- ModSummaries in the old map have valid ml_hs_files\r
- let location = ms_location old_summary\r
- src_fn = expectJust "summariseModule" (ml_hs_file location)\r
-\r
- -- check the modification time on the source file, and\r
- -- return the cached summary if it hasn't changed. If the\r
- -- file has disappeared, we need to call the Finder again.\r
- case maybe_buf of\r
- Just (_,t) -> check_timestamp old_summary location src_fn t\r
- Nothing -> do\r
- m <- tryIO (getModificationTime src_fn)\r
- case m of\r
- Right t -> check_timestamp old_summary location src_fn t\r
- Left e | isDoesNotExistError e -> find_it\r
- | otherwise -> ioError e\r
-\r
- | otherwise = find_it\r
- where\r
- dflags = hsc_dflags hsc_env\r
-\r
- hsc_src = if is_boot then HsBootFile else HsSrcFile\r
-\r
- check_timestamp old_summary location src_fn src_timestamp\r
- | ms_hs_date old_summary == src_timestamp = do\r
- -- update the object-file timestamp\r
- obj_timestamp <- \r
- if isObjectTarget (hscTarget (hsc_dflags hsc_env))\r
- || obj_allowed -- bug #1205\r
- then getObjTimestamp location is_boot\r
- else return Nothing\r
- return (Just old_summary{ ms_obj_date = obj_timestamp })\r
- | otherwise = \r
- -- source changed: re-summarise.\r
- new_summary location (ms_mod old_summary) src_fn src_timestamp\r
-\r
- find_it = do\r
- -- Don't use the Finder's cache this time. If the module was\r
- -- previously a package module, it may have now appeared on the\r
- -- search path, so we want to consider it to be a home module. If\r
- -- the module was previously a home module, it may have moved.\r
- uncacheModule hsc_env wanted_mod\r
- found <- findImportedModule hsc_env wanted_mod Nothing\r
- case found of\r
- Found location mod \r
- | isJust (ml_hs_file location) ->\r
- -- Home package\r
- just_found location mod\r
- | otherwise -> \r
- -- Drop external-pkg\r
- ASSERT(modulePackageId mod /= thisPackage dflags)\r
- return Nothing\r
- \r
- err -> noModError dflags loc wanted_mod err\r
- -- Not found\r
-\r
- just_found location mod = do\r
- -- Adjust location to point to the hs-boot source file, \r
- -- hi file, object file, when is_boot says so\r
- let location' | is_boot = addBootSuffixLocn location\r
- | otherwise = location\r
- src_fn = expectJust "summarise2" (ml_hs_file location')\r
-\r
- -- Check that it exists\r
- -- It might have been deleted since the Finder last found it\r
- maybe_t <- modificationTimeIfExists src_fn\r
- case maybe_t of\r
- Nothing -> noHsFileErr loc src_fn\r
- Just t -> new_summary location' mod src_fn t\r
-\r
-\r
- new_summary location mod src_fn src_timestamp\r
- = do\r
- -- Preprocess the source file and get its imports\r
- -- The dflags' contains the OPTIONS pragmas\r
- (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf\r
- (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn\r
-\r
- when (mod_name /= wanted_mod) $\r
- throwOneError $ mkPlainErrMsg mod_loc $ \r
- text "File name does not match module name:" \r
- $$ text "Saw:" <+> quotes (ppr mod_name)\r
- $$ text "Expected:" <+> quotes (ppr wanted_mod)\r
-\r
- -- Find the object timestamp, and return the summary\r
- obj_timestamp <-\r
- if isObjectTarget (hscTarget (hsc_dflags hsc_env))\r
- || obj_allowed -- bug #1205\r
- then getObjTimestamp location is_boot\r
- else return Nothing\r
-\r
- return (Just (ModSummary { ms_mod = mod,\r
- ms_hsc_src = hsc_src,\r
- ms_location = location,\r
- ms_hspp_file = hspp_fn,\r
- ms_hspp_opts = dflags',\r
- ms_hspp_buf = Just buf,\r
- ms_srcimps = srcimps,\r
- ms_imps = the_imps,\r
- ms_hs_date = src_timestamp,\r
- ms_obj_date = obj_timestamp }))\r
-\r
-\r
-getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime)\r
-getObjTimestamp location is_boot\r
- = if is_boot then return Nothing\r
- else modificationTimeIfExists (ml_obj_file location)\r
-\r
-\r
-preprocessFile :: HscEnv\r
- -> FilePath\r
- -> Maybe Phase -- ^ Starting phase\r
- -> Maybe (StringBuffer,ClockTime)\r
- -> IO (DynFlags, FilePath, StringBuffer)\r
-preprocessFile hsc_env src_fn mb_phase Nothing\r
- = do\r
- (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)\r
- buf <- hGetStringBuffer hspp_fn\r
- return (dflags', hspp_fn, buf)\r
-\r
-preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))\r
- = do\r
- let dflags = hsc_dflags hsc_env\r
- -- case we bypass the preprocessing stage?\r
- let \r
- local_opts = getOptions dflags buf src_fn\r
- --\r
- (dflags', leftovers, warns)\r
- <- parseDynamicNoPackageFlags dflags local_opts\r
- checkProcessArgsResult leftovers\r
- handleFlagWarnings dflags' warns\r
-\r
- let\r
- needs_preprocessing\r
- | Just (Unlit _) <- mb_phase = True\r
- | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True\r
- -- note: local_opts is only required if there's no Unlit phase\r
- | xopt Opt_Cpp dflags' = True\r
- | dopt Opt_Pp dflags' = True\r
- | otherwise = False\r
-\r
- when needs_preprocessing $\r
- ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")\r
-\r
- return (dflags', src_fn, buf)\r
-\r
-\r
------------------------------------------------------------------------------\r
--- Error messages\r
------------------------------------------------------------------------------\r
-\r
-noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab\r
--- ToDo: we don't have a proper line number for this error\r
-noModError dflags loc wanted_mod err\r
- = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err\r
- \r
-noHsFileErr :: SrcSpan -> String -> IO a\r
-noHsFileErr loc path\r
- = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path\r
- \r
-packageModErr :: ModuleName -> IO a\r
-packageModErr mod\r
- = throwOneError $ mkPlainErrMsg noSrcSpan $\r
- text "module" <+> quotes (ppr mod) <+> text "is a package module"\r
-\r
-multiRootsErr :: [ModSummary] -> IO ()\r
-multiRootsErr [] = panic "multiRootsErr"\r
-multiRootsErr summs@(summ1:_)\r
- = throwOneError $ mkPlainErrMsg noSrcSpan $\r
- text "module" <+> quotes (ppr mod) <+> \r
- text "is defined in multiple files:" <+>\r
- sep (map text files)\r
- where\r
- mod = ms_mod summ1\r
- files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs\r
-\r
-cyclicModuleErr :: [ModSummary] -> SDoc\r
-cyclicModuleErr ms\r
- = hang (ptext (sLit "Module imports form a cycle for modules:"))\r
- 2 (vcat (map show_one ms))\r
- where\r
- mods_in_cycle = map ms_mod_name ms\r
- imp_modname = unLoc . ideclName . unLoc\r
- just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname)\r
-\r
- show_one ms = \r
- vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+>\r
- maybe empty (parens . text) (ml_hs_file (ms_location ms)),\r
- nest 2 $ ptext (sLit "imports:") <+> vcat [\r
- pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms),\r
- pp_imps HsSrcFile (just_in_cycle $ ms_imps ms) ]\r
- ]\r
- show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)\r
- pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps)\r
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2011
+--
+-- This module implements multi-module compilation, and is used
+-- by --make and GHCi.
+--
+-- -----------------------------------------------------------------------------
+
+module GhcMake(
+ depanal,
+ load, LoadHowMuch(..),
+
+ topSortModuleGraph,
+
+ noModError, cyclicModuleErr
+ ) where
+
+#include "HsVersions.h"
+
+#ifdef GHCI
+import qualified Linker ( unload )
+#endif
+
+import DriverPipeline
+import DriverPhases
+import GhcMonad
+import Module
+import HscTypes
+import ErrUtils
+import DynFlags
+import HsSyn hiding ((<.>))
+import Finder
+import HeaderInfo
+import TcIface ( typecheckIface )
+import TcRnMonad ( initIfaceCheck )
+import RdrName ( RdrName )
+
+import Exception ( evaluate, tryIO )
+import Panic
+import SysTools
+import BasicTypes
+import SrcLoc
+import Util
+import Digraph
+import Bag ( listToBag )
+import Maybes ( expectJust, mapCatMaybes )
+import StringBuffer
+import FastString
+import Outputable
+import UniqFM
+
+import qualified Data.Map as Map
+import qualified FiniteMap as Map( insertListWith)
+
+import System.Directory ( doesFileExist, getModificationTime )
+import System.IO ( fixIO )
+import System.IO.Error ( isDoesNotExistError )
+import System.Time ( ClockTime )
+import System.FilePath
+import Control.Monad
+import Data.Maybe
+import Data.List
+import qualified Data.List as List
+
+-- -----------------------------------------------------------------------------
+-- Loading the program
+
+-- | Perform a dependency analysis starting from the current targets
+-- and update the session with the new module graph.
+--
+-- Dependency analysis entails parsing the @import@ directives and may
+-- therefore require running certain preprocessors.
+--
+-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.
+-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the
+-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want to
+-- changes to the 'DynFlags' to take effect you need to call this function
+-- again.
+--
+depanal :: GhcMonad m =>
+ [ModuleName] -- ^ excluded modules
+ -> Bool -- ^ allow duplicate roots
+ -> m ModuleGraph
+depanal excluded_mods allow_dup_roots = do
+ hsc_env <- getSession
+ let
+ dflags = hsc_dflags hsc_env
+ targets = hsc_targets hsc_env
+ old_graph = hsc_mod_graph hsc_env
+
+ liftIO $ showPass dflags "Chasing dependencies"
+ liftIO $ debugTraceMsg dflags 2 (hcat [
+ text "Chasing modules from: ",
+ hcat (punctuate comma (map pprTarget targets))])
+
+ mod_graph <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots
+ modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph }
+ return mod_graph
+
+-- | Describes which modules of the module graph need to be loaded.
+data LoadHowMuch
+ = LoadAllTargets
+ -- ^ Load all targets and its dependencies.
+ | LoadUpTo ModuleName
+ -- ^ Load only the given module and its dependencies.
+ | LoadDependenciesOf ModuleName
+ -- ^ Load only the dependencies of the given module, but not the module
+ -- itself.
+
+-- | Try to load the program. See 'LoadHowMuch' for the different modes.
+--
+-- This function implements the core of GHC's @--make@ mode. It preprocesses,
+-- compiles and loads the specified modules, avoiding re-compilation wherever
+-- possible. Depending on the target (see 'DynFlags.hscTarget') compilating
+-- and loading may result in files being created on disk.
+--
+-- Calls the 'reportModuleCompilationResult' callback after each compiling
+-- each module, whether successful or not.
+--
+-- Throw a 'SourceError' if errors are encountered before the actual
+-- compilation starts (e.g., during dependency analysis). All other errors
+-- are reported using the callback.
+--
+load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
+load how_much = do
+ mod_graph <- depanal [] False
+ load2 how_much mod_graph
+
+load2 :: GhcMonad m => LoadHowMuch -> [ModSummary]
+ -> m SuccessFlag
+load2 how_much mod_graph = do
+ guessOutputFile
+ hsc_env <- getSession
+
+ let hpt1 = hsc_HPT hsc_env
+ let dflags = hsc_dflags hsc_env
+
+ -- The "bad" boot modules are the ones for which we have
+ -- B.hs-boot in the module graph, but no B.hs
+ -- The downsweep should have ensured this does not happen
+ -- (see msDeps)
+ let all_home_mods = [ms_mod_name s
+ | s <- mod_graph, not (isBootSummary s)]
+ bad_boot_mods = [s | s <- mod_graph, isBootSummary s,
+ not (ms_mod_name s `elem` all_home_mods)]
+ ASSERT( null bad_boot_mods ) return ()
+
+ -- check that the module given in HowMuch actually exists, otherwise
+ -- topSortModuleGraph will bomb later.
+ let checkHowMuch (LoadUpTo m) = checkMod m
+ checkHowMuch (LoadDependenciesOf m) = checkMod m
+ checkHowMuch _ = id
+
+ checkMod m and_then
+ | m `elem` all_home_mods = and_then
+ | otherwise = do
+ liftIO $ errorMsg dflags (text "no such module:" <+>
+ quotes (ppr m))
+ return Failed
+
+ checkHowMuch how_much $ do
+
+ -- 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 Nothing
+
+ -- If we can determine that any of the {-# SOURCE #-} imports
+ -- are definitely unnecessary, then emit a warning.
+ warnUnnecessarySourceImports mg2_with_srcimps
+
+ let
+ -- check the stability property for each module.
+ stable_mods@(stable_obj,stable_bco)
+ = 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
+
+ _ <- liftIO $ evaluate pruned_hpt
+
+ -- before we unload anything, make sure we don't leave an old
+ -- interactive context around pointing to dead bindings. Also,
+ -- write the pruned HPT to allow the old HPT to be GC'd.
+ modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext,
+ hsc_HPT = pruned_hpt }
+
+ liftIO $ debugTraceMsg dflags 2 (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 <- [lookupUFM pruned_hpt m],
+ Just linkable <- [hm_linkable hmi] ]
+ liftIO $ unload hsc_env stable_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
+ -- done before the upsweep is abandoned.
+ --hPutStrLn stderr "after tsort:\n"
+ --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
+
+ -- 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_name ms == _mod; _ -> False )
+ List.init partial_mg0
+ | otherwise
+ = partial_mg0
+
+ stable_mg =
+ [ AcyclicSCC ms
+ | AcyclicSCC ms <- full_mg,
+ ms_mod_name ms `elem` stable_obj++stable_bco,
+ ms_mod_name ms `notElem` [ ms_mod_name ms' |
+ AcyclicSCC ms' <- partial_mg ] ]
+
+ mg = stable_mg ++ partial_mg
+
+ -- clean up between compilations
+ let cleanup = cleanTempFilesExcept dflags
+ (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
+
+ liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
+ 2 (ppr mg))
+
+ setSession hsc_env{ hsc_HPT = emptyHomePackageTable }
+ (upsweep_ok, modsUpswept)
+ <- upsweep pruned_hpt stable_mods cleanup mg
+
+ -- Make modsDone be the summaries for each home module now
+ -- available; this should equal the domain of hpt3.
+ -- Get in in a roughly top .. bottom order (hence reverse).
+
+ let modsDone = reverse modsUpswept
+
+ -- Try and do linking in some form, depending on whether the
+ -- upsweep was completely or only partially successful.
+
+ if succeeded upsweep_ok
+
+ then
+ -- Easy; just relink it all.
+ do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")
+
+ -- Clean up after ourselves
+ liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
+
+ -- Issue a warning for the confusing case where the user
+ -- said '-o foo' but we're not going to do any linking.
+ -- We attempt linking if either (a) one of the modules is
+ -- called Main, or (b) the user said -no-hs-main, indicating
+ -- that main() is going to come from somewhere else.
+ --
+ let ofile = outputFile dflags
+ let no_hs_main = dopt Opt_NoHsMain dflags
+ let
+ main_mod = mainModIs dflags
+ a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
+ do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib
+
+ when (ghcLink dflags == LinkBinary
+ && isJust ofile && not do_linking) $
+ liftIO $ 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
+ hsc_env1 <- getSession
+ linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
+
+ loadFinish Succeeded linkresult
+
+ 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 liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")
+
+ let modsDone_names
+ = map ms_mod modsDone
+ let mods_to_zap_names
+ = findPartiallyCompletedCycles modsDone_names
+ mg2_with_srcimps
+ let mods_to_keep
+ = filter ((`notElem` mods_to_zap_names).ms_mod)
+ modsDone
+
+ hsc_env1 <- getSession
+ let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
+ (hsc_HPT hsc_env1)
+
+ -- Clean up after ourselves
+ liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)
+
+ -- there should be no Nothings where linkables should be, now
+ ASSERT(all (isJust.hm_linkable)
+ (eltsUFM (hsc_HPT hsc_env))) do
+
+ -- Link everything together
+ linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4
+
+ modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 }
+ loadFinish Failed linkresult
+
+-- Finish up after a load.
+
+-- If the link failed, unload everything and return.
+loadFinish :: GhcMonad m =>
+ SuccessFlag -> SuccessFlag
+ -> m SuccessFlag
+loadFinish _all_ok Failed
+ = do hsc_env <- getSession
+ liftIO $ unload hsc_env []
+ modifySession discardProg
+ return Failed
+
+-- Empty the interactive context and set the module context to the topmost
+-- newly loaded module, or the Prelude if none were loaded.
+loadFinish all_ok Succeeded
+ = do modifySession $ \hsc_env -> 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
+ = hsc_env { hsc_mod_graph = emptyMG,
+ hsc_IC = emptyInteractiveContext,
+ hsc_HPT = emptyHomePackageTable }
+
+-- used to fish out the preprocess output files for the purposes of
+-- cleaning up. The preprocessed file *might* be the same as the
+-- source file, but that doesn't do any harm.
+ppFilesFromSummaries :: [ModSummary] -> [FilePath]
+ppFilesFromSummaries summaries = map ms_hspp_file summaries
+
+-- | If there is no -o option, guess the name of target executable
+-- by using top-level source file name as a base.
+guessOutputFile :: GhcMonad m => m ()
+guessOutputFile = modifySession $ \env ->
+ let dflags = hsc_dflags env
+ mod_graph = hsc_mod_graph env
+ mainModuleSrcPath :: Maybe String
+ mainModuleSrcPath = do
+ let isMain = (== mainModIs dflags) . ms_mod
+ [ms] <- return (filter isMain mod_graph)
+ ml_hs_file (ms_location ms)
+ name = fmap dropExtension mainModuleSrcPath
+
+#if defined(mingw32_HOST_OS)
+ -- we must add the .exe extention unconditionally here, otherwise
+ -- when name has an extension of its own, the .exe extension will
+ -- not be added by DriverPipeline.exeFileName. See #2248
+ name_exe = fmap (<.> "exe") name
+#else
+ name_exe = name
+#endif
+ in
+ case outputFile dflags of
+ Just _ -> env
+ Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }
+
+-- -----------------------------------------------------------------------------
+
+-- | 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]
+ -> ([ModuleName],[ModuleName])
+ -> HomePackageTable
+
+pruneHomePackageTable hpt summ (stable_obj, stable_bco)
+ = mapUFM prune hpt
+ where prune hmi
+ | is_stable modl = hmi'
+ | otherwise = hmi'{ hm_details = emptyModDetails }
+ where
+ modl = moduleName (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" (lookupUFM ms_map modl)
+
+ ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
+
+ 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.
+findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
+findPartiallyCompletedCycles modsDone theGraph
+ = chew theGraph
+ where
+ chew [] = []
+ chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting.
+ chew ((CyclicSCC vs):rest)
+ = let names_in_this_cycle = nub (map ms_mod vs)
+ mods_in_this_cycle
+ = nub ([done | done <- modsDone,
+ done `elem` names_in_this_cycle])
+ chewed_rest = chew rest
+ in
+ if notNull mods_in_this_cycle
+ && length mods_in_this_cycle < length names_in_this_cycle
+ then mods_in_this_cycle ++ chewed_rest
+ else chewed_rest
+
+
+-- ---------------------------------------------------------------------------
+-- Unloading
+
+unload :: HscEnv -> [Linkable] -> IO ()
+unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
+ = case ghcLink (hsc_dflags hsc_env) of
+#ifdef GHCI
+ LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables
+#else
+ LinkInMemory -> panic "unload: no interpreter"
+ -- urgh. avoid warnings:
+ hsc_env stable_linkables
+#endif
+ _other -> return ()
+
+-- -----------------------------------------------------------------------------
+
+{- |
+
+ 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.
+
+ 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, 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,
+ 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)
+ -> [ModuleName] -- all home modules
+ -> ([ModuleName], -- stableObject
+ [ModuleName]) -- 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_name scc
+ home_module m = m `elem` all_home_mods && m `notElem` scc_mods
+
+ scc_allimps = nub (filter home_module (concatMap ms_home_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 lookupUFM hpt (ms_mod_name ms) of
+ Just hmi | Just l <- hm_linkable hmi
+ -> isObjectLinkable l && t == linkableTime l
+ _other -> True
+ -- 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.
+
+ bco_ok ms
+ = case lookupUFM hpt (ms_mod_name ms) of
+ Just hmi | Just l <- hm_linkable hmi ->
+ not (isObjectLinkable l) &&
+ linkableTime l >= ms_hs_date ms
+ _other -> False
+
+-- -----------------------------------------------------------------------------
+
+-- | 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.
+--
+-- There better had not be any cyclic groups here -- we check for them.
+
+upsweep
+ :: GhcMonad m
+ => HomePackageTable -- ^ HPT from last time round (pruned)
+ -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)
+ -> IO () -- ^ How to clean up unwanted tmp files
+ -> [SCC ModSummary] -- ^ Mods to do (the worklist)
+ -> m (SuccessFlag,
+ [ModSummary])
+ -- ^ Returns:
+ --
+ -- 1. A flag whether the complete upsweep was successful.
+ -- 2. The 'HscEnv' in the monad has an updated HPT
+ -- 3. A list of modules which succeeded loading.
+
+upsweep old_hpt stable_mods cleanup sccs = do
+ (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs)
+ return (res, reverse done)
+ where
+
+ upsweep' _old_hpt done
+ [] _ _
+ = return (Succeeded, done)
+
+ upsweep' _old_hpt done
+ (CyclicSCC ms:_) _ _
+ = do dflags <- getSessionDynFlags
+ liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
+ return (Failed, done)
+
+ upsweep' old_hpt done
+ (AcyclicSCC mod:mods) mod_index nmods
+ = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
+ -- show (map (moduleUserString.moduleName.mi_module.hm_iface)
+ -- (moduleEnvElts (hsc_HPT hsc_env)))
+ let logger _mod = defaultWarnErrLogger
+
+ hsc_env <- getSession
+ mb_mod_info
+ <- handleSourceError
+ (\err -> do logger mod (Just err); return Nothing) $ do
+ mod_info <- liftIO $ upsweep_mod hsc_env old_hpt stable_mods
+ mod mod_index nmods
+ logger mod Nothing -- log warnings
+ return (Just mod_info)
+
+ liftIO cleanup -- Remove unwanted tmp files between compilations
+
+ case mb_mod_info of
+ Nothing -> return (Failed, done)
+ Just mod_info -> do
+ let this_mod = ms_mod_name mod
+
+ -- Add new info to hsc_env
+ hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info
+ hsc_env1 = hsc_env { hsc_HPT = hpt1 }
+
+ -- 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 the real module to be recompiled
+ -- every time.
+ old_hpt1 | isBootSummary mod = old_hpt
+ | otherwise = delFromUFM old_hpt this_mod
+
+ done' = mod:done
+
+ -- fixup our HomePackageTable after we've finished compiling
+ -- a mutually-recursive loop. See reTypecheckLoop, below.
+ hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done'
+ setSession hsc_env2
+
+ upsweep' old_hpt1 done' mods (mod_index+1) nmods
+
+-- | Compile a single module. Always produce a Linkable for it if
+-- successful. If no compilation happened, return the old Linkable.
+upsweep_mod :: HscEnv
+ -> HomePackageTable
+ -> ([ModuleName],[ModuleName])
+ -> ModSummary
+ -> Int -- index of module
+ -> Int -- total number of modules
+ -> IO HomeModInfo
+
+upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
+ = 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 HomeModInfo
+ compile_it mb_linkable =
+ compile hsc_env summary' mod_index nmods
+ mb_old_iface mb_linkable
+
+ compile_it_discard_iface :: Maybe Linkable -> IO HomeModInfo
+ compile_it_discard_iface mb_linkable =
+ compile hsc_env summary' mod_index nmods
+ Nothing mb_linkable
+
+ -- With the HscNothing target we create empty linkables to avoid
+ -- recompilation. We have to detect these to recompile anyway if
+ -- the target changed since the last compile.
+ is_fake_linkable
+ | Just hmi <- old_hmi, Just l <- hm_linkable hmi =
+ null (linkableUnlinked l)
+ | otherwise =
+ -- we have no linkable, so it cannot be fake
+ False
+
+ implies False _ = True
+ implies True x = x
+
+ in
+ case () of
+ _
+ -- 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, Just hmi <- old_hmi -> do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "skipping stable obj mod:" <+> ppr this_mod_name)
+ return hmi
+ -- object is stable, and we have an entry in the
+ -- old HPT: nothing to do
+
+ | is_stable_obj, isNothing old_hmi -> do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "compiling stable on-disk mod:" <+> ppr this_mod_name)
+ linkable <- liftIO $ findObjectLinkable this_mod obj_fn
+ (expectJust "upsweep1" mb_obj_date)
+ compile_it (Just linkable)
+ -- object is stable, but we need to load the interface
+ -- off disk to make a HMI.
+
+ | not (isObjectTarget target), is_stable_bco,
+ (target /= HscNothing) `implies` not is_fake_linkable ->
+ ASSERT(isJust old_hmi) -- must be in the old_hpt
+ let Just hmi = old_hmi in do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "skipping stable BCO mod:" <+> ppr this_mod_name)
+ return hmi
+ -- BCO is stable: nothing to do
+
+ | not (isObjectTarget target),
+ Just hmi <- old_hmi,
+ Just l <- hm_linkable hmi,
+ not (isObjectLinkable l),
+ (target /= HscNothing) `implies` not is_fake_linkable,
+ linkableTime l >= ms_hs_date summary -> do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)
+ 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.
+
+ -- 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.
+ --
+ | isObjectTarget target,
+ 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 -> do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)
+ compile_it (Just l)
+ _otherwise -> do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)
+ linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
+ compile_it_discard_iface (Just linkable)
+
+ _otherwise -> do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "compiling mod:" <+> ppr this_mod_name)
+ compile_it Nothing
+
+
+
+-- Filter modules in the HPT
+retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
+retainInTopLevelEnvs keep_these hpt
+ = listToUFM [ (mod, expectJust "retain" mb_mod_info)
+ | mod <- keep_these
+ , let mb_mod_info = lookupUFM hpt mod
+ , isJust mb_mod_info ]
+
+-- ---------------------------------------------------------------------------
+-- Typecheck module loops
+
+{-
+See bug #930. This code fixes a long-standing bug in --make. The
+problem is that when compiling the modules *inside* a loop, a data
+type that is only defined at the top of the loop looks opaque; but
+after the loop is done, the structure of the data type becomes
+apparent.
+
+The difficulty is then that two different bits of code have
+different notions of what the data type looks like.
+
+The idea is that after we compile a module which also has an .hs-boot
+file, we re-generate the ModDetails for each of the modules that
+depends on the .hs-boot file, so that everyone points to the proper
+TyCons, Ids etc. defined by the real module, not the boot module.
+Fortunately re-generating a ModDetails from a ModIface is easy: the
+function TcIface.typecheckIface does exactly that.
+
+Picking the modules to re-typecheck is slightly tricky. Starting from
+the module graph consisting of the modules that have already been
+compiled, we reverse the edges (so they point from the imported module
+to the importing module), and depth-first-search from the .hs-boot
+node. This gives us all the modules that depend transitively on the
+.hs-boot module, and those are exactly the modules that we need to
+re-typecheck.
+
+Following this fix, GHC can compile itself with --make -O2.
+-}
+
+reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
+reTypecheckLoop hsc_env ms graph
+ | not (isBootSummary ms) &&
+ any (\m -> ms_mod m == this_mod && isBootSummary m) graph
+ = do
+ let mss = reachableBackwards (ms_mod_name ms) graph
+ non_boot = filter (not.isBootSummary) mss
+ debugTraceMsg (hsc_dflags hsc_env) 2 $
+ text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot)
+ typecheckLoop hsc_env (map ms_mod_name non_boot)
+ | otherwise
+ = return hsc_env
+ where
+ this_mod = ms_mod ms
+
+typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv
+typecheckLoop hsc_env mods = do
+ new_hpt <-
+ fixIO $ \new_hpt -> do
+ let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }
+ mds <- initIfaceCheck new_hsc_env $
+ mapM (typecheckIface . hm_iface) hmis
+ let new_hpt = addListToUFM old_hpt
+ (zip mods [ hmi{ hm_details = details }
+ | (hmi,details) <- zip hmis mds ])
+ return new_hpt
+ return hsc_env{ hsc_HPT = new_hpt }
+ where
+ old_hpt = hsc_HPT hsc_env
+ hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods
+
+reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
+reachableBackwards mod summaries
+ = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]
+ where -- the rest just sets up the graph:
+ (graph, lookup_node) = moduleGraphNodes False summaries
+ root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
+
+-- ---------------------------------------------------------------------------
+-- Topological sort of the module graph
+
+type SummaryNode = (ModSummary, Int, [Int])
+
+topSortModuleGraph
+ :: Bool
+ -- ^ Drop hi-boot nodes? (see below)
+ -> [ModSummary]
+ -> Maybe ModuleName
+ -- ^ Root module name. If @Nothing@, use the full graph.
+ -> [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)?
+--
+-- - @False@: treat the hi-boot summaries as nodes of the graph,
+-- so the graph must be acyclic
+--
+-- - @True@: eliminate the hi-boot nodes, and instead pretend
+-- the a source-import of Foo is an import of Foo
+-- The resulting graph has no hi-boot nodes, but can be cyclic
+
+topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
+ = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
+ where
+ (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries
+
+ initial_graph = case mb_root_mod of
+ Nothing -> graph
+ Just root_mod ->
+ -- 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.
+ let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node
+ | otherwise = ghcError (ProgramError "module does not exist")
+ in graphFromEdgedVertices (seq root (reachableG graph root))
+
+summaryNodeKey :: SummaryNode -> Int
+summaryNodeKey (_, k, _) = k
+
+summaryNodeSummary :: SummaryNode -> ModSummary
+summaryNodeSummary (s, _, _) = s
+
+moduleGraphNodes :: Bool -> [ModSummary]
+ -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
+moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)
+ where
+ numbered_summaries = zip summaries [1..]
+
+ lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
+ lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map
+
+ lookup_key :: HscSource -> ModuleName -> Maybe Int
+ lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
+
+ node_map :: NodeMap SummaryNode
+ node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node)
+ | node@(s, _, _) <- nodes ]
+
+ -- We use integers as the keys for the SCC algorithm
+ nodes :: [SummaryNode]
+ nodes = [ (s, key, out_keys)
+ | (s, key) <- numbered_summaries
+ -- Drop the hi-boot ones if told to do so
+ , not (isBootSummary s && drop_hs_boot_nodes)
+ , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++
+ out_edge_keys HsSrcFile (map unLoc (ms_home_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]) ]
+
+ -- [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.
+
+ -- Drop hs-boot nodes by using HsSrcFile as the key
+ hs_boot_key | drop_hs_boot_nodes = HsSrcFile
+ | otherwise = HsBootFile
+
+ out_edge_keys :: HscSource -> [ModuleName] -> [Int]
+ out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
+ -- If we want keep_hi_boot_nodes, then we do lookup_key with
+ -- the IsBootInterface parameter True; else False
+
+
+type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are
+type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs
+
+msKey :: ModSummary -> NodeKey
+msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
+
+mkNodeMap :: [ModSummary] -> NodeMap ModSummary
+mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]
+
+nodeMapElts :: NodeMap a -> [a]
+nodeMapElts = Map.elems
+
+-- | 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 :: GhcMonad m => [SCC ModSummary] -> m ()
+warnUnnecessarySourceImports sccs = do
+ logWarnings (listToBag (concatMap (check.flattenSCC) sccs))
+ where check ms =
+ let mods_in_this_cycle = map ms_mod_name ms in
+ [ warn i | m <- ms, i <- ms_home_srcimps m,
+ unLoc i `notElem` mods_in_this_cycle ]
+
+ warn :: Located ModuleName -> WarnMsg
+ warn (L loc mod) =
+ mkPlainErrMsg loc
+ (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ")
+ <+> quotes (ppr mod))
+
+-----------------------------------------------------------------------------
+-- Downsweep (dependency analysis)
+
+-- Chase downwards from the specified root set, returning summaries
+-- for all home modules encountered. Only follow source-import
+-- links.
+
+-- We pass in the previous collection of summaries, which is used as a
+-- cache to avoid recalculating a module summary if the source is
+-- unchanged.
+--
+-- The returned list of [ModSummary] nodes has one node for each home-package
+-- module, plus one for any hs-boot files. The imports of these nodes
+-- are all there, including the imports of non-home-package modules.
+
+downsweep :: HscEnv
+ -> [ModSummary] -- Old summaries
+ -> [ModuleName] -- Ignore dependencies on these; treat
+ -- them as if they were package modules
+ -> Bool -- True <=> allow multiple targets to have
+ -- the same module name; this is
+ -- very useful for ghc -M
+ -> IO [ModSummary]
+ -- The elts of [ModSummary] all have distinct
+ -- (Modules, IsBoot) identifiers, unless the Bool is true
+ -- in which case there can be repeats
+downsweep hsc_env old_summaries excl_mods allow_dup_roots
+ = do
+ rootSummaries <- mapM getRootSummary roots
+ let root_map = mkRootMap rootSummaries
+ checkDuplicates root_map
+ summs <- loop (concatMap msDeps rootSummaries) root_map
+ return summs
+ where
+ roots = hsc_targets hsc_env
+
+ old_summary_map :: NodeMap ModSummary
+ old_summary_map = mkNodeMap old_summaries
+
+ getRootSummary :: Target -> IO ModSummary
+ getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
+ = do exists <- liftIO $ doesFileExist file
+ if exists
+ then summariseFile hsc_env old_summaries file mb_phase
+ obj_allowed maybe_buf
+ else throwOneError $ mkPlainErrMsg noSrcSpan $
+ text "can't find file:" <+> text file
+ getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
+ = do maybe_summary <- summariseModule hsc_env old_summary_map False
+ (L rootLoc modl) obj_allowed
+ maybe_buf excl_mods
+ case maybe_summary of
+ Nothing -> packageModErr modl
+ Just s -> return s
+
+ rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
+
+ -- In a root module, the filename is allowed to diverge from the module
+ -- name, so we have to check that there aren't multiple root files
+ -- defining the same module (otherwise the duplicates will be silently
+ -- ignored, leading to confusing behaviour).
+ checkDuplicates :: NodeMap [ModSummary] -> IO ()
+ checkDuplicates root_map
+ | allow_dup_roots = return ()
+ | null dup_roots = return ()
+ | otherwise = liftIO $ multiRootsErr (head dup_roots)
+ where
+ dup_roots :: [[ModSummary]] -- Each at least of length 2
+ dup_roots = filterOut isSingleton (nodeMapElts root_map)
+
+ loop :: [(Located ModuleName,IsBootInterface)]
+ -- Work list: process these modules
+ -> NodeMap [ModSummary]
+ -- Visited set; the range is a list because
+ -- the roots can have the same module names
+ -- if allow_dup_roots is True
+ -> IO [ModSummary]
+ -- The result includes the worklist, except
+ -- for those mentioned in the visited set
+ loop [] done = return (concat (nodeMapElts done))
+ loop ((wanted_mod, is_boot) : ss) done
+ | Just summs <- Map.lookup key done
+ = if isSingleton summs then
+ loop ss done
+ else
+ do { multiRootsErr summs; return [] }
+ | otherwise
+ = do mb_s <- summariseModule hsc_env old_summary_map
+ is_boot wanted_mod True
+ Nothing excl_mods
+ case mb_s of
+ Nothing -> loop ss done
+ Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done)
+ where
+ key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
+
+-- XXX Does the (++) here need to be flipped?
+mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
+mkRootMap summaries = Map.insertListWith (flip (++))
+ [ (msKey s, [s]) | s <- summaries ]
+ Map.empty
+
+msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
+-- (msDeps s) returns the dependencies of the ModSummary s.
+-- A wrinkle is that for a {-# SOURCE #-} import we return
+-- *both* the hs-boot file
+-- *and* the source file
+-- as "dependencies". That ensures that the list of all relevant
+-- modules always contains B.hs if it contains B.hs-boot.
+-- Remember, this pass isn't doing the topological sort. It's
+-- just gathering the list of all relevant ModSummaries
+msDeps s =
+ concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ]
+ ++ [ (m,False) | m <- ms_home_imps s ]
+
+home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName]
+home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ]
+ where isLocal Nothing = True
+ isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
+ isLocal _ = False
+
+ms_home_allimps :: ModSummary -> [ModuleName]
+ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)
+
+ms_home_srcimps :: ModSummary -> [Located ModuleName]
+ms_home_srcimps = home_imps . ms_srcimps
+
+ms_home_imps :: ModSummary -> [Located ModuleName]
+ms_home_imps = home_imps . ms_imps
+
+-----------------------------------------------------------------------------
+-- Summarising modules
+
+-- We have two types of summarisation:
+--
+-- * Summarise a file. This is used for the root module(s) passed to
+-- cmLoadModules. The file is read, and used to determine the root
+-- module name. The module name may differ from the filename.
+--
+-- * Summarise a module. We are given a module name, and must provide
+-- a summary. The finder is used to locate the file in which the module
+-- resides.
+
+summariseFile
+ :: HscEnv
+ -> [ModSummary] -- old summaries
+ -> FilePath -- source file name
+ -> Maybe Phase -- start phase
+ -> Bool -- object code allowed?
+ -> Maybe (StringBuffer,ClockTime)
+ -> IO ModSummary
+
+summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
+ -- we can use a cached summary if one is available and the
+ -- source file hasn't changed, But we have to look up the summary
+ -- by source file, rather than module name as we do in summarise.
+ | Just old_summary <- findSummaryBySourceFile old_summaries file
+ = do
+ let location = ms_location old_summary
+
+ -- return the cached summary if the source didn't change
+ src_timestamp <- case maybe_buf of
+ Just (_,t) -> return t
+ Nothing -> liftIO $ getModificationTime file
+ -- The file exists; we checked in getRootSummary above.
+ -- If it gets removed subsequently, then this
+ -- getModificationTime may fail, but that's the right
+ -- behaviour.
+
+ if ms_hs_date old_summary == src_timestamp
+ then do -- update the object-file timestamp
+ obj_timestamp <-
+ if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+ || obj_allowed -- bug #1205
+ then liftIO $ getObjTimestamp location False
+ else return Nothing
+ return old_summary{ ms_obj_date = obj_timestamp }
+ else
+ new_summary
+
+ | otherwise
+ = new_summary
+ where
+ new_summary = do
+ let dflags = hsc_dflags hsc_env
+
+ (dflags', hspp_fn, buf)
+ <- preprocessFile hsc_env file mb_phase maybe_buf
+
+ (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
+
+ -- Make a ModLocation for this file
+ location <- liftIO $ mkHomeModLocation dflags mod_name file
+
+ -- Tell the Finder cache where it is, so that subsequent calls
+ -- to findModule will find it, even if it's not on any search path
+ mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
+
+ src_timestamp <- case maybe_buf of
+ Just (_,t) -> return t
+ Nothing -> liftIO $ getModificationTime file
+ -- getMofificationTime may fail
+
+ -- when the user asks to load a source file by name, we only
+ -- use an object file if -fobject-code is on. See #1205.
+ obj_timestamp <-
+ if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+ || obj_allowed -- bug #1205
+ then liftIO $ modificationTimeIfExists (ml_obj_file location)
+ else return Nothing
+
+ return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
+ ms_location = location,
+ ms_hspp_file = hspp_fn,
+ ms_hspp_opts = dflags',
+ ms_hspp_buf = Just buf,
+ ms_srcimps = srcimps, ms_imps = the_imps,
+ ms_hs_date = src_timestamp,
+ ms_obj_date = obj_timestamp })
+
+findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
+findSummaryBySourceFile summaries file
+ = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
+ expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
+ [] -> Nothing
+ (x:_) -> Just x
+
+-- Summarise a module, and pick up source and timestamp.
+summariseModule
+ :: HscEnv
+ -> NodeMap ModSummary -- Map of old summaries
+ -> IsBootInterface -- True <=> a {-# SOURCE #-} import
+ -> Located ModuleName -- Imported module to be summarised
+ -> Bool -- object code allowed?
+ -> Maybe (StringBuffer, ClockTime)
+ -> [ModuleName] -- Modules to exclude
+ -> IO (Maybe ModSummary) -- Its new summary
+
+summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
+ obj_allowed maybe_buf excl_mods
+ | wanted_mod `elem` excl_mods
+ = return Nothing
+
+ | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map
+ = 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 = expectJust "summariseModule" (ml_hs_file location)
+
+ -- check the modification time on the source file, and
+ -- return the cached summary if it hasn't changed. If the
+ -- file has disappeared, we need to call the Finder again.
+ case maybe_buf of
+ Just (_,t) -> check_timestamp old_summary location src_fn t
+ Nothing -> do
+ m <- tryIO (getModificationTime src_fn)
+ case m of
+ Right t -> check_timestamp old_summary location src_fn t
+ Left e | isDoesNotExistError e -> find_it
+ | otherwise -> ioError e
+
+ | otherwise = find_it
+ where
+ dflags = hsc_dflags hsc_env
+
+ hsc_src = if is_boot then HsBootFile else HsSrcFile
+
+ check_timestamp old_summary location src_fn src_timestamp
+ | ms_hs_date old_summary == src_timestamp = do
+ -- update the object-file timestamp
+ obj_timestamp <-
+ if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+ || obj_allowed -- bug #1205
+ then getObjTimestamp location is_boot
+ else return Nothing
+ return (Just old_summary{ ms_obj_date = obj_timestamp })
+ | otherwise =
+ -- source changed: re-summarise.
+ new_summary location (ms_mod old_summary) src_fn src_timestamp
+
+ find_it = do
+ -- Don't use the Finder's cache this time. If the module was
+ -- previously a package module, it may have now appeared on the
+ -- search path, so we want to consider it to be a home module. If
+ -- the module was previously a home module, it may have moved.
+ uncacheModule hsc_env wanted_mod
+ found <- findImportedModule hsc_env wanted_mod Nothing
+ case found of
+ Found location mod
+ | isJust (ml_hs_file location) ->
+ -- Home package
+ just_found location mod
+ | otherwise ->
+ -- Drop external-pkg
+ ASSERT(modulePackageId mod /= thisPackage dflags)
+ return Nothing
+
+ err -> noModError dflags loc wanted_mod err
+ -- Not found
+
+ just_found location mod = 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 = expectJust "summarise2" (ml_hs_file location')
+
+ -- Check that it exists
+ -- It might have been deleted since the Finder last found it
+ maybe_t <- modificationTimeIfExists src_fn
+ case maybe_t of
+ Nothing -> noHsFileErr loc src_fn
+ Just t -> new_summary location' mod src_fn t
+
+
+ new_summary location mod src_fn src_timestamp
+ = do
+ -- Preprocess the source file and get its imports
+ -- The dflags' contains the OPTIONS pragmas
+ (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
+ (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
+
+ when (mod_name /= wanted_mod) $
+ throwOneError $ mkPlainErrMsg mod_loc $
+ text "File name does not match module name:"
+ $$ text "Saw:" <+> quotes (ppr mod_name)
+ $$ text "Expected:" <+> quotes (ppr wanted_mod)
+
+ -- Find the object timestamp, and return the summary
+ obj_timestamp <-
+ if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+ || obj_allowed -- bug #1205
+ then getObjTimestamp location is_boot
+ else return Nothing
+
+ return (Just (ModSummary { ms_mod = mod,
+ ms_hsc_src = hsc_src,
+ ms_location = location,
+ ms_hspp_file = hspp_fn,
+ ms_hspp_opts = dflags',
+ ms_hspp_buf = Just buf,
+ ms_srcimps = srcimps,
+ ms_imps = the_imps,
+ ms_hs_date = src_timestamp,
+ ms_obj_date = obj_timestamp }))
+
+
+getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime)
+getObjTimestamp location is_boot
+ = if is_boot then return Nothing
+ else modificationTimeIfExists (ml_obj_file location)
+
+
+preprocessFile :: HscEnv
+ -> FilePath
+ -> Maybe Phase -- ^ Starting phase
+ -> Maybe (StringBuffer,ClockTime)
+ -> IO (DynFlags, FilePath, StringBuffer)
+preprocessFile hsc_env src_fn mb_phase Nothing
+ = do
+ (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
+ buf <- hGetStringBuffer hspp_fn
+ return (dflags', hspp_fn, buf)
+
+preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
+ = do
+ let dflags = hsc_dflags hsc_env
+ -- case we bypass the preprocessing stage?
+ let
+ local_opts = getOptions dflags buf src_fn
+ --
+ (dflags', leftovers, warns)
+ <- parseDynamicNoPackageFlags dflags local_opts
+ checkProcessArgsResult leftovers
+ handleFlagWarnings dflags' warns
+
+ let
+ needs_preprocessing
+ | Just (Unlit _) <- mb_phase = True
+ | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
+ -- note: local_opts is only required if there's no Unlit phase
+ | xopt 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)
+
+
+-----------------------------------------------------------------------------
+-- Error messages
+-----------------------------------------------------------------------------
+
+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
+ = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
+
+noHsFileErr :: SrcSpan -> String -> IO a
+noHsFileErr loc path
+ = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path
+
+packageModErr :: ModuleName -> IO a
+packageModErr mod
+ = throwOneError $ mkPlainErrMsg noSrcSpan $
+ text "module" <+> quotes (ppr mod) <+> text "is a package module"
+
+multiRootsErr :: [ModSummary] -> IO ()
+multiRootsErr [] = panic "multiRootsErr"
+multiRootsErr summs@(summ1:_)
+ = throwOneError $ mkPlainErrMsg noSrcSpan $
+ text "module" <+> quotes (ppr mod) <+>
+ text "is defined in multiple files:" <+>
+ sep (map text files)
+ where
+ mod = ms_mod summ1
+ files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
+
+cyclicModuleErr :: [ModSummary] -> SDoc
+cyclicModuleErr ms
+ = hang (ptext (sLit "Module imports form a cycle for modules:"))
+ 2 (vcat (map show_one ms))
+ where
+ mods_in_cycle = map ms_mod_name ms
+ imp_modname = unLoc . ideclName . unLoc
+ just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname)
+
+ show_one ms =
+ vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+>
+ maybe empty (parens . text) (ml_hs_file (ms_location ms)),
+ nest 2 $ ptext (sLit "imports:") <+> vcat [
+ pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms),
+ pp_imps HsSrcFile (just_in_cycle $ ms_imps ms) ]
+ ]
+ show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
+ pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps)
projects / ghc-hetmet.git / commitdiff