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