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