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