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