b518518b1f84107d8459cd098a71b01fb020410e
[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 log_action dflags 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 = [ ms | (ms,_,_) <- 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 = (ModSummary, Int, [Int])
1622
1623 summaryNodeKey :: SummaryNode -> Int
1624 summaryNodeKey (_, k, _) = k
1625
1626 summaryNodeSummary :: SummaryNode -> ModSummary
1627 summaryNodeSummary (s, _, _) = s
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@(s, _, _) <- nodes ]
1646
1647 -- We use integers as the keys for the SCC algorithm
1648 nodes :: [SummaryNode]
1649 nodes = [ (s, key, out_keys)
1650 | (s, key) <- numbered_summaries
1651 -- Drop the hi-boot ones if told to do so
1652 , not (isBootSummary s && drop_hs_boot_nodes)
1653 , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++
1654 out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++
1655 (-- see [boot-edges] below
1656 if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
1657 then []
1658 else case lookup_key HsBootFile (ms_mod_name s) of
1659 Nothing -> []
1660 Just k -> [k]) ]
1661
1662 -- [boot-edges] if this is a .hs and there is an equivalent
1663 -- .hs-boot, add a link from the former to the latter. This
1664 -- has the effect of detecting bogus cases where the .hs-boot
1665 -- depends on the .hs, by introducing a cycle. Additionally,
1666 -- it ensures that we will always process the .hs-boot before
1667 -- the .hs, and so the HomePackageTable will always have the
1668 -- most up to date information.
1669
1670 -- Drop hs-boot nodes by using HsSrcFile as the key
1671 hs_boot_key | drop_hs_boot_nodes = HsSrcFile
1672 | otherwise = HsBootFile
1673
1674 out_edge_keys :: HscSource -> [ModuleName] -> [Int]
1675 out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms
1676 -- If we want keep_hi_boot_nodes, then we do lookup_key with
1677 -- IsBoot; else NotBoot
1678
1679 -- The nodes of the graph are keyed by (mod, is boot?) pairs
1680 -- NB: hsig files show up as *normal* nodes (not boot!), since they don't
1681 -- participate in cycles (for now)
1682 type NodeKey = (ModuleName, IsBoot)
1683 type NodeMap a = Map.Map NodeKey a
1684
1685 msKey :: ModSummary -> NodeKey
1686 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot })
1687 = (moduleName mod, hscSourceToIsBoot boot)
1688
1689 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
1690 mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]
1691
1692 nodeMapElts :: NodeMap a -> [a]
1693 nodeMapElts = Map.elems
1694
1695 -- | If there are {-# SOURCE #-} imports between strongly connected
1696 -- components in the topological sort, then those imports can
1697 -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
1698 -- were necessary, then the edge would be part of a cycle.
1699 warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
1700 warnUnnecessarySourceImports sccs = do
1701 dflags <- getDynFlags
1702 when (wopt Opt_WarnUnusedImports dflags)
1703 (logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs)))
1704 where check dflags ms =
1705 let mods_in_this_cycle = map ms_mod_name ms in
1706 [ warn dflags i | m <- ms, i <- ms_home_srcimps m,
1707 unLoc i `notElem` mods_in_this_cycle ]
1708
1709 warn :: DynFlags -> Located ModuleName -> WarnMsg
1710 warn dflags (L loc mod) =
1711 mkPlainErrMsg dflags loc
1712 (text "Warning: {-# SOURCE #-} unnecessary in import of "
1713 <+> quotes (ppr mod))
1714
1715
1716 reportImportErrors :: MonadIO m => [Either ErrMsg b] -> m [b]
1717 reportImportErrors xs | null errs = return oks
1718 | otherwise = throwManyErrors errs
1719 where (errs, oks) = partitionEithers xs
1720
1721 throwManyErrors :: MonadIO m => [ErrMsg] -> m ab
1722 throwManyErrors errs = liftIO $ throwIO $ mkSrcErr $ listToBag errs
1723
1724
1725 -----------------------------------------------------------------------------
1726 --
1727 -- | Downsweep (dependency analysis)
1728 --
1729 -- Chase downwards from the specified root set, returning summaries
1730 -- for all home modules encountered. Only follow source-import
1731 -- links.
1732 --
1733 -- We pass in the previous collection of summaries, which is used as a
1734 -- cache to avoid recalculating a module summary if the source is
1735 -- unchanged.
1736 --
1737 -- The returned list of [ModSummary] nodes has one node for each home-package
1738 -- module, plus one for any hs-boot files. The imports of these nodes
1739 -- are all there, including the imports of non-home-package modules.
1740 downsweep :: HscEnv
1741 -> [ModSummary] -- Old summaries
1742 -> [ModuleName] -- Ignore dependencies on these; treat
1743 -- them as if they were package modules
1744 -> Bool -- True <=> allow multiple targets to have
1745 -- the same module name; this is
1746 -- very useful for ghc -M
1747 -> IO [Either ErrMsg ModSummary]
1748 -- The elts of [ModSummary] all have distinct
1749 -- (Modules, IsBoot) identifiers, unless the Bool is true
1750 -- in which case there can be repeats
1751 downsweep hsc_env old_summaries excl_mods allow_dup_roots
1752 = do
1753 rootSummaries <- mapM getRootSummary roots
1754 rootSummariesOk <- reportImportErrors rootSummaries
1755 let root_map = mkRootMap rootSummariesOk
1756 checkDuplicates root_map
1757 summs <- loop (concatMap calcDeps rootSummariesOk) root_map
1758 return summs
1759 where
1760 calcDeps = msDeps
1761
1762 dflags = hsc_dflags hsc_env
1763 roots = hsc_targets hsc_env
1764
1765 old_summary_map :: NodeMap ModSummary
1766 old_summary_map = mkNodeMap old_summaries
1767
1768 getRootSummary :: Target -> IO (Either ErrMsg ModSummary)
1769 getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
1770 = do exists <- liftIO $ doesFileExist file
1771 if exists
1772 then Right `fmap` summariseFile hsc_env old_summaries file mb_phase
1773 obj_allowed maybe_buf
1774 else return $ Left $ mkPlainErrMsg dflags noSrcSpan $
1775 text "can't find file:" <+> text file
1776 getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
1777 = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot
1778 (L rootLoc modl) obj_allowed
1779 maybe_buf excl_mods
1780 case maybe_summary of
1781 Nothing -> return $ Left $ moduleNotFoundErr dflags modl
1782 Just s -> return s
1783
1784 rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
1785
1786 -- In a root module, the filename is allowed to diverge from the module
1787 -- name, so we have to check that there aren't multiple root files
1788 -- defining the same module (otherwise the duplicates will be silently
1789 -- ignored, leading to confusing behaviour).
1790 checkDuplicates :: NodeMap [Either ErrMsg ModSummary] -> IO ()
1791 checkDuplicates root_map
1792 | allow_dup_roots = return ()
1793 | null dup_roots = return ()
1794 | otherwise = liftIO $ multiRootsErr dflags (head dup_roots)
1795 where
1796 dup_roots :: [[ModSummary]] -- Each at least of length 2
1797 dup_roots = filterOut isSingleton $ map rights $ nodeMapElts root_map
1798
1799 loop :: [(Located ModuleName,IsBoot)]
1800 -- Work list: process these modules
1801 -> NodeMap [Either ErrMsg ModSummary]
1802 -- Visited set; the range is a list because
1803 -- the roots can have the same module names
1804 -- if allow_dup_roots is True
1805 -> IO [Either ErrMsg ModSummary]
1806 -- The result includes the worklist, except
1807 -- for those mentioned in the visited set
1808 loop [] done = return (concat (nodeMapElts done))
1809 loop ((wanted_mod, is_boot) : ss) done
1810 | Just summs <- Map.lookup key done
1811 = if isSingleton summs then
1812 loop ss done
1813 else
1814 do { multiRootsErr dflags (rights summs); return [] }
1815 | otherwise
1816 = do mb_s <- summariseModule hsc_env old_summary_map
1817 is_boot wanted_mod True
1818 Nothing excl_mods
1819 case mb_s of
1820 Nothing -> loop ss done
1821 Just (Left e) -> loop ss (Map.insert key [Left e] done)
1822 Just (Right s)-> loop (calcDeps s ++ ss)
1823 (Map.insert key [Right s] done)
1824 where
1825 key = (unLoc wanted_mod, is_boot)
1826
1827 mkRootMap :: [ModSummary] -> NodeMap [Either ErrMsg ModSummary]
1828 mkRootMap summaries = Map.insertListWith (flip (++))
1829 [ (msKey s, [Right s]) | s <- summaries ]
1830 Map.empty
1831
1832 -- | Returns the dependencies of the ModSummary s.
1833 -- A wrinkle is that for a {-# SOURCE #-} import we return
1834 -- *both* the hs-boot file
1835 -- *and* the source file
1836 -- as "dependencies". That ensures that the list of all relevant
1837 -- modules always contains B.hs if it contains B.hs-boot.
1838 -- Remember, this pass isn't doing the topological sort. It's
1839 -- just gathering the list of all relevant ModSummaries
1840 msDeps :: ModSummary -> [(Located ModuleName, IsBoot)]
1841 msDeps s =
1842 concat [ [(m,IsBoot), (m,NotBoot)] | m <- ms_home_srcimps s ]
1843 ++ [ (m,NotBoot) | m <- ms_home_imps s ]
1844
1845 home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]
1846 home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps,
1847 isLocal mb_pkg ]
1848 where isLocal Nothing = True
1849 isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
1850 isLocal _ = False
1851
1852 ms_home_allimps :: ModSummary -> [ModuleName]
1853 ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)
1854
1855 -- | Like 'ms_home_imps', but for SOURCE imports.
1856 ms_home_srcimps :: ModSummary -> [Located ModuleName]
1857 ms_home_srcimps = home_imps . ms_srcimps
1858
1859 -- | All of the (possibly) home module imports from a
1860 -- 'ModSummary'; that is to say, each of these module names
1861 -- could be a home import if an appropriately named file
1862 -- existed. (This is in contrast to package qualified
1863 -- imports, which are guaranteed not to be home imports.)
1864 ms_home_imps :: ModSummary -> [Located ModuleName]
1865 ms_home_imps = home_imps . ms_imps
1866
1867 -----------------------------------------------------------------------------
1868 -- Summarising modules
1869
1870 -- We have two types of summarisation:
1871 --
1872 -- * Summarise a file. This is used for the root module(s) passed to
1873 -- cmLoadModules. The file is read, and used to determine the root
1874 -- module name. The module name may differ from the filename.
1875 --
1876 -- * Summarise a module. We are given a module name, and must provide
1877 -- a summary. The finder is used to locate the file in which the module
1878 -- resides.
1879
1880 summariseFile
1881 :: HscEnv
1882 -> [ModSummary] -- old summaries
1883 -> FilePath -- source file name
1884 -> Maybe Phase -- start phase
1885 -> Bool -- object code allowed?
1886 -> Maybe (StringBuffer,UTCTime)
1887 -> IO ModSummary
1888
1889 summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
1890 -- we can use a cached summary if one is available and the
1891 -- source file hasn't changed, But we have to look up the summary
1892 -- by source file, rather than module name as we do in summarise.
1893 | Just old_summary <- findSummaryBySourceFile old_summaries file
1894 = do
1895 let location = ms_location old_summary
1896 dflags = hsc_dflags hsc_env
1897
1898 src_timestamp <- get_src_timestamp
1899 -- The file exists; we checked in getRootSummary above.
1900 -- If it gets removed subsequently, then this
1901 -- getModificationUTCTime may fail, but that's the right
1902 -- behaviour.
1903
1904 -- return the cached summary if the source didn't change
1905 if ms_hs_date old_summary == src_timestamp &&
1906 not (gopt Opt_ForceRecomp (hsc_dflags hsc_env))
1907 then do -- update the object-file timestamp
1908 obj_timestamp <-
1909 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
1910 || obj_allowed -- bug #1205
1911 then liftIO $ getObjTimestamp location NotBoot
1912 else return Nothing
1913 hi_timestamp <- maybeGetIfaceDate dflags location
1914 return old_summary{ ms_obj_date = obj_timestamp
1915 , ms_iface_date = hi_timestamp }
1916 else
1917 new_summary src_timestamp
1918
1919 | otherwise
1920 = do src_timestamp <- get_src_timestamp
1921 new_summary src_timestamp
1922 where
1923 get_src_timestamp = case maybe_buf of
1924 Just (_,t) -> return t
1925 Nothing -> liftIO $ getModificationUTCTime file
1926 -- getModificationUTCTime may fail
1927
1928 new_summary src_timestamp = do
1929 let dflags = hsc_dflags hsc_env
1930
1931 let hsc_src = if isHaskellSigFilename file then HsigFile else HsSrcFile
1932
1933 (dflags', hspp_fn, buf)
1934 <- preprocessFile hsc_env file mb_phase maybe_buf
1935
1936 (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
1937
1938 -- Make a ModLocation for this file
1939 location <- liftIO $ mkHomeModLocation dflags mod_name file
1940
1941 -- Tell the Finder cache where it is, so that subsequent calls
1942 -- to findModule will find it, even if it's not on any search path
1943 mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
1944
1945 -- when the user asks to load a source file by name, we only
1946 -- use an object file if -fobject-code is on. See #1205.
1947 obj_timestamp <-
1948 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
1949 || obj_allowed -- bug #1205
1950 then liftIO $ modificationTimeIfExists (ml_obj_file location)
1951 else return Nothing
1952
1953 hi_timestamp <- maybeGetIfaceDate dflags location
1954
1955 extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name
1956 required_by_imports <- implicitRequirements hsc_env the_imps
1957
1958 return (ModSummary { ms_mod = mod,
1959 ms_hsc_src = hsc_src,
1960 ms_location = location,
1961 ms_hspp_file = hspp_fn,
1962 ms_hspp_opts = dflags',
1963 ms_hspp_buf = Just buf,
1964 ms_parsed_mod = Nothing,
1965 ms_srcimps = srcimps,
1966 ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports,
1967 ms_hs_date = src_timestamp,
1968 ms_iface_date = hi_timestamp,
1969 ms_obj_date = obj_timestamp })
1970
1971 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
1972 findSummaryBySourceFile summaries file
1973 = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
1974 expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
1975 [] -> Nothing
1976 (x:_) -> Just x
1977
1978 -- Summarise a module, and pick up source and timestamp.
1979 summariseModule
1980 :: HscEnv
1981 -> NodeMap ModSummary -- Map of old summaries
1982 -> IsBoot -- IsBoot <=> a {-# SOURCE #-} import
1983 -> Located ModuleName -- Imported module to be summarised
1984 -> Bool -- object code allowed?
1985 -> Maybe (StringBuffer, UTCTime)
1986 -> [ModuleName] -- Modules to exclude
1987 -> IO (Maybe (Either ErrMsg ModSummary)) -- Its new summary
1988
1989 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
1990 obj_allowed maybe_buf excl_mods
1991 | wanted_mod `elem` excl_mods
1992 = return Nothing
1993
1994 | Just old_summary <- Map.lookup (wanted_mod, is_boot) old_summary_map
1995 = do -- Find its new timestamp; all the
1996 -- ModSummaries in the old map have valid ml_hs_files
1997 let location = ms_location old_summary
1998 src_fn = expectJust "summariseModule" (ml_hs_file location)
1999
2000 -- check the modification time on the source file, and
2001 -- return the cached summary if it hasn't changed. If the
2002 -- file has disappeared, we need to call the Finder again.
2003 case maybe_buf of
2004 Just (_,t) -> check_timestamp old_summary location src_fn t
2005 Nothing -> do
2006 m <- tryIO (getModificationUTCTime src_fn)
2007 case m of
2008 Right t -> check_timestamp old_summary location src_fn t
2009 Left e | isDoesNotExistError e -> find_it
2010 | otherwise -> ioError e
2011
2012 | otherwise = find_it
2013 where
2014 dflags = hsc_dflags hsc_env
2015
2016 check_timestamp old_summary location src_fn src_timestamp
2017 | ms_hs_date old_summary == src_timestamp &&
2018 not (gopt Opt_ForceRecomp dflags) = do
2019 -- update the object-file timestamp
2020 obj_timestamp <-
2021 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2022 || obj_allowed -- bug #1205
2023 then getObjTimestamp location is_boot
2024 else return Nothing
2025 hi_timestamp <- maybeGetIfaceDate dflags location
2026 return (Just (Right old_summary{ ms_obj_date = obj_timestamp
2027 , ms_iface_date = hi_timestamp}))
2028 | otherwise =
2029 -- source changed: re-summarise.
2030 new_summary location (ms_mod old_summary) src_fn src_timestamp
2031
2032 find_it = do
2033 -- Don't use the Finder's cache this time. If the module was
2034 -- previously a package module, it may have now appeared on the
2035 -- search path, so we want to consider it to be a home module. If
2036 -- the module was previously a home module, it may have moved.
2037 uncacheModule hsc_env wanted_mod
2038 found <- findImportedModule hsc_env wanted_mod Nothing
2039 case found of
2040 Found location mod
2041 | isJust (ml_hs_file location) ->
2042 -- Home package
2043 just_found location mod
2044
2045 _ -> return Nothing
2046 -- Not found
2047 -- (If it is TRULY not found at all, we'll
2048 -- error when we actually try to compile)
2049
2050 just_found location mod = do
2051 -- Adjust location to point to the hs-boot source file,
2052 -- hi file, object file, when is_boot says so
2053 let location' | IsBoot <- is_boot = addBootSuffixLocn location
2054 | otherwise = location
2055 src_fn = expectJust "summarise2" (ml_hs_file location')
2056
2057 -- Check that it exists
2058 -- It might have been deleted since the Finder last found it
2059 maybe_t <- modificationTimeIfExists src_fn
2060 case maybe_t of
2061 Nothing -> return $ Just $ Left $ noHsFileErr dflags loc src_fn
2062 Just t -> new_summary location' mod src_fn t
2063
2064
2065 new_summary location mod src_fn src_timestamp
2066 = do
2067 -- Preprocess the source file and get its imports
2068 -- The dflags' contains the OPTIONS pragmas
2069 (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
2070 (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
2071
2072 -- NB: Despite the fact that is_boot is a top-level parameter, we
2073 -- don't actually know coming into this function what the HscSource
2074 -- of the module in question is. This is because we may be processing
2075 -- this module because another module in the graph imported it: in this
2076 -- case, we know if it's a boot or not because of the {-# SOURCE #-}
2077 -- annotation, but we don't know if it's a signature or a regular
2078 -- module until we actually look it up on the filesystem.
2079 let hsc_src = case is_boot of
2080 IsBoot -> HsBootFile
2081 _ | isHaskellSigFilename src_fn -> HsigFile
2082 | otherwise -> HsSrcFile
2083
2084 when (mod_name /= wanted_mod) $
2085 throwOneError $ mkPlainErrMsg dflags' mod_loc $
2086 text "File name does not match module name:"
2087 $$ text "Saw:" <+> quotes (ppr mod_name)
2088 $$ text "Expected:" <+> quotes (ppr wanted_mod)
2089
2090 when (hsc_src == HsigFile && isNothing (lookup mod_name (thisUnitIdInsts dflags))) $
2091 let suggested_instantiated_with =
2092 hcat (punctuate comma $
2093 [ ppr k <> text "=" <> ppr v
2094 | (k,v) <- ((mod_name, mkHoleModule mod_name)
2095 : thisUnitIdInsts dflags)
2096 ])
2097 in throwOneError $ mkPlainErrMsg dflags' mod_loc $
2098 text "Unexpected signature:" <+> quotes (ppr mod_name)
2099 $$ if gopt Opt_BuildingCabalPackage dflags
2100 then parens (text "Try adding" <+> quotes (ppr mod_name)
2101 <+> text "to the"
2102 <+> quotes (text "signatures")
2103 <+> text "field in your Cabal file.")
2104 else parens (text "Try passing -instantiated-with=\"" <>
2105 suggested_instantiated_with <> text "\"" $$
2106 text "replacing <" <> ppr mod_name <> text "> as necessary.")
2107
2108 -- Find the object timestamp, and return the summary
2109 obj_timestamp <-
2110 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
2111 || obj_allowed -- bug #1205
2112 then getObjTimestamp location is_boot
2113 else return Nothing
2114
2115 hi_timestamp <- maybeGetIfaceDate dflags location
2116
2117 extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name
2118 required_by_imports <- implicitRequirements hsc_env the_imps
2119
2120 return (Just (Right (ModSummary { ms_mod = mod,
2121 ms_hsc_src = hsc_src,
2122 ms_location = location,
2123 ms_hspp_file = hspp_fn,
2124 ms_hspp_opts = dflags',
2125 ms_hspp_buf = Just buf,
2126 ms_parsed_mod = Nothing,
2127 ms_srcimps = srcimps,
2128 ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports,
2129 ms_hs_date = src_timestamp,
2130 ms_iface_date = hi_timestamp,
2131 ms_obj_date = obj_timestamp })))
2132
2133
2134 getObjTimestamp :: ModLocation -> IsBoot -> IO (Maybe UTCTime)
2135 getObjTimestamp location is_boot
2136 = if is_boot == IsBoot then return Nothing
2137 else modificationTimeIfExists (ml_obj_file location)
2138
2139
2140 preprocessFile :: HscEnv
2141 -> FilePath
2142 -> Maybe Phase -- ^ Starting phase
2143 -> Maybe (StringBuffer,UTCTime)
2144 -> IO (DynFlags, FilePath, StringBuffer)
2145 preprocessFile hsc_env src_fn mb_phase Nothing
2146 = do
2147 (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
2148 buf <- hGetStringBuffer hspp_fn
2149 return (dflags', hspp_fn, buf)
2150
2151 preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
2152 = do
2153 let dflags = hsc_dflags hsc_env
2154 let local_opts = getOptions dflags buf src_fn
2155
2156 (dflags', leftovers, warns)
2157 <- parseDynamicFilePragma dflags local_opts
2158 checkProcessArgsResult dflags leftovers
2159 handleFlagWarnings dflags' warns
2160
2161 let needs_preprocessing
2162 | Just (Unlit _) <- mb_phase = True
2163 | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
2164 -- note: local_opts is only required if there's no Unlit phase
2165 | xopt LangExt.Cpp dflags' = True
2166 | gopt Opt_Pp dflags' = True
2167 | otherwise = False
2168
2169 when needs_preprocessing $
2170 throwGhcExceptionIO (ProgramError "buffer needs preprocesing; interactive check disabled")
2171
2172 return (dflags', src_fn, buf)
2173
2174
2175 -----------------------------------------------------------------------------
2176 -- Error messages
2177 -----------------------------------------------------------------------------
2178
2179 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg
2180 -- ToDo: we don't have a proper line number for this error
2181 noModError dflags loc wanted_mod err
2182 = mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err
2183
2184 noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrMsg
2185 noHsFileErr dflags loc path
2186 = mkPlainErrMsg dflags loc $ text "Can't find" <+> text path
2187
2188 moduleNotFoundErr :: DynFlags -> ModuleName -> ErrMsg
2189 moduleNotFoundErr dflags mod
2190 = mkPlainErrMsg dflags noSrcSpan $
2191 text "module" <+> quotes (ppr mod) <+> text "cannot be found locally"
2192
2193 multiRootsErr :: DynFlags -> [ModSummary] -> IO ()
2194 multiRootsErr _ [] = panic "multiRootsErr"
2195 multiRootsErr dflags summs@(summ1:_)
2196 = throwOneError $ mkPlainErrMsg dflags noSrcSpan $
2197 text "module" <+> quotes (ppr mod) <+>
2198 text "is defined in multiple files:" <+>
2199 sep (map text files)
2200 where
2201 mod = ms_mod summ1
2202 files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
2203
2204 cyclicModuleErr :: [ModSummary] -> SDoc
2205 -- From a strongly connected component we find
2206 -- a single cycle to report
2207 cyclicModuleErr mss
2208 = ASSERT( not (null mss) )
2209 case findCycle graph of
2210 Nothing -> text "Unexpected non-cycle" <+> ppr mss
2211 Just path -> vcat [ text "Module imports form a cycle:"
2212 , nest 2 (show_path path) ]
2213 where
2214 graph :: [Node NodeKey ModSummary]
2215 graph = [(ms, msKey ms, get_deps ms) | ms <- mss]
2216
2217 get_deps :: ModSummary -> [NodeKey]
2218 get_deps ms = ([ (unLoc m, IsBoot) | m <- ms_home_srcimps ms ] ++
2219 [ (unLoc m, NotBoot) | m <- ms_home_imps ms ])
2220
2221 show_path [] = panic "show_path"
2222 show_path [m] = text "module" <+> ppr_ms m
2223 <+> text "imports itself"
2224 show_path (m1:m2:ms) = vcat ( nest 7 (text "module" <+> ppr_ms m1)
2225 : nest 6 (text "imports" <+> ppr_ms m2)
2226 : go ms )
2227 where
2228 go [] = [text "which imports" <+> ppr_ms m1]
2229 go (m:ms) = (text "which imports" <+> ppr_ms m) : go ms
2230
2231
2232 ppr_ms :: ModSummary -> SDoc
2233 ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>
2234 (parens (text (msHsFilePath ms)))