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