Make module membership on ModuleGraph faster
[ghc.git] / compiler / main / GhcMake.hs
1 {-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-}
2 {-# LANGUAGE NamedFieldPuns #-}
3 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
4 -- NB: we specifically ignore deprecations. GHC 7.6 marks the .QSem module as
5 -- deprecated, although it became un-deprecated later. As a result, using 7.6
6 -- as your bootstrap compiler throws annoying warnings.
7
8 -- -----------------------------------------------------------------------------
9 --
10 -- (c) The University of Glasgow, 2011
11 --
12 -- This module implements multi-module compilation, and is used
13 -- by --make and GHCi.
14 --
15 -- -----------------------------------------------------------------------------
16 module GhcMake(
17 depanal,
18 load, load', LoadHowMuch(..),
19
20 topSortModuleGraph,
21
22 ms_home_srcimps, ms_home_imps,
23
24 IsBoot(..),
25 summariseModule,
26 hscSourceToIsBoot,
27 findExtraSigImports,
28 implicitRequirements,
29
30 noModError, cyclicModuleErr,
31 moduleGraphNodes, SummaryNode
32 ) where
33
34 #include "HsVersions.h"
35
36 import qualified Linker ( unload )
37
38 import DriverPhases
39 import DriverPipeline
40 import DynFlags
41 import ErrUtils
42 import Finder
43 import GhcMonad
44 import HeaderInfo
45 import HscTypes
46 import Module
47 import TcIface ( typecheckIface )
48 import TcRnMonad ( initIfaceCheck )
49 import HscMain
50
51 import Bag ( listToBag )
52 import BasicTypes
53 import Digraph
54 import Exception ( tryIO, gbracket, gfinally )
55 import FastString
56 import Maybes ( expectJust )
57 import Name
58 import MonadUtils ( allM, MonadIO )
59 import Outputable
60 import Panic
61 import SrcLoc
62 import StringBuffer
63 import UniqFM
64 import UniqDSet
65 import TcBackpack
66 import Packages
67 import UniqSet
68 import Util
69 import qualified GHC.LanguageExtensions as LangExt
70 import NameEnv
71 import FileCleanup
72
73 import Data.Either ( rights, partitionEithers )
74 import qualified Data.Map as Map
75 import Data.Map (Map)
76 import qualified Data.Set as Set
77 import qualified FiniteMap as Map ( insertListWith )
78
79 import Control.Concurrent ( forkIOWithUnmask, killThread )
80 import qualified GHC.Conc as CC
81 import Control.Concurrent.MVar
82 import Control.Concurrent.QSem
83 import Control.Exception
84 import Control.Monad
85 import Data.IORef
86 import Data.List
87 import qualified Data.List as List
88 import Data.Foldable (toList)
89 import Data.Maybe
90 import Data.Ord ( comparing )
91 import Data.Time
92 import System.Directory
93 import System.FilePath
94 import System.IO ( fixIO )
95 import System.IO.Error ( isDoesNotExistError )
96
97 import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )
98
99 label_self :: String -> IO ()
100 label_self thread_name = do
101 self_tid <- CC.myThreadId
102 CC.labelThread self_tid thread_name
103
104 -- -----------------------------------------------------------------------------
105 -- Loading the program
106
107 -- | Perform a dependency analysis starting from the current targets
108 -- and update the session with the new module graph.
109 --
110 -- Dependency analysis entails parsing the @import@ directives and may
111 -- therefore require running certain preprocessors.
112 --
113 -- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.
114 -- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the
115 -- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want
116 -- changes to the 'DynFlags' to take effect you need to call this function
117 -- again.
118 --
119 depanal :: GhcMonad m =>
120 [ModuleName] -- ^ excluded modules
121 -> Bool -- ^ allow duplicate roots
122 -> m ModuleGraph
123 depanal excluded_mods allow_dup_roots = do
124 hsc_env <- getSession
125 let
126 dflags = hsc_dflags hsc_env
127 targets = hsc_targets hsc_env
128 old_graph = hsc_mod_graph hsc_env
129
130 withTiming (pure dflags) (text "Chasing dependencies") (const ()) $ do
131 liftIO $ debugTraceMsg dflags 2 (hcat [
132 text "Chasing modules from: ",
133 hcat (punctuate comma (map pprTarget targets))])
134
135 -- Home package modules may have been moved or deleted, and new
136 -- source files may have appeared in the home package that shadow
137 -- external package modules, so we have to discard the existing
138 -- cached finder data.
139 liftIO $ flushFinderCaches hsc_env
140
141 mod_summariesE <- liftIO $ downsweep hsc_env (mgModSummaries old_graph)
142 excluded_mods allow_dup_roots
143 mod_summaries <- reportImportErrors mod_summariesE
144
145 let mod_graph = mkModuleGraph mod_summaries
146
147 warnMissingHomeModules hsc_env mod_graph
148
149 setSession hsc_env { hsc_mod_graph = mod_graph }
150 return mod_graph
151
152 -- Note [Missing home modules]
153 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
154 -- Sometimes user doesn't want GHC to pick up modules, not explicitly listed
155 -- in a command line. For example, cabal may want to enable this warning
156 -- when building a library, so that GHC warns user about modules, not listed
157 -- neither in `exposed-modules`, nor in `other-modules`.
158 --
159 -- Here "home module" means a module, that doesn't come from an other package.
160 --
161 -- For example, if GHC is invoked with modules "A" and "B" as targets,
162 -- but "A" imports some other module "C", then GHC will issue a warning
163 -- about module "C" not being listed in a command line.
164 --
165 -- The warning in enabled by `-Wmissing-home-modules`. See Trac #13129
166 warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m ()
167 warnMissingHomeModules hsc_env mod_graph =
168 when (wopt Opt_WarnMissingHomeModules dflags && not (null missing)) $
169 logWarnings (listToBag [warn])
170 where
171 dflags = hsc_dflags hsc_env
172 targets = map targetId (hsc_targets hsc_env)
173
174 is_known_module mod = any (is_my_target mod) targets
175
176 -- We need to be careful to handle the case where (possibly
177 -- path-qualified) filenames (aka 'TargetFile') rather than module
178 -- names are being passed on the GHC command-line.
179 --
180 -- For instance, `ghc --make src-exe/Main.hs` and
181 -- `ghc --make -isrc-exe Main` are supposed to be equivalent.
182 -- Note also that we can't always infer the associated module name
183 -- directly from the filename argument. See Trac #13727.
184 is_my_target mod (TargetModule name)
185 = moduleName (ms_mod mod) == name
186 is_my_target mod (TargetFile target_file _)
187 | Just mod_file <- ml_hs_file (ms_location mod)
188 = target_file == mod_file ||
189 -- We can get a file target even if a module name was
190 -- originally specified in a command line because it can
191 -- be converted in guessTarget (by appending .hs/.lhs).
192 -- So let's convert it back and compare with module name
193 mkModuleName (fst $ splitExtension target_file)
194 == moduleName (ms_mod mod)
195 is_my_target _ _ = False
196
197 missing = map (moduleName . ms_mod) $
198 filter (not . is_known_module) (mgModSummaries mod_graph)
199
200 msg = text "Modules are not listed in command line: "
201 <> sep (map ppr missing)
202 warn = makeIntoWarning
203 (Reason Opt_WarnMissingHomeModules)
204 (mkPlainErrMsg dflags noSrcSpan msg)
205
206 -- | Describes which modules of the module graph need to be loaded.
207 data LoadHowMuch
208 = LoadAllTargets
209 -- ^ Load all targets and its dependencies.
210 | LoadUpTo ModuleName
211 -- ^ Load only the given module and its dependencies.
212 | LoadDependenciesOf ModuleName
213 -- ^ Load only the dependencies of the given module, but not the module
214 -- itself.
215
216 -- | Try to load the program. See 'LoadHowMuch' for the different modes.
217 --
218 -- This function implements the core of GHC's @--make@ mode. It preprocesses,
219 -- compiles and loads the specified modules, avoiding re-compilation wherever
220 -- possible. Depending on the target (see 'DynFlags.hscTarget') compiling
221 -- and loading may result in files being created on disk.
222 --
223 -- Calls the 'defaultWarnErrLogger' after each compiling each module, whether
224 -- successful or not.
225 --
226 -- Throw a 'SourceError' if errors are encountered before the actual
227 -- compilation starts (e.g., during dependency analysis). All other errors
228 -- are reported using the 'defaultWarnErrLogger'.
229 --
230 load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
231 load how_much = do
232 mod_graph <- depanal [] False
233 load' how_much (Just batchMsg) mod_graph
234
235 -- | Generalized version of 'load' which also supports a custom
236 -- 'Messager' (for reporting progress) and 'ModuleGraph' (generally
237 -- produced by calling 'depanal'.
238 load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
239 load' how_much mHscMessage mod_graph = do
240 modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }
241 guessOutputFile
242 hsc_env <- getSession
243
244 let hpt1 = hsc_HPT hsc_env
245 let dflags = hsc_dflags hsc_env
246
247 -- The "bad" boot modules are the ones for which we have
248 -- B.hs-boot in the module graph, but no B.hs
249 -- The downsweep should have ensured this does not happen
250 -- (see msDeps)
251 let all_home_mods =
252 mkUniqSet [ ms_mod_name s
253 | s <- mgModSummaries mod_graph, not (isBootSummary s)]
254 -- TODO: Figure out what the correct form of this assert is. It's violated
255 -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot
256 -- files without corresponding hs files.
257 -- bad_boot_mods = [s | s <- mod_graph, isBootSummary s,
258 -- not (ms_mod_name s `elem` all_home_mods)]
259 -- ASSERT( null bad_boot_mods ) return ()
260
261 -- check that the module given in HowMuch actually exists, otherwise
262 -- topSortModuleGraph will bomb later.
263 let checkHowMuch (LoadUpTo m) = checkMod m
264 checkHowMuch (LoadDependenciesOf m) = checkMod m
265 checkHowMuch _ = id
266
267 checkMod m and_then
268 | m `elementOfUniqSet` all_home_mods = and_then
269 | otherwise = do
270 liftIO $ errorMsg dflags (text "no such module:" <+>
271 quotes (ppr m))
272 return Failed
273
274 checkHowMuch how_much $ do
275
276 -- mg2_with_srcimps drops the hi-boot nodes, returning a
277 -- graph with cycles. Among other things, it is used for
278 -- backing out partially complete cycles following a failed
279 -- upsweep, and for removing from hpt all the modules
280 -- not in strict downwards closure, during calls to compile.
281 let mg2_with_srcimps :: [SCC ModSummary]
282 mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
283
284 -- If we can determine that any of the {-# SOURCE #-} imports
285 -- are definitely unnecessary, then emit a warning.
286 warnUnnecessarySourceImports mg2_with_srcimps
287
288 let
289 -- check the stability property for each module.
290 stable_mods@(stable_obj,stable_bco)
291 = checkStability hpt1 mg2_with_srcimps all_home_mods
292
293 -- prune bits of the HPT which are definitely redundant now,
294 -- to save space.
295 pruned_hpt = pruneHomePackageTable hpt1
296 (flattenSCCs mg2_with_srcimps)
297 stable_mods
298
299 _ <- liftIO $ evaluate pruned_hpt
300
301 -- before we unload anything, make sure we don't leave an old
302 -- interactive context around pointing to dead bindings. Also,
303 -- write the pruned HPT to allow the old HPT to be GC'd.
304 setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt }
305
306 liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
307 text "Stable BCO:" <+> ppr stable_bco)
308
309 -- Unload any modules which are going to be re-linked this time around.
310 let stable_linkables = [ linkable
311 | m <- nonDetEltsUniqSet stable_obj ++
312 nonDetEltsUniqSet stable_bco,
313 -- It's OK to use nonDetEltsUniqSet here
314 -- because it only affects linking. Besides
315 -- this list only serves as a poor man's set.
316 Just hmi <- [lookupHpt pruned_hpt m],
317 Just linkable <- [hm_linkable hmi] ]
318 liftIO $ unload hsc_env stable_linkables
319
320 -- We could at this point detect cycles which aren't broken by
321 -- a source-import, and complain immediately, but it seems better
322 -- to let upsweep_mods do this, so at least some useful work gets
323 -- done before the upsweep is abandoned.
324 --hPutStrLn stderr "after tsort:\n"
325 --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
326
327 -- Now do the upsweep, calling compile for each module in
328 -- turn. Final result is version 3 of everything.
329
330 -- Topologically sort the module graph, this time including hi-boot
331 -- nodes, and possibly just including the portion of the graph
332 -- reachable from the module specified in the 2nd argument to load.
333 -- This graph should be cycle-free.
334 -- If we're restricting the upsweep to a portion of the graph, we
335 -- also want to retain everything that is still stable.
336 let full_mg :: [SCC ModSummary]
337 full_mg = topSortModuleGraph False mod_graph Nothing
338
339 maybe_top_mod = case how_much of
340 LoadUpTo m -> Just m
341 LoadDependenciesOf m -> Just m
342 _ -> Nothing
343
344 partial_mg0 :: [SCC ModSummary]
345 partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
346
347 -- LoadDependenciesOf m: we want the upsweep to stop just
348 -- short of the specified module (unless the specified module
349 -- is stable).
350 partial_mg
351 | LoadDependenciesOf _mod <- how_much
352 = ASSERT( case last partial_mg0 of
353 AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )
354 List.init partial_mg0
355 | otherwise
356 = partial_mg0
357
358 stable_mg =
359 [ AcyclicSCC ms
360 | AcyclicSCC ms <- full_mg,
361 stable_mod_summary ms ]
362
363 stable_mod_summary ms =
364 ms_mod_name ms `elementOfUniqSet` stable_obj ||
365 ms_mod_name ms `elementOfUniqSet` stable_bco
366
367 -- the modules from partial_mg that are not also stable
368 -- NB. also keep cycles, we need to emit an error message later
369 unstable_mg = filter not_stable partial_mg
370 where not_stable (CyclicSCC _) = True
371 not_stable (AcyclicSCC ms)
372 = not $ stable_mod_summary ms
373
374 -- Load all the stable modules first, before attempting to load
375 -- an unstable module (#7231).
376 mg = stable_mg ++ unstable_mg
377
378 -- clean up between compilations
379 let cleanup = cleanCurrentModuleTempFiles . hsc_dflags
380 liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
381 2 (ppr mg))
382
383 n_jobs <- case parMakeCount dflags of
384 Nothing -> liftIO getNumProcessors
385 Just n -> return n
386 let upsweep_fn | n_jobs > 1 = parUpsweep n_jobs
387 | otherwise = upsweep
388
389 setSession hsc_env{ hsc_HPT = emptyHomePackageTable }
390 (upsweep_ok, modsUpswept)
391 <- upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg
392
393 -- Make modsDone be the summaries for each home module now
394 -- available; this should equal the domain of hpt3.
395 -- Get in in a roughly top .. bottom order (hence reverse).
396
397 let modsDone = reverse modsUpswept
398
399 -- Try and do linking in some form, depending on whether the
400 -- upsweep was completely or only partially successful.
401
402 if succeeded upsweep_ok
403
404 then
405 -- Easy; just relink it all.
406 do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")
407
408 -- Clean up after ourselves
409 hsc_env1 <- getSession
410 liftIO $ cleanCurrentModuleTempFiles dflags
411
412 -- Issue a warning for the confusing case where the user
413 -- said '-o foo' but we're not going to do any linking.
414 -- We attempt linking if either (a) one of the modules is
415 -- called Main, or (b) the user said -no-hs-main, indicating
416 -- that main() is going to come from somewhere else.
417 --
418 let ofile = outputFile dflags
419 let no_hs_main = gopt Opt_NoHsMain dflags
420 let
421 main_mod = mainModIs dflags
422 a_root_is_Main = mgElemModule mod_graph main_mod
423 do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib
424
425 -- link everything together
426 linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
427
428 if ghcLink dflags == LinkBinary && isJust ofile && not do_linking
429 then do
430 liftIO $ errorMsg dflags $ text
431 ("output was redirected with -o, " ++
432 "but no output will be generated\n" ++
433 "because there is no " ++
434 moduleNameString (moduleName main_mod) ++ " module.")
435 -- This should be an error, not a warning (#10895).
436 loadFinish Failed linkresult
437 else
438 loadFinish Succeeded linkresult
439
440 else
441 -- Tricky. We need to back out the effects of compiling any
442 -- half-done cycles, both so as to clean up the top level envs
443 -- and to avoid telling the interactive linker to link them.
444 do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")
445
446 let modsDone_names
447 = map ms_mod modsDone
448 let mods_to_zap_names
449 = findPartiallyCompletedCycles modsDone_names
450 mg2_with_srcimps
451 let (mods_to_clean, mods_to_keep) =
452 partition ((`Set.member` mods_to_zap_names).ms_mod) modsDone
453 hsc_env1 <- getSession
454 let hpt4 = hsc_HPT hsc_env1
455 -- We must change the lifetime to TFL_CurrentModule for any temp
456 -- file created for an element of mod_to_clean during the upsweep.
457 -- These include preprocessed files and object files for loaded
458 -- modules.
459 unneeded_temps = concat
460 [ms_hspp_file : object_files
461 | ModSummary{ms_mod, ms_hspp_file} <- mods_to_clean
462 , let object_files = maybe [] linkableObjs $
463 lookupHpt hpt4 (moduleName ms_mod)
464 >>= hm_linkable
465 ]
466 liftIO $
467 changeTempFilesLifetime dflags TFL_CurrentModule unneeded_temps
468 liftIO $ cleanCurrentModuleTempFiles dflags
469
470 let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
471 hpt4
472
473 -- Clean up after ourselves
474
475 -- there should be no Nothings where linkables should be, now
476 let just_linkables =
477 isNoLink (ghcLink dflags)
478 || allHpt (isJust.hm_linkable)
479 (filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface)
480 hpt5)
481 ASSERT( just_linkables ) do
482
483 -- Link everything together
484 linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt5
485
486 modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 }
487 loadFinish Failed linkresult
488
489
490 -- | Finish up after a load.
491 loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag
492
493 -- If the link failed, unload everything and return.
494 loadFinish _all_ok Failed
495 = do hsc_env <- getSession
496 liftIO $ unload hsc_env []
497 modifySession discardProg
498 return Failed
499
500 -- Empty the interactive context and set the module context to the topmost
501 -- newly loaded module, or the Prelude if none were loaded.
502 loadFinish all_ok Succeeded
503 = do modifySession discardIC
504 return all_ok
505
506
507 -- | Forget the current program, but retain the persistent info in HscEnv
508 discardProg :: HscEnv -> HscEnv
509 discardProg hsc_env
510 = discardIC $ hsc_env { hsc_mod_graph = emptyMG
511 , hsc_HPT = emptyHomePackageTable }
512
513 -- | Discard the contents of the InteractiveContext, but keep the DynFlags.
514 -- It will also keep ic_int_print and ic_monad if their names are from
515 -- external packages.
516 discardIC :: HscEnv -> HscEnv
517 discardIC hsc_env
518 = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print
519 , ic_monad = new_ic_monad } }
520 where
521 -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic
522 !new_ic_int_print = keep_external_name ic_int_print
523 !new_ic_monad = keep_external_name ic_monad
524 dflags = ic_dflags old_ic
525 old_ic = hsc_IC hsc_env
526 empty_ic = emptyInteractiveContext dflags
527 keep_external_name ic_name
528 | nameIsFromExternalPackage this_pkg old_name = old_name
529 | otherwise = ic_name empty_ic
530 where
531 this_pkg = thisPackage dflags
532 old_name = ic_name old_ic
533
534 -- | If there is no -o option, guess the name of target executable
535 -- by using top-level source file name as a base.
536 guessOutputFile :: GhcMonad m => m ()
537 guessOutputFile = modifySession $ \env ->
538 let dflags = hsc_dflags env
539 -- Force mod_graph to avoid leaking env
540 !mod_graph = hsc_mod_graph env
541 mainModuleSrcPath :: Maybe String
542 mainModuleSrcPath = do
543 ms <- mgLookupModule mod_graph (mainModIs dflags)
544 ml_hs_file (ms_location ms)
545 name = fmap dropExtension mainModuleSrcPath
546
547 name_exe = do
548 #if defined(mingw32_HOST_OS)
549 -- we must add the .exe extension unconditionally here, otherwise
550 -- when name has an extension of its own, the .exe extension will
551 -- not be added by DriverPipeline.exeFileName. See #2248
552 name' <- fmap (<.> "exe") name
553 #else
554 name' <- name
555 #endif
556 mainModuleSrcPath' <- mainModuleSrcPath
557 -- #9930: don't clobber input files (unless they ask for it)
558 if name' == mainModuleSrcPath'
559 then throwGhcException . UsageError $
560 "default output name would overwrite the input file; " ++
561 "must specify -o explicitly"
562 else Just name'
563 in
564 case outputFile dflags of
565 Just _ -> env
566 Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }
567
568 -- -----------------------------------------------------------------------------
569 --
570 -- | Prune the HomePackageTable
571 --
572 -- Before doing an upsweep, we can throw away:
573 --
574 -- - For non-stable modules:
575 -- - all ModDetails, all linked code
576 -- - all unlinked code that is out of date with respect to
577 -- the source file
578 --
579 -- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
580 -- space at the end of the upsweep, because the topmost ModDetails of the
581 -- old HPT holds on to the entire type environment from the previous
582 -- compilation.
583 pruneHomePackageTable :: HomePackageTable
584 -> [ModSummary]
585 -> StableModules
586 -> HomePackageTable
587 pruneHomePackageTable hpt summ (stable_obj, stable_bco)
588 = mapHpt prune hpt
589 where prune hmi
590 | is_stable modl = hmi'
591 | otherwise = hmi'{ hm_details = emptyModDetails }
592 where
593 modl = moduleName (mi_module (hm_iface hmi))
594 hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
595 = hmi{ hm_linkable = Nothing }
596 | otherwise
597 = hmi
598 where ms = expectJust "prune" (lookupUFM ms_map modl)
599
600 ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
601
602 is_stable m =
603 m `elementOfUniqSet` stable_obj ||
604 m `elementOfUniqSet` stable_bco
605
606 -- -----------------------------------------------------------------------------
607 --
608 -- | Return (names of) all those in modsDone who are part of a cycle as defined
609 -- by theGraph.
610 findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set.Set Module
611 findPartiallyCompletedCycles modsDone theGraph
612 = Set.unions
613 [mods_in_this_cycle
614 | CyclicSCC vs <- theGraph -- Acyclic? Not interesting.
615 , let names_in_this_cycle = Set.fromList (map ms_mod vs)
616 mods_in_this_cycle =
617 Set.intersection (Set.fromList modsDone) names_in_this_cycle
618 -- If size mods_in_this_cycle == size names_in_this_cycle,
619 -- then this cycle has already been completed and we're not
620 -- interested.
621 , Set.size mods_in_this_cycle < Set.size names_in_this_cycle]
622
623
624 -- ---------------------------------------------------------------------------
625 --
626 -- | Unloading
627 unload :: HscEnv -> [Linkable] -> IO ()
628 unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
629 = case ghcLink (hsc_dflags hsc_env) of
630 LinkInMemory -> Linker.unload hsc_env stable_linkables
631 _other -> return ()
632
633 -- -----------------------------------------------------------------------------
634 {- |
635
636 Stability tells us which modules definitely do not need to be recompiled.
637 There are two main reasons for having stability:
638
639 - avoid doing a complete upsweep of the module graph in GHCi when
640 modules near the bottom of the tree have not changed.
641
642 - to tell GHCi when it can load object code: we can only load object code
643 for a module when we also load object code fo all of the imports of the
644 module. So we need to know that we will definitely not be recompiling
645 any of these modules, and we can use the object code.
646
647 The stability check is as follows. Both stableObject and
648 stableBCO are used during the upsweep phase later.
649
650 @
651 stable m = stableObject m || stableBCO m
652
653 stableObject m =
654 all stableObject (imports m)
655 && old linkable does not exist, or is == on-disk .o
656 && date(on-disk .o) > date(.hs)
657
658 stableBCO m =
659 all stable (imports m)
660 && date(BCO) > date(.hs)
661 @
662
663 These properties embody the following ideas:
664
665 - if a module is stable, then:
666
667 - if it has been compiled in a previous pass (present in HPT)
668 then it does not need to be compiled or re-linked.
669
670 - if it has not been compiled in a previous pass,
671 then we only need to read its .hi file from disk and
672 link it to produce a 'ModDetails'.
673
674 - if a modules is not stable, we will definitely be at least
675 re-linking, and possibly re-compiling it during the 'upsweep'.
676 All non-stable modules can (and should) therefore be unlinked
677 before the 'upsweep'.
678
679 - Note that objects are only considered stable if they only depend
680 on other objects. We can't link object code against byte code.
681
682 - Note that even if an object is stable, we may end up recompiling
683 if the interface is out of date because an *external* interface
684 has changed. The current code in GhcMake handles this case
685 fairly poorly, so be careful.
686 -}
687
688 type StableModules =
689 ( UniqSet ModuleName -- stableObject
690 , UniqSet ModuleName -- stableBCO
691 )
692
693
694 checkStability
695 :: HomePackageTable -- HPT from last compilation
696 -> [SCC ModSummary] -- current module graph (cyclic)
697 -> UniqSet ModuleName -- all home modules
698 -> StableModules
699
700 checkStability hpt sccs all_home_mods =
701 foldl checkSCC (emptyUniqSet, emptyUniqSet) sccs
702 where
703 checkSCC :: StableModules -> SCC ModSummary -> StableModules
704 checkSCC (stable_obj, stable_bco) scc0
705 | stableObjects = (addListToUniqSet stable_obj scc_mods, stable_bco)
706 | stableBCOs = (stable_obj, addListToUniqSet stable_bco scc_mods)
707 | otherwise = (stable_obj, stable_bco)
708 where
709 scc = flattenSCC scc0
710 scc_mods = map ms_mod_name scc
711 home_module m =
712 m `elementOfUniqSet` all_home_mods && m `notElem` scc_mods
713
714 scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))
715 -- all imports outside the current SCC, but in the home pkg
716
717 stable_obj_imps = map (`elementOfUniqSet` stable_obj) scc_allimps
718 stable_bco_imps = map (`elementOfUniqSet` stable_bco) scc_allimps
719
720 stableObjects =
721 and stable_obj_imps
722 && all object_ok scc
723
724 stableBCOs =
725 and (zipWith (||) stable_obj_imps stable_bco_imps)
726 && all bco_ok scc
727
728 object_ok ms
729 | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False
730 | Just t <- ms_obj_date ms = t >= ms_hs_date ms
731 && same_as_prev t
732 | otherwise = False
733 where
734 same_as_prev t = case lookupHpt hpt (ms_mod_name ms) of
735 Just hmi | Just l <- hm_linkable hmi
736 -> isObjectLinkable l && t == linkableTime l
737 _other -> True
738 -- why '>=' rather than '>' above? If the filesystem stores
739 -- times to the nearset second, we may occasionally find that
740 -- the object & source have the same modification time,
741 -- especially if the source was automatically generated
742 -- and compiled. Using >= is slightly unsafe, but it matches
743 -- make's behaviour.
744 --
745 -- But see #5527, where someone ran into this and it caused
746 -- a problem.
747
748 bco_ok ms
749 | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False
750 | otherwise = case lookupHpt hpt (ms_mod_name ms) of
751 Just hmi | Just l <- hm_linkable hmi ->
752 not (isObjectLinkable l) &&
753 linkableTime l >= ms_hs_date ms
754 _other -> False
755
756 {- Parallel Upsweep
757 -
758 - The parallel upsweep attempts to concurrently compile the modules in the
759 - compilation graph using multiple Haskell threads.
760 -
761 - The Algorithm
762 -
763 - A Haskell thread is spawned for each module in the module graph, waiting for
764 - its direct dependencies to finish building before it itself begins to build.
765 -
766 - Each module is associated with an initially empty MVar that stores the
767 - result of that particular module's compile. If the compile succeeded, then
768 - the HscEnv (synchronized by an MVar) is updated with the fresh HMI of that
769 - module, and the module's HMI is deleted from the old HPT (synchronized by an
770 - IORef) to save space.
771 -
772 - Instead of immediately outputting messages to the standard handles, all
773 - compilation output is deferred to a per-module TQueue. A QSem is used to
774 - limit the number of workers that are compiling simultaneously.
775 -
776 - Meanwhile, the main thread sequentially loops over all the modules in the
777 - module graph, outputting the messages stored in each module's TQueue.
778 -}
779
780 -- | Each module is given a unique 'LogQueue' to redirect compilation messages
781 -- to. A 'Nothing' value contains the result of compilation, and denotes the
782 -- end of the message queue.
783 data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, MsgDoc)])
784 !(MVar ())
785
786 -- | The graph of modules to compile and their corresponding result 'MVar' and
787 -- 'LogQueue'.
788 type CompilationGraph = [(ModSummary, MVar SuccessFlag, LogQueue)]
789
790 -- | Build a 'CompilationGraph' out of a list of strongly-connected modules,
791 -- also returning the first, if any, encountered module cycle.
792 buildCompGraph :: [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary])
793 buildCompGraph [] = return ([], Nothing)
794 buildCompGraph (scc:sccs) = case scc of
795 AcyclicSCC ms -> do
796 mvar <- newEmptyMVar
797 log_queue <- do
798 ref <- newIORef []
799 sem <- newEmptyMVar
800 return (LogQueue ref sem)
801 (rest,cycle) <- buildCompGraph sccs
802 return ((ms,mvar,log_queue):rest, cycle)
803 CyclicSCC mss -> return ([], Just mss)
804
805 -- A Module and whether it is a boot module.
806 type BuildModule = (Module, IsBoot)
807
808 -- | 'Bool' indicating if a module is a boot module or not. We need to treat
809 -- boot modules specially when building compilation graphs, since they break
810 -- cycles. Regular source files and signature files are treated equivalently.
811 data IsBoot = IsBoot | NotBoot
812 deriving (Ord, Eq, Show, Read)
813
814 -- | Tests if an 'HscSource' is a boot file, primarily for constructing
815 -- elements of 'BuildModule'.
816 hscSourceToIsBoot :: HscSource -> IsBoot
817 hscSourceToIsBoot HsBootFile = IsBoot
818 hscSourceToIsBoot _ = NotBoot
819
820 mkBuildModule :: ModSummary -> BuildModule
821 mkBuildModule ms = (ms_mod ms, if isBootSummary ms then IsBoot else NotBoot)
822
823 -- | The entry point to the parallel upsweep.
824 --
825 -- See also the simpler, sequential 'upsweep'.
826 parUpsweep
827 :: GhcMonad m
828 => Int
829 -- ^ The number of workers we wish to run in parallel
830 -> Maybe Messager
831 -> HomePackageTable
832 -> StableModules
833 -> (HscEnv -> IO ())
834 -> [SCC ModSummary]
835 -> m (SuccessFlag,
836 [ModSummary])
837 parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
838 hsc_env <- getSession
839 let dflags = hsc_dflags hsc_env
840
841 when (not (null (unitIdsToCheck dflags))) $
842 throwGhcException (ProgramError "Backpack typechecking not supported with -j")
843
844 -- The bits of shared state we'll be using:
845
846 -- The global HscEnv is updated with the module's HMI when a module
847 -- successfully compiles.
848 hsc_env_var <- liftIO $ newMVar hsc_env
849
850 -- The old HPT is used for recompilation checking in upsweep_mod. When a
851 -- module successfully gets compiled, its HMI is pruned from the old HPT.
852 old_hpt_var <- liftIO $ newIORef old_hpt
853
854 -- What we use to limit parallelism with.
855 par_sem <- liftIO $ newQSem n_jobs
856
857
858 let updNumCapabilities = liftIO $ do
859 n_capabilities <- getNumCapabilities
860 n_cpus <- getNumProcessors
861 -- Setting number of capabilities more than
862 -- CPU count usually leads to high userspace
863 -- lock contention. Trac #9221
864 let n_caps = min n_jobs n_cpus
865 unless (n_capabilities /= 1) $ setNumCapabilities n_caps
866 return n_capabilities
867 -- Reset the number of capabilities once the upsweep ends.
868 let resetNumCapabilities orig_n = liftIO $ setNumCapabilities orig_n
869
870 gbracket updNumCapabilities resetNumCapabilities $ \_ -> do
871
872 -- Sync the global session with the latest HscEnv once the upsweep ends.
873 let finallySyncSession io = io `gfinally` do
874 hsc_env <- liftIO $ readMVar hsc_env_var
875 setSession hsc_env
876
877 finallySyncSession $ do
878
879 -- Build the compilation graph out of the list of SCCs. Module cycles are
880 -- handled at the very end, after some useful work gets done. Note that
881 -- this list is topologically sorted (by virtue of 'sccs' being sorted so).
882 (comp_graph,cycle) <- liftIO $ buildCompGraph sccs
883 let comp_graph_w_idx = zip comp_graph [1..]
884
885 -- The list of all loops in the compilation graph.
886 -- NB: For convenience, the last module of each loop (aka the module that
887 -- finishes the loop) is prepended to the beginning of the loop.
888 let comp_graph_loops = go graph
889 where
890 graph = mkModuleGraph (map fstOf3 (reverse comp_graph))
891 go mg
892 | Just (ms, mg') <- mgHead mg =
893 case getModLoop ms mg of
894 Just loop -> map mkBuildModule (ms:loop) : go mg'
895 Nothing -> go mg'
896 | otherwise = []
897
898 -- Build a Map out of the compilation graph with which we can efficiently
899 -- look up the result MVar associated with a particular home module.
900 let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)
901 home_mod_map =
902 Map.fromList [ (mkBuildModule ms, (mvar, idx))
903 | ((ms,mvar,_),idx) <- comp_graph_w_idx ]
904
905
906 liftIO $ label_self "main --make thread"
907 -- For each module in the module graph, spawn a worker thread that will
908 -- compile this module.
909 let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) ->
910 forkIOWithUnmask $ \unmask -> do
911 liftIO $ label_self $ unwords
912 [ "worker --make thread"
913 , "for module"
914 , show (moduleNameString (ms_mod_name mod))
915 , "number"
916 , show mod_idx
917 ]
918 -- Replace the default log_action with one that writes each
919 -- message to the module's log_queue. The main thread will
920 -- deal with synchronously printing these messages.
921 --
922 -- Use a local filesToClean var so that we can clean up
923 -- intermediate files in a timely fashion (as soon as
924 -- compilation for that module is finished) without having to
925 -- worry about accidentally deleting a simultaneous compile's
926 -- important files.
927 lcl_files_to_clean <- newIORef emptyFilesToClean
928 let lcl_dflags = dflags { log_action = parLogAction log_queue
929 , filesToClean = lcl_files_to_clean }
930
931 -- Unmask asynchronous exceptions and perform the thread-local
932 -- work to compile the module (see parUpsweep_one).
933 m_res <- try $ unmask $ prettyPrintGhcErrors lcl_dflags $
934 parUpsweep_one mod home_mod_map comp_graph_loops
935 lcl_dflags mHscMessage cleanup
936 par_sem hsc_env_var old_hpt_var
937 stable_mods mod_idx (length sccs)
938
939 res <- case m_res of
940 Right flag -> return flag
941 Left exc -> do
942 -- Don't print ThreadKilled exceptions: they are used
943 -- to kill the worker thread in the event of a user
944 -- interrupt, and the user doesn't have to be informed
945 -- about that.
946 when (fromException exc /= Just ThreadKilled)
947 (errorMsg lcl_dflags (text (show exc)))
948 return Failed
949
950 -- Populate the result MVar.
951 putMVar mvar res
952
953 -- Write the end marker to the message queue, telling the main
954 -- thread that it can stop waiting for messages from this
955 -- particular compile.
956 writeLogQueue log_queue Nothing
957
958 -- Add the remaining files that weren't cleaned up to the
959 -- global filesToClean ref, for cleanup later.
960 FilesToClean
961 { ftcCurrentModule = cm_files
962 , ftcGhcSession = gs_files
963 } <- readIORef (filesToClean lcl_dflags)
964 addFilesToClean dflags TFL_CurrentModule $ Set.toList cm_files
965 addFilesToClean dflags TFL_GhcSession $ Set.toList gs_files
966
967 -- Kill all the workers, masking interrupts (since killThread is
968 -- interruptible). XXX: This is not ideal.
969 ; killWorkers = uninterruptibleMask_ . mapM_ killThread }
970
971
972 -- Spawn the workers, making sure to kill them later. Collect the results
973 -- of each compile.
974 results <- liftIO $ bracket spawnWorkers killWorkers $ \_ ->
975 -- Loop over each module in the compilation graph in order, printing
976 -- each message from its log_queue.
977 forM comp_graph $ \(mod,mvar,log_queue) -> do
978 printLogs dflags log_queue
979 result <- readMVar mvar
980 if succeeded result then return (Just mod) else return Nothing
981
982
983 -- Collect and return the ModSummaries of all the successful compiles.
984 -- NB: Reverse this list to maintain output parity with the sequential upsweep.
985 let ok_results = reverse (catMaybes results)
986
987 -- Handle any cycle in the original compilation graph and return the result
988 -- of the upsweep.
989 case cycle of
990 Just mss -> do
991 liftIO $ fatalErrorMsg dflags (cyclicModuleErr mss)
992 return (Failed,ok_results)
993 Nothing -> do
994 let success_flag = successIf (all isJust results)
995 return (success_flag,ok_results)
996
997 where
998 writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,PprStyle,MsgDoc) -> IO ()
999 writeLogQueue (LogQueue ref sem) msg = do
1000 atomicModifyIORef' ref $ \msgs -> (msg:msgs,())
1001 _ <- tryPutMVar sem ()
1002 return ()
1003
1004 -- The log_action callback that is used to synchronize messages from a
1005 -- worker thread.
1006 parLogAction :: LogQueue -> LogAction
1007 parLogAction log_queue _dflags !reason !severity !srcSpan !style !msg = do
1008 writeLogQueue log_queue (Just (reason,severity,srcSpan,style,msg))
1009
1010 -- Print each message from the log_queue using the log_action from the
1011 -- session's DynFlags.
1012 printLogs :: DynFlags -> LogQueue -> IO ()
1013 printLogs !dflags (LogQueue ref sem) = read_msgs
1014 where read_msgs = do
1015 takeMVar sem
1016 msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs)
1017 print_loop msgs
1018
1019 print_loop [] = read_msgs
1020 print_loop (x:xs) = case x of
1021 Just (reason,severity,srcSpan,style,msg) -> do
1022 putLogMsg dflags reason severity srcSpan style msg
1023 print_loop xs
1024 -- Exit the loop once we encounter the end marker.
1025 Nothing -> return ()
1026
1027 -- The interruptible subset of the worker threads' work.
1028 parUpsweep_one
1029 :: ModSummary
1030 -- ^ The module we wish to compile
1031 -> Map BuildModule (MVar SuccessFlag, Int)
1032 -- ^ The map of home modules and their result MVar
1033 -> [[BuildModule]]
1034 -- ^ The list of all module loops within the compilation graph.
1035 -> DynFlags
1036 -- ^ The thread-local DynFlags
1037 -> Maybe Messager
1038 -- ^ The messager
1039 -> (HscEnv -> IO ())
1040 -- ^ The callback for cleaning up intermediate files
1041 -> QSem
1042 -- ^ The semaphore for limiting the number of simultaneous compiles
1043 -> MVar HscEnv
1044 -- ^ The MVar that synchronizes updates to the global HscEnv
1045 -> IORef HomePackageTable
1046 -- ^ The old HPT
1047 -> StableModules
1048 -- ^ Sets of stable objects and BCOs
1049 -> Int
1050 -- ^ The index of this module
1051 -> Int
1052 -- ^ The total number of modules
1053 -> IO SuccessFlag
1054 -- ^ The result of this compile
1055 parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup par_sem
1056 hsc_env_var old_hpt_var stable_mods mod_index num_mods = do
1057
1058 let this_build_mod = mkBuildModule mod
1059
1060 let home_imps = map unLoc $ ms_home_imps mod
1061 let home_src_imps = map unLoc $ ms_home_srcimps mod
1062
1063 -- All the textual imports of this module.
1064 let textual_deps = Set.fromList $ mapFst (mkModule (thisPackage lcl_dflags)) $
1065 zip home_imps (repeat NotBoot) ++
1066 zip home_src_imps (repeat IsBoot)
1067
1068 -- Dealing with module loops
1069 -- ~~~~~~~~~~~~~~~~~~~~~~~~~
1070 --
1071 -- Not only do we have to deal with explicit textual dependencies, we also
1072 -- have to deal with implicit dependencies introduced by import cycles that
1073 -- are broken by an hs-boot file. We have to ensure that:
1074 --
1075 -- 1. A module that breaks a loop must depend on all the modules in the
1076 -- loop (transitively or otherwise). This is normally always fulfilled
1077 -- by the module's textual dependencies except in degenerate loops,
1078 -- e.g.:
1079 --
1080 -- A.hs imports B.hs-boot
1081 -- B.hs doesn't import A.hs
1082 -- C.hs imports A.hs, B.hs
1083 --
1084 -- In this scenario, getModLoop will detect the module loop [A,B] but
1085 -- the loop finisher B doesn't depend on A. So we have to explicitly add
1086 -- A in as a dependency of B when we are compiling B.
1087 --
1088 -- 2. A module that depends on a module in an external loop can't proceed
1089 -- until the entire loop is re-typechecked.
1090 --
1091 -- These two invariants have to be maintained to correctly build a
1092 -- compilation graph with one or more loops.
1093
1094
1095 -- The loop that this module will finish. After this module successfully
1096 -- compiles, this loop is going to get re-typechecked.
1097 let finish_loop = listToMaybe
1098 [ tail loop | loop <- comp_graph_loops
1099 , head loop == this_build_mod ]
1100
1101 -- If this module finishes a loop then it must depend on all the other
1102 -- modules in that loop because the entire module loop is going to be
1103 -- re-typechecked once this module gets compiled. These extra dependencies
1104 -- are this module's "internal" loop dependencies, because this module is
1105 -- inside the loop in question.
1106 let int_loop_deps = Set.fromList $
1107 case finish_loop of
1108 Nothing -> []
1109 Just loop -> filter (/= this_build_mod) loop
1110
1111 -- If this module depends on a module within a loop then it must wait for
1112 -- that loop to get re-typechecked, i.e. it must wait on the module that
1113 -- finishes that loop. These extra dependencies are this module's
1114 -- "external" loop dependencies, because this module is outside of the
1115 -- loop(s) in question.
1116 let ext_loop_deps = Set.fromList
1117 [ head loop | loop <- comp_graph_loops
1118 , any (`Set.member` textual_deps) loop
1119 , this_build_mod `notElem` loop ]
1120
1121
1122 let all_deps = foldl1 Set.union [textual_deps, int_loop_deps, ext_loop_deps]
1123
1124 -- All of the module's home-module dependencies.
1125 let home_deps_with_idx =
1126 [ home_dep | dep <- Set.toList all_deps
1127 , Just home_dep <- [Map.lookup dep home_mod_map] ]
1128
1129 -- Sort the list of dependencies in reverse-topological order. This way, by
1130 -- the time we get woken up by the result of an earlier dependency,
1131 -- subsequent dependencies are more likely to have finished. This step
1132 -- effectively reduces the number of MVars that each thread blocks on.
1133 let home_deps = map fst $ sortBy (flip (comparing snd)) home_deps_with_idx
1134
1135 -- Wait for the all the module's dependencies to finish building.
1136 deps_ok <- allM (fmap succeeded . readMVar) home_deps
1137
1138 -- We can't build this module if any of its dependencies failed to build.
1139 if not deps_ok
1140 then return Failed
1141 else do
1142 -- Any hsc_env at this point is OK to use since we only really require
1143 -- that the HPT contains the HMIs of our dependencies.
1144 hsc_env <- readMVar hsc_env_var
1145 old_hpt <- readIORef old_hpt_var
1146
1147 let logger err = printBagOfErrors lcl_dflags (srcErrorMessages err)
1148
1149 -- Limit the number of parallel compiles.
1150 let withSem sem = bracket_ (waitQSem sem) (signalQSem sem)
1151 mb_mod_info <- withSem par_sem $
1152 handleSourceError (\err -> do logger err; return Nothing) $ do
1153 -- Have the ModSummary and HscEnv point to our local log_action
1154 -- and filesToClean var.
1155 let lcl_mod = localize_mod mod
1156 let lcl_hsc_env = localize_hsc_env hsc_env
1157
1158 -- Re-typecheck the loop
1159 -- This is necessary to make sure the knot is tied when
1160 -- we close a recursive module loop, see bug #12035.
1161 type_env_var <- liftIO $ newIORef emptyNameEnv
1162 let lcl_hsc_env' = lcl_hsc_env { hsc_type_env_var =
1163 Just (ms_mod lcl_mod, type_env_var) }
1164 lcl_hsc_env'' <- case finish_loop of
1165 Nothing -> return lcl_hsc_env'
1166 Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $
1167 map (moduleName . fst) loop
1168
1169 -- Compile the module.
1170 mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods
1171 lcl_mod mod_index num_mods
1172 return (Just mod_info)
1173
1174 case mb_mod_info of
1175 Nothing -> return Failed
1176 Just mod_info -> do
1177 let this_mod = ms_mod_name mod
1178
1179 -- Prune the old HPT unless this is an hs-boot module.
1180 unless (isBootSummary mod) $
1181 atomicModifyIORef' old_hpt_var $ \old_hpt ->
1182 (delFromHpt old_hpt this_mod, ())
1183
1184 -- Update and fetch the global HscEnv.
1185 lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do
1186 let hsc_env' = hsc_env
1187 { hsc_HPT = addToHpt (hsc_HPT hsc_env)
1188 this_mod mod_info }
1189 -- If this module is a loop finisher, now is the time to
1190 -- re-typecheck the loop.
1191 hsc_env'' <- case finish_loop of
1192 Nothing -> return hsc_env'
1193 Just loop -> typecheckLoop lcl_dflags hsc_env' $
1194 map (moduleName . fst) loop
1195 return (hsc_env'', localize_hsc_env hsc_env'')
1196
1197 -- Clean up any intermediate files.
1198 cleanup lcl_hsc_env'
1199 return Succeeded
1200
1201 where
1202 localize_mod mod
1203 = mod { ms_hspp_opts = (ms_hspp_opts mod)
1204 { log_action = log_action lcl_dflags
1205 , filesToClean = filesToClean lcl_dflags } }
1206
1207 localize_hsc_env hsc_env
1208 = hsc_env { hsc_dflags = (hsc_dflags hsc_env)
1209 { log_action = log_action lcl_dflags
1210 , filesToClean = filesToClean lcl_dflags } }
1211
1212 -- -----------------------------------------------------------------------------
1213 --
1214 -- | The upsweep
1215 --
1216 -- This is where we compile each module in the module graph, in a pass
1217 -- from the bottom to the top of the graph.
1218 --
1219 -- There better had not be any cyclic groups here -- we check for them.
1220 upsweep
1221 :: GhcMonad m
1222 => Maybe Messager
1223 -> HomePackageTable -- ^ HPT from last time round (pruned)
1224 -> StableModules -- ^ stable modules (see checkStability)
1225 -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files
1226 -> [SCC ModSummary] -- ^ Mods to do (the worklist)
1227 -> m (SuccessFlag,
1228 [ModSummary])
1229 -- ^ Returns:
1230 --
1231 -- 1. A flag whether the complete upsweep was successful.
1232 -- 2. The 'HscEnv' in the monad has an updated HPT
1233 -- 3. A list of modules which succeeded loading.
1234
1235 upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
1236 dflags <- getSessionDynFlags
1237 (res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs)
1238 (unitIdsToCheck dflags) done_holes
1239 return (res, reverse $ mgModSummaries done)
1240 where
1241 done_holes = emptyUniqSet
1242
1243 upsweep'
1244 :: GhcMonad m
1245 => HomePackageTable
1246 -> ModuleGraph
1247 -> [SCC ModSummary]
1248 -> Int
1249 -> Int
1250 -> [UnitId]
1251 -> UniqSet ModuleName
1252 -> m (SuccessFlag, ModuleGraph)
1253 upsweep' _old_hpt done
1254 [] _ _ uids_to_check _
1255 = do hsc_env <- getSession
1256 liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) uids_to_check
1257 return (Succeeded, done)
1258
1259 upsweep' _old_hpt done
1260 (CyclicSCC ms:_) _ _ _ _
1261 = do dflags <- getSessionDynFlags
1262 liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
1263 return (Failed, done)
1264
1265 upsweep' old_hpt done
1266 (AcyclicSCC mod:mods) mod_index nmods uids_to_check done_holes
1267 = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
1268 -- show (map (moduleUserString.moduleName.mi_module.hm_iface)
1269 -- (moduleEnvElts (hsc_HPT hsc_env)))
1270 let logger _mod = defaultWarnErrLogger
1271
1272 hsc_env <- getSession
1273
1274 -- TODO: Cache this, so that we don't repeatedly re-check
1275 -- our imports when you run --make.
1276 let (ready_uids, uids_to_check')
1277 = partition (\uid -> isEmptyUniqDSet
1278 (unitIdFreeHoles uid `uniqDSetMinusUniqSet` done_holes))
1279 uids_to_check
1280 done_holes'
1281 | ms_hsc_src mod == HsigFile
1282 = addOneToUniqSet done_holes (ms_mod_name mod)
1283 | otherwise = done_holes
1284 liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) ready_uids
1285
1286 -- Remove unwanted tmp files between compilations
1287 liftIO (cleanup hsc_env)
1288
1289 -- Get ready to tie the knot
1290 type_env_var <- liftIO $ newIORef emptyNameEnv
1291 let hsc_env1 = hsc_env { hsc_type_env_var =
1292 Just (ms_mod mod, type_env_var) }
1293 setSession hsc_env1
1294
1295 -- Lazily reload the HPT modules participating in the loop.
1296 -- See Note [Tying the knot]--if we don't throw out the old HPT
1297 -- and reinitalize the knot-tying process, anything that was forced
1298 -- while we were previously typechecking won't get updated, this
1299 -- was bug #12035.
1300 hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done
1301 setSession hsc_env2
1302
1303 mb_mod_info
1304 <- handleSourceError
1305 (\err -> do logger mod (Just err); return Nothing) $ do
1306 mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods
1307 mod mod_index nmods
1308 logger mod Nothing -- log warnings
1309 return (Just mod_info)
1310
1311 case mb_mod_info of
1312 Nothing -> return (Failed, done)
1313 Just mod_info -> do
1314 let this_mod = ms_mod_name mod
1315
1316 -- Add new info to hsc_env
1317 hpt1 = addToHpt (hsc_HPT hsc_env2) this_mod mod_info
1318 hsc_env3 = hsc_env2 { hsc_HPT = hpt1, hsc_type_env_var = Nothing }
1319
1320 -- Space-saving: delete the old HPT entry
1321 -- for mod BUT if mod is a hs-boot
1322 -- node, don't delete it. For the
1323 -- interface, the HPT entry is probaby for the
1324 -- main Haskell source file. Deleting it
1325 -- would force the real module to be recompiled
1326 -- every time.
1327 old_hpt1 | isBootSummary mod = old_hpt
1328 | otherwise = delFromHpt old_hpt this_mod
1329
1330 done' = extendMG done mod
1331
1332 -- fixup our HomePackageTable after we've finished compiling
1333 -- a mutually-recursive loop. We have to do this again
1334 -- to make sure we have the final unfoldings, which may
1335 -- not have been computed accurately in the previous
1336 -- retypecheck.
1337 hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done'
1338 setSession hsc_env4
1339
1340 -- Add any necessary entries to the static pointer
1341 -- table. See Note [Grand plan for static forms] in
1342 -- StaticPtrTable.
1343 when (hscTarget (hsc_dflags hsc_env4) == HscInterpreted) $
1344 liftIO $ hscAddSptEntries hsc_env4
1345 [ spt
1346 | Just linkable <- pure $ hm_linkable mod_info
1347 , unlinked <- linkableUnlinked linkable
1348 , BCOs _ spts <- pure unlinked
1349 , spt <- spts
1350 ]
1351
1352 upsweep' old_hpt1 done' mods (mod_index+1) nmods uids_to_check' done_holes'
1353
1354 unitIdsToCheck :: DynFlags -> [UnitId]
1355 unitIdsToCheck dflags =
1356 nubSort $ concatMap goUnitId (explicitPackages (pkgState dflags))
1357 where
1358 goUnitId uid =
1359 case splitUnitIdInsts uid of
1360 (_, Just indef) ->
1361 let insts = indefUnitIdInsts indef
1362 in uid : concatMap (goUnitId . moduleUnitId . snd) insts
1363 _ -> []
1364
1365 maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)
1366 maybeGetIfaceDate dflags location
1367 | writeInterfaceOnlyMode dflags
1368 -- Minor optimization: it should be harmless to check the hi file location
1369 -- always, but it's better to avoid hitting the filesystem if possible.
1370 = modificationTimeIfExists (ml_hi_file location)
1371 | otherwise
1372 = return Nothing
1373
1374 -- | Compile a single module. Always produce a Linkable for it if
1375 -- successful. If no compilation happened, return the old Linkable.
1376 upsweep_mod :: HscEnv
1377 -> Maybe Messager
1378 -> HomePackageTable
1379 -> StableModules
1380 -> ModSummary
1381 -> Int -- index of module
1382 -> Int -- total number of modules
1383 -> IO HomeModInfo
1384 upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_index nmods
1385 = let
1386 this_mod_name = ms_mod_name summary
1387 this_mod = ms_mod summary
1388 mb_obj_date = ms_obj_date summary
1389 mb_if_date = ms_iface_date summary
1390 obj_fn = ml_obj_file (ms_location summary)
1391 hs_date = ms_hs_date summary
1392
1393 is_stable_obj = this_mod_name `elementOfUniqSet` stable_obj
1394 is_stable_bco = this_mod_name `elementOfUniqSet` stable_bco
1395
1396 old_hmi = lookupHpt old_hpt this_mod_name
1397
1398 -- We're using the dflags for this module now, obtained by
1399 -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
1400 dflags = ms_hspp_opts summary
1401 prevailing_target = hscTarget (hsc_dflags hsc_env)
1402 local_target = hscTarget dflags
1403
1404 -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that
1405 -- we don't do anything dodgy: these should only work to change
1406 -- from -fllvm to -fasm and vice-versa, or away from -fno-code,
1407 -- otherwise we could end up trying to link object code to byte
1408 -- code.
1409 target = if prevailing_target /= local_target
1410 && (not (isObjectTarget prevailing_target)
1411 || not (isObjectTarget local_target))
1412 && not (prevailing_target == HscNothing)
1413 then prevailing_target
1414 else local_target
1415
1416 -- store the corrected hscTarget into the summary
1417 summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }
1418
1419 -- The old interface is ok if
1420 -- a) we're compiling a source file, and the old HPT
1421 -- entry is for a source file
1422 -- b) we're compiling a hs-boot file
1423 -- Case (b) allows an hs-boot file to get the interface of its
1424 -- real source file on the second iteration of the compilation
1425 -- manager, but that does no harm. Otherwise the hs-boot file
1426 -- will always be recompiled
1427
1428 mb_old_iface
1429 = case old_hmi of
1430 Nothing -> Nothing
1431 Just hm_info | isBootSummary summary -> Just iface
1432 | not (mi_boot iface) -> Just iface
1433 | otherwise -> Nothing
1434 where
1435 iface = hm_iface hm_info
1436
1437 compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo
1438 compile_it mb_linkable src_modified =
1439 compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods
1440 mb_old_iface mb_linkable src_modified
1441
1442 compile_it_discard_iface :: Maybe Linkable -> SourceModified
1443 -> IO HomeModInfo
1444 compile_it_discard_iface mb_linkable src_modified =
1445 compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods
1446 Nothing mb_linkable src_modified
1447
1448 -- With the HscNothing target we create empty linkables to avoid
1449 -- recompilation. We have to detect these to recompile anyway if
1450 -- the target changed since the last compile.
1451 is_fake_linkable
1452 | Just hmi <- old_hmi, Just l <- hm_linkable hmi =
1453 null (linkableUnlinked l)
1454 | otherwise =
1455 -- we have no linkable, so it cannot be fake
1456 False
1457
1458 implies False _ = True
1459 implies True x = x
1460
1461 in
1462 case () of
1463 _
1464 -- Regardless of whether we're generating object code or
1465 -- byte code, we can always use an existing object file
1466 -- if it is *stable* (see checkStability).
1467 | is_stable_obj, Just hmi <- old_hmi -> do
1468 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1469 (text "skipping stable obj mod:" <+> ppr this_mod_name)
1470 return hmi
1471 -- object is stable, and we have an entry in the
1472 -- old HPT: nothing to do
1473
1474 | is_stable_obj, isNothing old_hmi -> do
1475 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1476 (text "compiling stable on-disk mod:" <+> ppr this_mod_name)
1477 linkable <- liftIO $ findObjectLinkable this_mod obj_fn
1478 (expectJust "upsweep1" mb_obj_date)
1479 compile_it (Just linkable) SourceUnmodifiedAndStable
1480 -- object is stable, but we need to load the interface
1481 -- off disk to make a HMI.
1482
1483 | not (isObjectTarget target), is_stable_bco,
1484 (target /= HscNothing) `implies` not is_fake_linkable ->
1485 ASSERT(isJust old_hmi) -- must be in the old_hpt
1486 let Just hmi = old_hmi in do
1487 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1488 (text "skipping stable BCO mod:" <+> ppr this_mod_name)
1489 return hmi
1490 -- BCO is stable: nothing to do
1491
1492 | not (isObjectTarget target),
1493 Just hmi <- old_hmi,
1494 Just l <- hm_linkable hmi,
1495 not (isObjectLinkable l),
1496 (target /= HscNothing) `implies` not is_fake_linkable,
1497 linkableTime l >= ms_hs_date summary -> do
1498 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1499 (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)
1500 compile_it (Just l) SourceUnmodified
1501 -- we have an old BCO that is up to date with respect
1502 -- to the source: do a recompilation check as normal.
1503
1504 -- When generating object code, if there's an up-to-date
1505 -- object file on the disk, then we can use it.
1506 -- However, if the object file is new (compared to any
1507 -- linkable we had from a previous compilation), then we
1508 -- must discard any in-memory interface, because this
1509 -- means the user has compiled the source file
1510 -- separately and generated a new interface, that we must
1511 -- read from the disk.
1512 --
1513 | isObjectTarget target,
1514 Just obj_date <- mb_obj_date,
1515 obj_date >= hs_date -> do
1516 case old_hmi of
1517 Just hmi
1518 | Just l <- hm_linkable hmi,
1519 isObjectLinkable l && linkableTime l == obj_date -> do
1520 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1521 (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)
1522 compile_it (Just l) SourceUnmodified
1523 _otherwise -> do
1524 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1525 (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)
1526 linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
1527 compile_it_discard_iface (Just linkable) SourceUnmodified
1528
1529 -- See Note [Recompilation checking in -fno-code mode]
1530 | writeInterfaceOnlyMode dflags,
1531 Just if_date <- mb_if_date,
1532 if_date >= hs_date -> do
1533 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1534 (text "skipping tc'd mod:" <+> ppr this_mod_name)
1535 compile_it Nothing SourceUnmodified
1536
1537 _otherwise -> do
1538 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1539 (text "compiling mod:" <+> ppr this_mod_name)
1540 compile_it Nothing SourceModified
1541
1542
1543 {- Note [-fno-code mode]
1544 ~~~~~~~~~~~~~~~~~~~~~~~~
1545 GHC offers the flag -fno-code for the purpose of parsing and typechecking a
1546 program without generating object files. This is intended to be used by tooling
1547 and IDEs to provide quick feedback on any parser or type errors as cheaply as
1548 possible.
1549
1550 When GHC is invoked with -fno-code no object files or linked output will be
1551 generated. As many errors and warnings as possible will be generated, as if
1552 -fno-code had not been passed. The session DynFlags will have
1553 hscTarget == HscNothing.
1554
1555 -fwrite-interface
1556 ~~~~~~~~~~~~~~~~
1557 Whether interface files are generated in -fno-code mode is controlled by the
1558 -fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is
1559 not also passed. Recompilation avoidance requires interface files, so passing
1560 -fno-code without -fwrite-interface should be avoided. If -fno-code were
1561 re-implemented today, -fwrite-interface would be discarded and it would be
1562 considered always on; this behaviour is as it is for backwards compatibility.
1563
1564 ================================================================
1565 IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER
1566 ================================================================
1567
1568 Template Haskell
1569 ~~~~~~~~~~~~~~~~
1570 A module using template haskell may invoke an imported function from inside a
1571 splice. This will cause the type-checker to attempt to execute that code, which
1572 would fail if no object files had been generated. See #8025. To rectify this,
1573 during the downsweep we patch the DynFlags in the ModSummary of any home module
1574 that is imported by a module that uses template haskell, to generate object
1575 code.
1576
1577 The flavour of generated object code is chosen by defaultObjectTarget for the
1578 target platform. It would likely be faster to generate bytecode, but this is not
1579 supported on all platforms(?Please Confirm?), and does not support the entirety
1580 of GHC haskell. See #1257.
1581
1582 The object files (and interface files if -fwrite-interface is disabled) produced
1583 for template haskell are written to temporary files.
1584
1585 Note that since template haskell can run arbitrary IO actions, -fno-code mode
1586 is no more secure than running without it.
1587
1588 Potential TODOS:
1589 ~~~~~
1590 * Remove -fwrite-interface and have interface files always written in -fno-code
1591 mode
1592 * Both .o and .dyn_o files are generated for template haskell, but we only need
1593 .dyn_o. Fix it.
1594 * In make mode, a message like
1595 Compiling A (A.hs, /tmp/ghc_123.o)
1596 is shown if downsweep enabled object code generation for A. Perhaps we should
1597 show "nothing" or "temporary object file" instead. Note that one
1598 can currently use -keep-tmp-files and inspect the generated file with the
1599 current behaviour.
1600 * Offer a -no-codedir command line option, and write what were temporary
1601 object files there. This would speed up recompilation.
1602 * Use existing object files (if they are up to date) instead of always
1603 generating temporary ones.
1604 -}
1605
1606 -- Note [Recompilation checking in -fno-code mode]
1607 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1608 -- If we are compiling with -fno-code -fwrite-interface, there won't
1609 -- be any object code that we can compare against, nor should there
1610 -- be: we're *just* generating interface files. In this case, we
1611 -- want to check if the interface file is new, in lieu of the object
1612 -- file. See also Trac #9243.
1613
1614 -- Filter modules in the HPT
1615 retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
1616 retainInTopLevelEnvs keep_these hpt
1617 = listToHpt [ (mod, expectJust "retain" mb_mod_info)
1618 | mod <- keep_these
1619 , let mb_mod_info = lookupHpt hpt mod
1620 , isJust mb_mod_info ]
1621
1622 -- ---------------------------------------------------------------------------
1623 -- Typecheck module loops
1624 {-
1625 See bug #930. This code fixes a long-standing bug in --make. The
1626 problem is that when compiling the modules *inside* a loop, a data
1627 type that is only defined at the top of the loop looks opaque; but
1628 after the loop is done, the structure of the data type becomes
1629 apparent.
1630
1631 The difficulty is then that two different bits of code have
1632 different notions of what the data type looks like.
1633
1634 The idea is that after we compile a module which also has an .hs-boot
1635 file, we re-generate the ModDetails for each of the modules that
1636 depends on the .hs-boot file, so that everyone points to the proper
1637 TyCons, Ids etc. defined by the real module, not the boot module.
1638 Fortunately re-generating a ModDetails from a ModIface is easy: the
1639 function TcIface.typecheckIface does exactly that.
1640
1641 Picking the modules to re-typecheck is slightly tricky. Starting from
1642 the module graph consisting of the modules that have already been
1643 compiled, we reverse the edges (so they point from the imported module
1644 to the importing module), and depth-first-search from the .hs-boot
1645 node. This gives us all the modules that depend transitively on the
1646 .hs-boot module, and those are exactly the modules that we need to
1647 re-typecheck.
1648
1649 Following this fix, GHC can compile itself with --make -O2.
1650 -}
1651
1652 reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
1653 reTypecheckLoop hsc_env ms graph
1654 | Just loop <- getModLoop ms graph
1655 -- SOME hs-boot files should still
1656 -- get used, just not the loop-closer.
1657 , let non_boot = filter (\l -> not (isBootSummary l &&
1658 ms_mod l == ms_mod ms)) loop
1659 = typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot)
1660 | otherwise
1661 = return hsc_env
1662
1663 getModLoop :: ModSummary -> ModuleGraph -> Maybe [ModSummary]
1664 getModLoop ms graph
1665 | not (isBootSummary ms)
1666 , mgElemBootModule graph this_mod
1667 , let mss = reachableBackwards (ms_mod_name ms) (mgModSummaries graph)
1668 = Just mss
1669 | otherwise
1670 = Nothing
1671 where
1672 this_mod = ms_mod ms
1673
1674 typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
1675 typecheckLoop dflags hsc_env mods = do
1676 debugTraceMsg dflags 2 $
1677 text "Re-typechecking loop: " <> ppr mods
1678 new_hpt <-
1679 fixIO $ \new_hpt -> do
1680 let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }
1681 mds <- initIfaceCheck (text "typecheckLoop") new_hsc_env $
1682 mapM (typecheckIface . hm_iface) hmis
1683 let new_hpt = addListToHpt old_hpt
1684 (zip mods [ hmi{ hm_details = details }
1685 | (hmi,details) <- zip hmis mds ])
1686 return new_hpt
1687 return hsc_env{ hsc_HPT = new_hpt }
1688 where
1689 old_hpt = hsc_HPT hsc_env
1690 hmis = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods
1691
1692 reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
1693 reachableBackwards mod summaries
1694 = [ node_payload node | node <- reachableG (transposeG graph) root ]
1695 where -- the rest just sets up the graph:
1696 (graph, lookup_node) = moduleGraphNodes False summaries
1697 root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
1698
1699 -- ---------------------------------------------------------------------------
1700 --
1701 -- | Topological sort of the module graph
1702 topSortModuleGraph
1703 :: Bool
1704 -- ^ Drop hi-boot nodes? (see below)
1705 -> ModuleGraph
1706 -> Maybe ModuleName
1707 -- ^ Root module name. If @Nothing@, use the full graph.
1708 -> [SCC ModSummary]
1709 -- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
1710 -- The resulting list of strongly-connected-components is in topologically
1711 -- sorted order, starting with the module(s) at the bottom of the
1712 -- dependency graph (ie compile them first) and ending with the ones at
1713 -- the top.
1714 --
1715 -- Drop hi-boot nodes (first boolean arg)?
1716 --
1717 -- - @False@: treat the hi-boot summaries as nodes of the graph,
1718 -- so the graph must be acyclic
1719 --
1720 -- - @True@: eliminate the hi-boot nodes, and instead pretend
1721 -- the a source-import of Foo is an import of Foo
1722 -- The resulting graph has no hi-boot nodes, but can be cyclic
1723
1724 topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod
1725 = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
1726 where
1727 summaries = mgModSummaries module_graph
1728 -- stronglyConnCompG flips the original order, so if we reverse
1729 -- the summaries we get a stable topological sort.
1730 (graph, lookup_node) =
1731 moduleGraphNodes drop_hs_boot_nodes (reverse summaries)
1732
1733 initial_graph = case mb_root_mod of
1734 Nothing -> graph
1735 Just root_mod ->
1736 -- restrict the graph to just those modules reachable from
1737 -- the specified module. We do this by building a graph with
1738 -- the full set of nodes, and determining the reachable set from
1739 -- the specified node.
1740 let root | Just node <- lookup_node HsSrcFile root_mod
1741 , graph `hasVertexG` node
1742 = node
1743 | otherwise
1744 = throwGhcException (ProgramError "module does not exist")
1745 in graphFromEdgedVerticesUniq (seq root (reachableG graph root))
1746
1747 type SummaryNode = Node Int ModSummary
1748
1749 summaryNodeKey :: SummaryNode -> Int
1750 summaryNodeKey = node_key
1751
1752 summaryNodeSummary :: SummaryNode -> ModSummary
1753 summaryNodeSummary = node_payload
1754
1755 moduleGraphNodes :: Bool -> [ModSummary]
1756 -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
1757 moduleGraphNodes drop_hs_boot_nodes summaries =
1758 (graphFromEdgedVerticesUniq nodes, lookup_node)
1759 where
1760 numbered_summaries = zip summaries [1..]
1761
1762 lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
1763 lookup_node hs_src mod = Map.lookup (mod, hscSourceToIsBoot hs_src) node_map
1764
1765 lookup_key :: HscSource -> ModuleName -> Maybe Int
1766 lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
1767
1768 node_map :: NodeMap SummaryNode
1769 node_map = Map.fromList [ ((moduleName (ms_mod s),
1770 hscSourceToIsBoot (ms_hsc_src s)), node)
1771 | node <- nodes
1772 , let s = summaryNodeSummary node ]
1773
1774 -- We use integers as the keys for the SCC algorithm
1775 nodes :: [SummaryNode]
1776 nodes = [ DigraphNode s key out_keys
1777 | (s, key) <- numbered_summaries
1778 -- Drop the hi-boot ones if told to do so
1779 , not (isBootSummary s && drop_hs_boot_nodes)
1780 , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++
1781 out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++
1782 (-- see [boot-edges] below
1783 if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
1784 then []
1785 else case lookup_key HsBootFile (ms_mod_name s) of
1786 Nothing -> []
1787 Just k -> [k]) ]
1788
1789 -- [boot-edges] if this is a .hs and there is an equivalent
1790 -- .hs-boot, add a link from the former to the latter. This
1791 -- has the effect of detecting bogus cases where the .hs-boot
1792 -- depends on the .hs, by introducing a cycle. Additionally,
1793 -- it ensures that we will always process the .hs-boot before
1794 -- the .hs, and so the HomePackageTable will always have the
1795 -- most up to date information.
1796
1797 -- Drop hs-boot nodes by using HsSrcFile as the key
1798 hs_boot_key | drop_hs_boot_nodes = HsSrcFile
1799 | otherwise = HsBootFile
1800
1801 out_edge_keys :: HscSource -> [ModuleName] -> [Int]
1802 out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms
1803 -- If we want keep_hi_boot_nodes, then we do lookup_key with
1804 -- IsBoot; else NotBoot
1805
1806 -- The nodes of the graph are keyed by (mod, is boot?) pairs
1807 -- NB: hsig files show up as *normal* nodes (not boot!), since they don't
1808 -- participate in cycles (for now)
1809 type NodeKey = (ModuleName, IsBoot)
1810 type NodeMap a = Map.Map NodeKey a
1811
1812 msKey :: ModSummary -> NodeKey
1813 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot })
1814 = (moduleName mod, hscSourceToIsBoot boot)
1815
1816 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
1817 mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]
1818
1819 nodeMapElts :: NodeMap a -> [a]
1820 nodeMapElts = Map.elems
1821
1822 -- | If there are {-# SOURCE #-} imports between strongly connected
1823 -- components in the topological sort, then those imports can
1824 -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
1825 -- were necessary, then the edge would be part of a cycle.
1826 warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
1827 warnUnnecessarySourceImports sccs = do
1828 dflags <- getDynFlags
1829 when (wopt Opt_WarnUnusedImports dflags)
1830 (logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs)))
1831 where check dflags ms =
1832 let mods_in_this_cycle = map ms_mod_name ms in
1833 [ warn dflags i | m <- ms, i <- ms_home_srcimps m,
1834 unLoc i `notElem` mods_in_this_cycle ]
1835
1836 warn :: DynFlags -> Located ModuleName -> WarnMsg
1837 warn dflags (L loc mod) =
1838 mkPlainErrMsg dflags loc
1839 (text "Warning: {-# SOURCE #-} unnecessary in import of "
1840 <+> quotes (ppr mod))
1841
1842
1843 reportImportErrors :: MonadIO m => [Either ErrMsg b] -> m [b]
1844 reportImportErrors xs | null errs = return oks
1845 | otherwise = throwManyErrors errs
1846 where (errs, oks) = partitionEithers xs
1847
1848 throwManyErrors :: MonadIO m => [ErrMsg] -> m ab
1849 throwManyErrors errs = liftIO $ throwIO $ mkSrcErr $ listToBag errs
1850
1851
1852 -----------------------------------------------------------------------------
1853 --
1854 -- | Downsweep (dependency analysis)
1855 --
1856 -- Chase downwards from the specified root set, returning summaries
1857 -- for all home modules encountered. Only follow source-import
1858 -- links.
1859 --
1860 -- We pass in the previous collection of summaries, which is used as a
1861 -- cache to avoid recalculating a module summary if the source is
1862 -- unchanged.
1863 --
1864 -- The returned list of [ModSummary] nodes has one node for each home-package
1865 -- module, plus one for any hs-boot files. The imports of these nodes
1866 -- are all there, including the imports of non-home-package modules.
1867 downsweep :: HscEnv
1868 -> [ModSummary] -- Old summaries
1869 -> [ModuleName] -- Ignore dependencies on these; treat
1870 -- them as if they were package modules
1871 -> Bool -- True <=> allow multiple targets to have
1872 -- the same module name; this is
1873 -- very useful for ghc -M
1874 -> IO [Either ErrMsg ModSummary]
1875 -- The elts of [ModSummary] all have distinct
1876 -- (Modules, IsBoot) identifiers, unless the Bool is true
1877 -- in which case there can be repeats
1878 downsweep hsc_env old_summaries excl_mods allow_dup_roots
1879 = do
1880 rootSummaries <- mapM getRootSummary roots
1881 rootSummariesOk <- reportImportErrors rootSummaries
1882 let root_map = mkRootMap rootSummariesOk
1883 checkDuplicates root_map
1884 map0 <- loop (concatMap calcDeps rootSummariesOk) root_map
1885 -- if we have been passed -fno-code, we enable code generation
1886 -- for dependencies of modules that have -XTemplateHaskell,
1887 -- otherwise those modules will fail to compile.
1888 -- See Note [-fno-code mode] #8025
1889 map1 <- if hscTarget dflags == HscNothing
1890 then enableCodeGenForTH
1891 (defaultObjectTarget (targetPlatform dflags))
1892 map0
1893 else return map0
1894 return $ concat $ nodeMapElts map1
1895 where
1896 calcDeps = msDeps
1897
1898 dflags = hsc_dflags hsc_env
1899 roots = hsc_targets hsc_env
1900
1901 old_summary_map :: NodeMap ModSummary
1902 old_summary_map = mkNodeMap old_summaries
1903
1904 getRootSummary :: Target -> IO (Either ErrMsg ModSummary)
1905 getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
1906 = do exists <- liftIO $ doesFileExist file
1907 if exists
1908 then Right `fmap` summariseFile hsc_env old_summaries file mb_phase
1909 obj_allowed maybe_buf
1910 else return $ Left $ mkPlainErrMsg dflags noSrcSpan $
1911 text "can't find file:" <+> text file
1912 getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
1913 = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot
1914 (L rootLoc modl) obj_allowed
1915 maybe_buf excl_mods
1916 case maybe_summary of
1917 Nothing -> return $ Left $ moduleNotFoundErr dflags modl
1918 Just s -> return s
1919
1920 rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
1921
1922 -- In a root module, the filename is allowed to diverge from the module
1923 -- name, so we have to check that there aren't multiple root files
1924 -- defining the same module (otherwise the duplicates will be silently
1925 -- ignored, leading to confusing behaviour).
1926 checkDuplicates :: NodeMap [Either ErrMsg ModSummary] -> IO ()
1927 checkDuplicates root_map
1928 | allow_dup_roots = return ()
1929 | null dup_roots = return ()
1930 | otherwise = liftIO $ multiRootsErr dflags (head dup_roots)
1931 where
1932 dup_roots :: [[ModSummary]] -- Each at least of length 2
1933 dup_roots = filterOut isSingleton $ map rights $ nodeMapElts root_map
1934
1935 loop :: [(Located ModuleName,IsBoot)]
1936 -- Work list: process these modules
1937 -> NodeMap [Either ErrMsg ModSummary]
1938 -- Visited set; the range is a list because
1939 -- the roots can have the same module names
1940 -- if allow_dup_roots is True
1941 -> IO (NodeMap [Either ErrMsg ModSummary])
1942 -- The result is the completed NodeMap
1943 loop [] done = return done
1944 loop ((wanted_mod, is_boot) : ss) done
1945 | Just summs <- Map.lookup key done
1946 = if isSingleton summs then
1947 loop ss done
1948 else
1949 do { multiRootsErr dflags (rights summs); return Map.empty }
1950 | otherwise
1951 = do mb_s <- summariseModule hsc_env old_summary_map
1952 is_boot wanted_mod True
1953 Nothing excl_mods
1954 case mb_s of
1955 Nothing -> loop ss done
1956 Just (Left e) -> loop ss (Map.insert key [Left e] done)
1957 Just (Right s)-> do
1958 new_map <-
1959 loop (calcDeps s) (Map.insert key [Right s] done)
1960 loop ss new_map
1961 where
1962 key = (unLoc wanted_mod, is_boot)
1963
1964 -- | Update the every ModSummary that is depended on
1965 -- by a module that needs template haskell. We enable codegen to
1966 -- the specified target, disable optimization and change the .hi
1967 -- and .o file locations to be temporary files.
1968 -- See Note [-fno-code mode]
1969 enableCodeGenForTH :: HscTarget
1970 -> NodeMap [Either ErrMsg ModSummary]
1971 -> IO (NodeMap [Either ErrMsg ModSummary])
1972 enableCodeGenForTH target nodemap =
1973 traverse (traverse (traverse enable_code_gen)) nodemap
1974 where
1975 enable_code_gen ms
1976 | ModSummary
1977 { ms_mod = ms_mod
1978 , ms_location = ms_location
1979 , ms_hsc_src = HsSrcFile
1980 , ms_hspp_opts = dflags@DynFlags
1981 {hscTarget = HscNothing}
1982 } <- ms
1983 , ms_mod `Set.member` needs_codegen_set
1984 = do
1985 let new_temp_file suf dynsuf = do
1986 tn <- newTempName dflags TFL_CurrentModule suf
1987 let dyn_tn = tn -<.> dynsuf
1988 addFilesToClean dflags TFL_GhcSession [dyn_tn]
1989 return tn
1990 -- We don't want to create .o or .hi files unless we have been asked
1991 -- to by the user. But we need them, so we patch their locations in
1992 -- the ModSummary with temporary files.
1993 --
1994 hi_file <-
1995 if gopt Opt_WriteInterface dflags
1996 then return $ ml_hi_file ms_location
1997 else new_temp_file (hiSuf dflags) (dynHiSuf dflags)
1998 o_temp_file <- new_temp_file (objectSuf dflags) (dynObjectSuf dflags)
1999 return $
2000 ms
2001 { ms_location =
2002 ms_location {ml_hi_file = hi_file, ml_obj_file = o_temp_file}
2003 , ms_hspp_opts = updOptLevel 0 $ dflags {hscTarget = target}
2004 }
2005 | otherwise = return ms
2006 needs_codegen_set = transitive_deps_set Set.empty th_modSums
2007 th_modSums =
2008 [ ms
2009 | mss <- Map.elems nodemap
2010 , Right ms <- mss
2011 , xopt LangExt.TemplateHaskell (ms_hspp_opts ms)
2012 ]
2013 transitive_deps_set marked_mods modSums = foldl' go marked_mods modSums
2014 go marked_mods ms
2015 | Set.member (ms_mod ms) marked_mods = marked_mods
2016 | otherwise =
2017 let deps =
2018 [ dep_ms
2019 | (L _ mn, NotBoot) <- msDeps ms
2020 , dep_ms <-
2021 toList (Map.lookup (mn, NotBoot) nodemap) >>= toList >>=
2022 toList
2023 ]
2024 new_marked_mods =
2025 marked_mods `Set.union` Set.fromList (fmap ms_mod deps)
2026 in transitive_deps_set new_marked_mods deps
2027
2028 mkRootMap :: [ModSummary] -> NodeMap [Either ErrMsg ModSummary]
2029 mkRootMap summaries = Map.insertListWith (flip (++))
2030 [ (msKey s, [Right s]) | s <- summaries ]
2031 Map.empty
2032
2033 -- | Returns the dependencies of the ModSummary s.
2034 -- A wrinkle is that for a {-# SOURCE #-} import we return
2035 -- *both* the hs-boot file
2036 -- *and* the source file
2037 -- as "dependencies". That ensures that the list of all relevant
2038 -- modules always contains B.hs if it contains B.hs-boot.
2039 -- Remember, this pass isn't doing the topological sort. It's
2040 -- just gathering the list of all relevant ModSummaries
2041 msDeps :: ModSummary -> [(Located ModuleName, IsBoot)]
2042 msDeps s =
2043 concat [ [(m,IsBoot), (m,NotBoot)] | m <- ms_home_srcimps s ]
2044 ++ [ (m,NotBoot) | m <- ms_home_imps s ]
2045
2046 home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]
2047 home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps,
2048 isLocal mb_pkg ]
2049 where isLocal Nothing = True
2050 isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
2051 isLocal _ = False
2052
2053 ms_home_allimps :: ModSummary -> [ModuleName]
2054 ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)
2055
2056 -- | Like 'ms_home_imps', but for SOURCE imports.
2057 ms_home_srcimps :: ModSummary -> [Located ModuleName]
2058 ms_home_srcimps = home_imps . ms_srcimps
2059
2060 -- | All of the (possibly) home module imports from a
2061 -- 'ModSummary'; that is to say, each of these module names
2062 -- could be a home import if an appropriately named file
2063 -- existed. (This is in contrast to package qualified
2064 -- imports, which are guaranteed not to be home imports.)
2065 ms_home_imps :: ModSummary -> [Located ModuleName]
2066 ms_home_imps = home_imps . ms_imps
2067
2068 -----------------------------------------------------------------------------
2069 -- Summarising modules
2070
2071 -- We have two types of summarisation:
2072 --
2073 -- * Summarise a file. This is used for the root module(s) passed to
2074 -- cmLoadModules. The file is read, and used to determine the root
2075 -- module name. The module name may differ from the filename.
2076 --
2077 -- * Summarise a module. We are given a module name, and must provide
2078 -- a summary. The finder is used to locate the file in which the module
2079 -- resides.
2080
2081 summariseFile
2082 :: HscEnv
2083 -> [ModSummary] -- old summaries
2084 -> FilePath -- source file name
2085 -> Maybe Phase -- start phase
2086 -> Bool -- object code allowed?
2087 -> Maybe (StringBuffer,UTCTime)
2088 -> IO ModSummary
2089
2090 summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
2091 -- we can use a cached summary if one is available and the
2092 -- source file hasn't changed, But we have to look up the summary
2093 -- by source file, rather than module name as we do in summarise.
2094 | Just old_summary <- findSummaryBySourceFile old_summaries file
2095 = do
2096 let location = ms_location old_summary
2097 dflags = hsc_dflags hsc_env
2098
2099 src_timestamp <- get_src_timestamp
2100 -- The file exists; we checked in getRootSummary above.
2101 -- If it gets removed subsequently, then this
2102 -- getModificationUTCTime may fail, but that's the right
2103 -- behaviour.
2104
2105 -- return the cached summary if the source didn't change
2106 if ms_hs_date old_summary == src_timestamp &&
2107 not (gopt Opt_ForceRecomp (hsc_dflags hsc_env))
2108 then do -- update the object-file timestamp
2109 obj_timestamp <-
2110 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2111 || obj_allowed -- bug #1205
2112 then liftIO $ getObjTimestamp location NotBoot
2113 else return Nothing
2114 hi_timestamp <- maybeGetIfaceDate dflags location
2115
2116 -- We have to repopulate the Finder's cache because it
2117 -- was flushed before the downsweep.
2118 _ <- liftIO $ addHomeModuleToFinder hsc_env
2119 (moduleName (ms_mod old_summary)) (ms_location old_summary)
2120
2121 return old_summary{ ms_obj_date = obj_timestamp
2122 , ms_iface_date = hi_timestamp }
2123 else
2124 new_summary src_timestamp
2125
2126 | otherwise
2127 = do src_timestamp <- get_src_timestamp
2128 new_summary src_timestamp
2129 where
2130 get_src_timestamp = case maybe_buf of
2131 Just (_,t) -> return t
2132 Nothing -> liftIO $ getModificationUTCTime file
2133 -- getModificationUTCTime may fail
2134
2135 new_summary src_timestamp = do
2136 let dflags = hsc_dflags hsc_env
2137
2138 let hsc_src = if isHaskellSigFilename file then HsigFile else HsSrcFile
2139
2140 (dflags', hspp_fn, buf)
2141 <- preprocessFile hsc_env file mb_phase maybe_buf
2142
2143 (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
2144
2145 -- Make a ModLocation for this file
2146 location <- liftIO $ mkHomeModLocation dflags mod_name file
2147
2148 -- Tell the Finder cache where it is, so that subsequent calls
2149 -- to findModule will find it, even if it's not on any search path
2150 mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
2151
2152 -- when the user asks to load a source file by name, we only
2153 -- use an object file if -fobject-code is on. See #1205.
2154 obj_timestamp <-
2155 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2156 || obj_allowed -- bug #1205
2157 then liftIO $ modificationTimeIfExists (ml_obj_file location)
2158 else return Nothing
2159
2160 hi_timestamp <- maybeGetIfaceDate dflags location
2161
2162 extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name
2163 required_by_imports <- implicitRequirements hsc_env the_imps
2164
2165 return (ModSummary { ms_mod = mod,
2166 ms_hsc_src = hsc_src,
2167 ms_location = location,
2168 ms_hspp_file = hspp_fn,
2169 ms_hspp_opts = dflags',
2170 ms_hspp_buf = Just buf,
2171 ms_parsed_mod = Nothing,
2172 ms_srcimps = srcimps,
2173 ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports,
2174 ms_hs_date = src_timestamp,
2175 ms_iface_date = hi_timestamp,
2176 ms_obj_date = obj_timestamp })
2177
2178 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
2179 findSummaryBySourceFile summaries file
2180 = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
2181 expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
2182 [] -> Nothing
2183 (x:_) -> Just x
2184
2185 -- Summarise a module, and pick up source and timestamp.
2186 summariseModule
2187 :: HscEnv
2188 -> NodeMap ModSummary -- Map of old summaries
2189 -> IsBoot -- IsBoot <=> a {-# SOURCE #-} import
2190 -> Located ModuleName -- Imported module to be summarised
2191 -> Bool -- object code allowed?
2192 -> Maybe (StringBuffer, UTCTime)
2193 -> [ModuleName] -- Modules to exclude
2194 -> IO (Maybe (Either ErrMsg ModSummary)) -- Its new summary
2195
2196 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
2197 obj_allowed maybe_buf excl_mods
2198 | wanted_mod `elem` excl_mods
2199 = return Nothing
2200
2201 | Just old_summary <- Map.lookup (wanted_mod, is_boot) old_summary_map
2202 = do -- Find its new timestamp; all the
2203 -- ModSummaries in the old map have valid ml_hs_files
2204 let location = ms_location old_summary
2205 src_fn = expectJust "summariseModule" (ml_hs_file location)
2206
2207 -- check the modification time on the source file, and
2208 -- return the cached summary if it hasn't changed. If the
2209 -- file has disappeared, we need to call the Finder again.
2210 case maybe_buf of
2211 Just (_,t) -> check_timestamp old_summary location src_fn t
2212 Nothing -> do
2213 m <- tryIO (getModificationUTCTime src_fn)
2214 case m of
2215 Right t -> check_timestamp old_summary location src_fn t
2216 Left e | isDoesNotExistError e -> find_it
2217 | otherwise -> ioError e
2218
2219 | otherwise = find_it
2220 where
2221 dflags = hsc_dflags hsc_env
2222
2223 check_timestamp old_summary location src_fn src_timestamp
2224 | ms_hs_date old_summary == src_timestamp &&
2225 not (gopt Opt_ForceRecomp dflags) = do
2226 -- update the object-file timestamp
2227 obj_timestamp <-
2228 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2229 || obj_allowed -- bug #1205
2230 then getObjTimestamp location is_boot
2231 else return Nothing
2232 hi_timestamp <- maybeGetIfaceDate dflags location
2233 return (Just (Right old_summary{ ms_obj_date = obj_timestamp
2234 , ms_iface_date = hi_timestamp}))
2235 | otherwise =
2236 -- source changed: re-summarise.
2237 new_summary location (ms_mod old_summary) src_fn src_timestamp
2238
2239 find_it = do
2240 found <- findImportedModule hsc_env wanted_mod Nothing
2241 case found of
2242 Found location mod
2243 | isJust (ml_hs_file location) ->
2244 -- Home package
2245 just_found location mod
2246
2247 _ -> return Nothing
2248 -- Not found
2249 -- (If it is TRULY not found at all, we'll
2250 -- error when we actually try to compile)
2251
2252 just_found location mod = do
2253 -- Adjust location to point to the hs-boot source file,
2254 -- hi file, object file, when is_boot says so
2255 let location' | IsBoot <- is_boot = addBootSuffixLocn location
2256 | otherwise = location
2257 src_fn = expectJust "summarise2" (ml_hs_file location')
2258
2259 -- Check that it exists
2260 -- It might have been deleted since the Finder last found it
2261 maybe_t <- modificationTimeIfExists src_fn
2262 case maybe_t of
2263 Nothing -> return $ Just $ Left $ noHsFileErr dflags loc src_fn
2264 Just t -> new_summary location' mod src_fn t
2265
2266
2267 new_summary location mod src_fn src_timestamp
2268 = do
2269 -- Preprocess the source file and get its imports
2270 -- The dflags' contains the OPTIONS pragmas
2271 (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
2272 (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
2273
2274 -- NB: Despite the fact that is_boot is a top-level parameter, we
2275 -- don't actually know coming into this function what the HscSource
2276 -- of the module in question is. This is because we may be processing
2277 -- this module because another module in the graph imported it: in this
2278 -- case, we know if it's a boot or not because of the {-# SOURCE #-}
2279 -- annotation, but we don't know if it's a signature or a regular
2280 -- module until we actually look it up on the filesystem.
2281 let hsc_src = case is_boot of
2282 IsBoot -> HsBootFile
2283 _ | isHaskellSigFilename src_fn -> HsigFile
2284 | otherwise -> HsSrcFile
2285
2286 when (mod_name /= wanted_mod) $
2287 throwOneError $ mkPlainErrMsg dflags' mod_loc $
2288 text "File name does not match module name:"
2289 $$ text "Saw:" <+> quotes (ppr mod_name)
2290 $$ text "Expected:" <+> quotes (ppr wanted_mod)
2291
2292 when (hsc_src == HsigFile && isNothing (lookup mod_name (thisUnitIdInsts dflags))) $
2293 let suggested_instantiated_with =
2294 hcat (punctuate comma $
2295 [ ppr k <> text "=" <> ppr v
2296 | (k,v) <- ((mod_name, mkHoleModule mod_name)
2297 : thisUnitIdInsts dflags)
2298 ])
2299 in throwOneError $ mkPlainErrMsg dflags' mod_loc $
2300 text "Unexpected signature:" <+> quotes (ppr mod_name)
2301 $$ if gopt Opt_BuildingCabalPackage dflags
2302 then parens (text "Try adding" <+> quotes (ppr mod_name)
2303 <+> text "to the"
2304 <+> quotes (text "signatures")
2305 <+> text "field in your Cabal file.")
2306 else parens (text "Try passing -instantiated-with=\"" <>
2307 suggested_instantiated_with <> text "\"" $$
2308 text "replacing <" <> ppr mod_name <> text "> as necessary.")
2309
2310 -- Find the object timestamp, and return the summary
2311 obj_timestamp <-
2312 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2313 || obj_allowed -- bug #1205
2314 then getObjTimestamp location is_boot
2315 else return Nothing
2316
2317 hi_timestamp <- maybeGetIfaceDate dflags location
2318
2319 extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name
2320 required_by_imports <- implicitRequirements hsc_env the_imps
2321
2322 return (Just (Right (ModSummary { ms_mod = mod,
2323 ms_hsc_src = hsc_src,
2324 ms_location = location,
2325 ms_hspp_file = hspp_fn,
2326 ms_hspp_opts = dflags',
2327 ms_hspp_buf = Just buf,
2328 ms_parsed_mod = Nothing,
2329 ms_srcimps = srcimps,
2330 ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports,
2331 ms_hs_date = src_timestamp,
2332 ms_iface_date = hi_timestamp,
2333 ms_obj_date = obj_timestamp })))
2334
2335
2336 getObjTimestamp :: ModLocation -> IsBoot -> IO (Maybe UTCTime)
2337 getObjTimestamp location is_boot
2338 = if is_boot == IsBoot then return Nothing
2339 else modificationTimeIfExists (ml_obj_file location)
2340
2341
2342 preprocessFile :: HscEnv
2343 -> FilePath
2344 -> Maybe Phase -- ^ Starting phase
2345 -> Maybe (StringBuffer,UTCTime)
2346 -> IO (DynFlags, FilePath, StringBuffer)
2347 preprocessFile hsc_env src_fn mb_phase Nothing
2348 = do
2349 (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
2350 buf <- hGetStringBuffer hspp_fn
2351 return (dflags', hspp_fn, buf)
2352
2353 preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
2354 = do
2355 let dflags = hsc_dflags hsc_env
2356 let local_opts = getOptions dflags buf src_fn
2357
2358 (dflags', leftovers, warns)
2359 <- parseDynamicFilePragma dflags local_opts
2360 checkProcessArgsResult dflags leftovers
2361 handleFlagWarnings dflags' warns
2362
2363 let needs_preprocessing
2364 | Just (Unlit _) <- mb_phase = True
2365 | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
2366 -- note: local_opts is only required if there's no Unlit phase
2367 | xopt LangExt.Cpp dflags' = True
2368 | gopt Opt_Pp dflags' = True
2369 | otherwise = False
2370
2371 when needs_preprocessing $
2372 throwGhcExceptionIO (ProgramError "buffer needs preprocesing; interactive check disabled")
2373
2374 return (dflags', src_fn, buf)
2375
2376
2377 -----------------------------------------------------------------------------
2378 -- Error messages
2379 -----------------------------------------------------------------------------
2380
2381 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg
2382 -- ToDo: we don't have a proper line number for this error
2383 noModError dflags loc wanted_mod err
2384 = mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err
2385
2386 noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrMsg
2387 noHsFileErr dflags loc path
2388 = mkPlainErrMsg dflags loc $ text "Can't find" <+> text path
2389
2390 moduleNotFoundErr :: DynFlags -> ModuleName -> ErrMsg
2391 moduleNotFoundErr dflags mod
2392 = mkPlainErrMsg dflags noSrcSpan $
2393 text "module" <+> quotes (ppr mod) <+> text "cannot be found locally"
2394
2395 multiRootsErr :: DynFlags -> [ModSummary] -> IO ()
2396 multiRootsErr _ [] = panic "multiRootsErr"
2397 multiRootsErr dflags summs@(summ1:_)
2398 = throwOneError $ mkPlainErrMsg dflags noSrcSpan $
2399 text "module" <+> quotes (ppr mod) <+>
2400 text "is defined in multiple files:" <+>
2401 sep (map text files)
2402 where
2403 mod = ms_mod summ1
2404 files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
2405
2406 cyclicModuleErr :: [ModSummary] -> SDoc
2407 -- From a strongly connected component we find
2408 -- a single cycle to report
2409 cyclicModuleErr mss
2410 = ASSERT( not (null mss) )
2411 case findCycle graph of
2412 Nothing -> text "Unexpected non-cycle" <+> ppr mss
2413 Just path -> vcat [ text "Module imports form a cycle:"
2414 , nest 2 (show_path path) ]
2415 where
2416 graph :: [Node NodeKey ModSummary]
2417 graph = [ DigraphNode ms (msKey ms) (get_deps ms) | ms <- mss]
2418
2419 get_deps :: ModSummary -> [NodeKey]
2420 get_deps ms = ([ (unLoc m, IsBoot) | m <- ms_home_srcimps ms ] ++
2421 [ (unLoc m, NotBoot) | m <- ms_home_imps ms ])
2422
2423 show_path [] = panic "show_path"
2424 show_path [m] = text "module" <+> ppr_ms m
2425 <+> text "imports itself"
2426 show_path (m1:m2:ms) = vcat ( nest 7 (text "module" <+> ppr_ms m1)
2427 : nest 6 (text "imports" <+> ppr_ms m2)
2428 : go ms )
2429 where
2430 go [] = [text "which imports" <+> ppr_ms m1]
2431 go (m:ms) = (text "which imports" <+> ppr_ms m) : go ms
2432
2433
2434 ppr_ms :: ModSummary -> SDoc
2435 ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>
2436 (parens (text (msHsFilePath ms)))