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