never executed always true always false
1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE DeriveTraversable #-}
3 {-# LANGUAGE NamedFieldPuns #-}
4 {-# LANGUAGE NondecreasingIndentation #-}
5 {-# LANGUAGE LambdaCase #-}
6 {-# LANGUAGE RecordWildCards #-}
7 {-# LANGUAGE ScopedTypeVariables #-}
8
9 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
10 {-# LANGUAGE FlexibleContexts #-}
11 {-# LANGUAGE GADTs #-}
12 {-# LANGUAGE MultiParamTypeClasses #-}
13 {-# LANGUAGE FlexibleInstances #-}
14 {-# LANGUAGE RankNTypes #-}
15 {-# LANGUAGE DerivingStrategies #-}
16 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
17 {-# LANGUAGE TupleSections #-}
18 {-# LANGUAGE ApplicativeDo #-}
19
20 -- -----------------------------------------------------------------------------
21 --
22 -- (c) The University of Glasgow, 2011
23 --
24 -- This module implements multi-module compilation, and is used
25 -- by --make and GHCi.
26 --
27 -- -----------------------------------------------------------------------------
28 module GHC.Driver.Make (
29 depanal, depanalE, depanalPartial,
30 load, loadWithCache, load', LoadHowMuch(..),
31 instantiationNodes,
32
33 downsweep,
34
35 topSortModuleGraph,
36
37 ms_home_srcimps, ms_home_imps,
38
39 summariseModule,
40 summariseFile,
41 hscSourceToIsBoot,
42 findExtraSigImports,
43 implicitRequirementsShallow,
44
45 noModError, cyclicModuleErr,
46 moduleGraphNodes, SummaryNode,
47 IsBootInterface(..), mkNodeKey,
48
49 ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert
50 ) where
51
52 import GHC.Prelude
53 import GHC.Platform
54
55 import GHC.Tc.Utils.Backpack
56 import GHC.Tc.Utils.Monad ( initIfaceLoad )
57
58 import GHC.Runtime.Interpreter
59 import qualified GHC.Linker.Loader as Linker
60 import GHC.Linker.Types
61
62 import GHC.Runtime.Context
63
64 import GHC.Driver.Config.Finder (initFinderOpts)
65 import GHC.Driver.Config.Parser (initParserOpts)
66 import GHC.Driver.Config.Diagnostic
67 import GHC.Driver.Phases
68 import GHC.Driver.Pipeline
69 import GHC.Driver.Session
70 import GHC.Driver.Backend
71 import GHC.Driver.Monad
72 import GHC.Driver.Env
73 import GHC.Driver.Errors
74 import GHC.Driver.Errors.Types
75 import GHC.Driver.Main
76
77 import GHC.Parser.Header
78
79 import GHC.Iface.Load ( cannotFindModule )
80 import GHC.IfaceToCore ( typecheckIface )
81 import GHC.Iface.Recomp ( RecompileRequired ( MustCompile ) )
82
83 import GHC.Data.Bag ( listToBag )
84 import GHC.Data.Graph.Directed
85 import GHC.Data.FastString
86 import GHC.Data.Maybe ( expectJust )
87 import GHC.Data.StringBuffer
88 import qualified GHC.LanguageExtensions as LangExt
89
90 import GHC.Utils.Exception ( throwIO, SomeAsyncException )
91 import GHC.Utils.Outputable
92 import GHC.Utils.Panic
93 import GHC.Utils.Panic.Plain
94 import GHC.Utils.Misc
95 import GHC.Utils.Error
96 import GHC.Utils.Logger
97 import GHC.Utils.Fingerprint
98 import GHC.Utils.TmpFs
99
100 import GHC.Types.Basic
101 import GHC.Types.Error
102 import GHC.Types.Target
103 import GHC.Types.SourceFile
104 import GHC.Types.SourceError
105 import GHC.Types.SrcLoc
106 import GHC.Types.Unique.FM
107 import GHC.Types.Unique.DSet
108 import GHC.Types.Unique.Set
109 import GHC.Types.Name
110 import GHC.Types.Name.Env
111 import GHC.Types.PkgQual
112
113 import GHC.Unit
114 import GHC.Unit.Finder
115 import GHC.Unit.Module.ModSummary
116 import GHC.Unit.Module.ModIface
117 import GHC.Unit.Module.ModDetails
118 import GHC.Unit.Module.Graph
119 import GHC.Unit.Home.ModInfo
120
121 import Data.Either ( rights, partitionEithers )
122 import qualified Data.Map as Map
123 import qualified Data.Set as Set
124 import qualified GHC.Data.FiniteMap as Map ( insertListWith )
125
126 import Control.Concurrent ( forkIO, newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )
127 import qualified GHC.Conc as CC
128 import Control.Concurrent.MVar
129 import Control.Monad
130 import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
131 import qualified Control.Monad.Catch as MC
132 import Data.IORef
133 import Data.Foldable (toList)
134 import Data.Maybe
135 import Data.Time
136 import Data.Bifunctor (first)
137 import System.Directory
138 import System.FilePath
139 import System.IO ( fixIO )
140
141 import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )
142 import Control.Monad.IO.Class
143 import Control.Monad.Trans.Reader
144 import GHC.Driver.Pipeline.LogQueue
145 import qualified Data.Map.Strict as M
146 import GHC.Types.TypeEnv
147 import Control.Monad.Trans.State.Lazy
148 import Control.Monad.Trans.Class
149 import GHC.Driver.Env.KnotVars
150 import Control.Concurrent.STM
151 import Control.Monad.Trans.Maybe
152 import GHC.Runtime.Loader
153 import GHC.Rename.Names
154
155
156 -- -----------------------------------------------------------------------------
157 -- Loading the program
158
159 -- | Perform a dependency analysis starting from the current targets
160 -- and update the session with the new module graph.
161 --
162 -- Dependency analysis entails parsing the @import@ directives and may
163 -- therefore require running certain preprocessors.
164 --
165 -- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.
166 -- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the
167 -- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want
168 -- changes to the 'DynFlags' to take effect you need to call this function
169 -- again.
170 -- In case of errors, just throw them.
171 --
172 depanal :: GhcMonad m =>
173 [ModuleName] -- ^ excluded modules
174 -> Bool -- ^ allow duplicate roots
175 -> m ModuleGraph
176 depanal excluded_mods allow_dup_roots = do
177 (errs, mod_graph) <- depanalE excluded_mods allow_dup_roots
178 if isEmptyMessages errs
179 then pure mod_graph
180 else throwErrors (fmap GhcDriverMessage errs)
181
182 -- | Perform dependency analysis like in 'depanal'.
183 -- In case of errors, the errors and an empty module graph are returned.
184 depanalE :: GhcMonad m => -- New for #17459
185 [ModuleName] -- ^ excluded modules
186 -> Bool -- ^ allow duplicate roots
187 -> m (DriverMessages, ModuleGraph)
188 depanalE excluded_mods allow_dup_roots = do
189 hsc_env <- getSession
190 (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots
191 if isEmptyMessages errs
192 then do
193 let unused_home_mod_err = warnMissingHomeModules hsc_env mod_graph
194 unused_pkg_err = warnUnusedPackages hsc_env mod_graph
195 logDiagnostics (GhcDriverMessage <$> (unused_home_mod_err `unionMessages` unused_pkg_err))
196 setSession hsc_env { hsc_mod_graph = mod_graph }
197 pure (emptyMessages, mod_graph)
198 else do
199 -- We don't have a complete module dependency graph,
200 -- The graph may be disconnected and is unusable.
201 setSession hsc_env { hsc_mod_graph = emptyMG }
202 pure (errs, emptyMG)
203
204
205 -- | Perform dependency analysis like 'depanal' but return a partial module
206 -- graph even in the face of problems with some modules.
207 --
208 -- Modules which have parse errors in the module header, failing
209 -- preprocessors or other issues preventing them from being summarised will
210 -- simply be absent from the returned module graph.
211 --
212 -- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the
213 -- new module graph.
214 depanalPartial
215 :: GhcMonad m
216 => [ModuleName] -- ^ excluded modules
217 -> Bool -- ^ allow duplicate roots
218 -> m (DriverMessages, ModuleGraph)
219 -- ^ possibly empty 'Bag' of errors and a module graph.
220 depanalPartial excluded_mods allow_dup_roots = do
221 hsc_env <- getSession
222 let
223 targets = hsc_targets hsc_env
224 old_graph = hsc_mod_graph hsc_env
225 logger = hsc_logger hsc_env
226
227 withTiming logger (text "Chasing dependencies") (const ()) $ do
228 liftIO $ debugTraceMsg logger 2 (hcat [
229 text "Chasing modules from: ",
230 hcat (punctuate comma (map pprTarget targets))])
231
232 -- Home package modules may have been moved or deleted, and new
233 -- source files may have appeared in the home package that shadow
234 -- external package modules, so we have to discard the existing
235 -- cached finder data.
236 liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_home_unit hsc_env)
237
238 mod_summariesE <- liftIO $ downsweep
239 hsc_env (mgExtendedModSummaries old_graph)
240 excluded_mods allow_dup_roots
241 let
242 (errs, mod_summaries) = partitionEithers mod_summariesE
243 mod_graph = mkModuleGraph' $
244 (instantiationNodes (hsc_units hsc_env))
245 ++ fmap ModuleNode mod_summaries
246 return (unionManyMessages errs, mod_graph)
247
248 -- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes.
249 -- These are used to represent the type checking that is done after
250 -- all the free holes (sigs in current package) relevant to that instantiation
251 -- are compiled. This is necessary to catch some instantiation errors.
252 --
253 -- In the future, perhaps more of the work of instantiation could be moved here,
254 -- instead of shoved in with the module compilation nodes. That could simplify
255 -- backpack, and maybe hs-boot too.
256 instantiationNodes :: UnitState -> [ModuleGraphNode]
257 instantiationNodes unit_state = InstantiationNode <$> iuids_to_check
258 where
259 iuids_to_check :: [InstantiatedUnit]
260 iuids_to_check =
261 nubSort $ concatMap goUnitId (explicitUnits unit_state)
262 where
263 goUnitId uid =
264 [ recur
265 | VirtUnit indef <- [uid]
266 , inst <- instUnitInsts indef
267 , recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst
268 ]
269
270 -- Note [Missing home modules]
271 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
272 -- Sometimes user doesn't want GHC to pick up modules, not explicitly listed
273 -- in a command line. For example, cabal may want to enable this warning
274 -- when building a library, so that GHC warns user about modules, not listed
275 -- neither in `exposed-modules`, nor in `other-modules`.
276 --
277 -- Here "home module" means a module, that doesn't come from an other package.
278 --
279 -- For example, if GHC is invoked with modules "A" and "B" as targets,
280 -- but "A" imports some other module "C", then GHC will issue a warning
281 -- about module "C" not being listed in a command line.
282 --
283 -- The warning in enabled by `-Wmissing-home-modules`. See #13129
284 warnMissingHomeModules :: HscEnv -> ModuleGraph -> DriverMessages
285 warnMissingHomeModules hsc_env mod_graph =
286 if null missing
287 then emptyMessages
288 else warn
289 where
290 dflags = hsc_dflags hsc_env
291 targets = map targetId (hsc_targets hsc_env)
292 diag_opts = initDiagOpts dflags
293
294 is_known_module mod = any (is_my_target mod) targets
295
296 -- We need to be careful to handle the case where (possibly
297 -- path-qualified) filenames (aka 'TargetFile') rather than module
298 -- names are being passed on the GHC command-line.
299 --
300 -- For instance, `ghc --make src-exe/Main.hs` and
301 -- `ghc --make -isrc-exe Main` are supposed to be equivalent.
302 -- Note also that we can't always infer the associated module name
303 -- directly from the filename argument. See #13727.
304 is_my_target mod (TargetModule name)
305 = moduleName (ms_mod mod) == name
306 is_my_target mod (TargetFile target_file _)
307 | Just mod_file <- ml_hs_file (ms_location mod)
308 = target_file == mod_file ||
309
310 -- Don't warn on B.hs-boot if B.hs is specified (#16551)
311 addBootSuffix target_file == mod_file ||
312
313 -- We can get a file target even if a module name was
314 -- originally specified in a command line because it can
315 -- be converted in guessTarget (by appending .hs/.lhs).
316 -- So let's convert it back and compare with module name
317 mkModuleName (fst $ splitExtension target_file)
318 == moduleName (ms_mod mod)
319 is_my_target _ _ = False
320
321 missing = map (moduleName . ms_mod) $
322 filter (not . is_known_module) (mgModSummaries mod_graph)
323
324 warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan
325 $ DriverMissingHomeModules missing (checkBuildingCabalPackage dflags)
326
327 -- | Describes which modules of the module graph need to be loaded.
328 data LoadHowMuch
329 = LoadAllTargets
330 -- ^ Load all targets and its dependencies.
331 | LoadUpTo ModuleName
332 -- ^ Load only the given module and its dependencies.
333 | LoadDependenciesOf ModuleName
334 -- ^ Load only the dependencies of the given module, but not the module
335 -- itself.
336
337 -- | Try to load the program. See 'LoadHowMuch' for the different modes.
338 --
339 -- This function implements the core of GHC's @--make@ mode. It preprocesses,
340 -- compiles and loads the specified modules, avoiding re-compilation wherever
341 -- possible. Depending on the backend (see 'DynFlags.backend' field) compiling
342 -- and loading may result in files being created on disk.
343 --
344 -- Calls the 'defaultWarnErrLogger' after each compiling each module, whether
345 -- successful or not.
346 --
347 -- If errors are encountered during dependency analysis, the module `depanalE`
348 -- returns together with the errors an empty ModuleGraph.
349 -- After processing this empty ModuleGraph, the errors of depanalE are thrown.
350 -- All other errors are reported using the 'defaultWarnErrLogger'.
351
352 load :: GhcMonad f => LoadHowMuch -> f SuccessFlag
353 load how_much = fst <$> loadWithCache [] how_much
354
355 loadWithCache :: GhcMonad m => [HomeModInfo] -> LoadHowMuch -> m (SuccessFlag, [HomeModInfo])
356 loadWithCache cache how_much = do
357 (errs, mod_graph) <- depanalE [] False -- #17459
358 success <- load' cache how_much (Just batchMsg) mod_graph
359 if isEmptyMessages errs
360 then pure success
361 else throwErrors (fmap GhcDriverMessage errs)
362
363 -- Note [Unused packages]
364 --
365 -- Cabal passes `--package-id` flag for each direct dependency. But GHC
366 -- loads them lazily, so when compilation is done, we have a list of all
367 -- actually loaded packages. All the packages, specified on command line,
368 -- but never loaded, are probably unused dependencies.
369
370 warnUnusedPackages :: HscEnv -> ModuleGraph -> DriverMessages
371 warnUnusedPackages hsc_env mod_graph =
372 let dflags = hsc_dflags hsc_env
373 state = hsc_units hsc_env
374 diag_opts = initDiagOpts dflags
375 us = hsc_units hsc_env
376
377 -- Only need non-source imports here because SOURCE imports are always HPT
378 loadedPackages = concat $
379 mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)
380 $ concatMap ms_imps (mgModSummaries mod_graph)
381
382 requestedArgs = mapMaybe packageArg (packageFlags dflags)
383
384 unusedArgs
385 = filter (\arg -> not $ any (matching state arg) loadedPackages)
386 requestedArgs
387
388 warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan (DriverUnusedPackages unusedArgs)
389
390 in if null unusedArgs
391 then emptyMessages
392 else warn
393
394 where
395 packageArg (ExposePackage _ arg _) = Just arg
396 packageArg _ = Nothing
397
398 matchingStr :: String -> UnitInfo -> Bool
399 matchingStr str p
400 = str == unitPackageIdString p
401 || str == unitPackageNameString p
402
403 matching :: UnitState -> PackageArg -> UnitInfo -> Bool
404 matching _ (PackageArg str) p = matchingStr str p
405 matching state (UnitIdArg uid) p = uid == realUnit state p
406
407 -- For wired-in packages, we have to unwire their id,
408 -- otherwise they won't match package flags
409 realUnit :: UnitState -> UnitInfo -> Unit
410 realUnit state
411 = unwireUnit state
412 . RealUnit
413 . Definite
414 . unitId
415
416
417 data BuildPlan = SingleModule ModuleGraphNode -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle
418 | ResolvedCycle [ModuleGraphNode] -- A resolved cycle, linearised by hs-boot files
419 | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files
420
421 instance Outputable BuildPlan where
422 ppr (SingleModule mgn) = text "SingleModule" <> parens (ppr mgn)
423 ppr (ResolvedCycle mgn) = text "ResolvedCycle:" <+> ppr mgn
424 ppr (UnresolvedCycle mgn) = text "UnresolvedCycle:" <+> ppr mgn
425
426
427 -- Just used for an assertion
428 countMods :: BuildPlan -> Int
429 countMods (SingleModule _) = 1
430 countMods (ResolvedCycle ns) = length ns
431 countMods (UnresolvedCycle ns) = length ns
432
433 -- See Note [Upsweep] for a high-level description.
434 createBuildPlan :: ModuleGraph -> Maybe ModuleName -> [BuildPlan]
435 createBuildPlan mod_graph maybe_top_mod =
436 let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles
437 cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod
438
439 -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles.
440 build_plan :: [BuildPlan]
441 build_plan
442 -- Fast path, if there are no boot modules just do a normal toposort
443 | isEmptyModuleEnv boot_modules = collapseAcyclic $ topSortModuleGraph False mod_graph maybe_top_mod
444 | otherwise = toBuildPlan cycle_mod_graph []
445
446 toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]
447 toBuildPlan [] mgn = collapseAcyclic (topSortWithBoot mgn)
448 toBuildPlan ((AcyclicSCC node):sccs) mgn = toBuildPlan sccs (node:mgn)
449 -- Interesting case
450 toBuildPlan ((CyclicSCC nodes):sccs) mgn =
451 let acyclic = collapseAcyclic (topSortWithBoot mgn)
452 -- Now perform another toposort but just with these nodes and relevant hs-boot files.
453 -- The result should be acyclic, if it's not, then there's an unresolved cycle in the graph.
454 mresolved_cycle = collapseSCC (topSortWithBoot nodes)
455 in acyclic ++ [maybe (UnresolvedCycle nodes) ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs []
456
457 -- An environment mapping a module to its hs-boot file, if one exists
458 boot_modules = mkModuleEnv
459 [ (ms_mod ms, m) | m@(ModuleNode (ExtendedModSummary ms _)) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot]
460
461 select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]
462 select_boot_modules = mapMaybe (\m -> case m of ModuleNode (ExtendedModSummary ms _) -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing )
463
464 -- Any cycles should be resolved now
465 collapseSCC :: [SCC ModuleGraphNode] -> Maybe [ModuleGraphNode]
466 -- Must be at least two nodes, as we were in a cycle
467 collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Just [node1, node2]
468 collapseSCC (AcyclicSCC node : nodes) = (node :) <$> collapseSCC nodes
469 -- Cyclic
470 collapseSCC _ = Nothing
471
472 -- The toposort and accumulation of acyclic modules is solely to pick-up
473 -- hs-boot files which are **not** part of cycles.
474 collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan]
475 collapseAcyclic (AcyclicSCC node : nodes) = SingleModule node : collapseAcyclic nodes
476 collapseAcyclic (CyclicSCC cy_nodes : nodes) = (UnresolvedCycle cy_nodes) : collapseAcyclic nodes
477 collapseAcyclic [] = []
478
479 topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing
480
481
482 in
483
484 assertPpr (sum (map countMods build_plan) == length (mgModSummaries' mod_graph))
485 (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr build_plan), (text "GRAPH:" <+> ppr (mgModSummaries' mod_graph ))])
486 build_plan
487
488 -- | Generalized version of 'load' which also supports a custom
489 -- 'Messager' (for reporting progress) and 'ModuleGraph' (generally
490 -- produced by calling 'depanal'.
491 load' :: GhcMonad m => [HomeModInfo] -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m (SuccessFlag, [HomeModInfo])
492 load' cache how_much mHscMessage mod_graph = do
493 modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }
494 guessOutputFile
495 hsc_env <- getSession
496
497 let dflags = hsc_dflags hsc_env
498 let logger = hsc_logger hsc_env
499 let interp = hscInterp hsc_env
500
501 -- The "bad" boot modules are the ones for which we have
502 -- B.hs-boot in the module graph, but no B.hs
503 -- The downsweep should have ensured this does not happen
504 -- (see msDeps)
505 let all_home_mods =
506 mkUniqSet [ ms_mod_name s
507 | s <- mgModSummaries mod_graph, isBootSummary s == NotBoot]
508 -- TODO: Figure out what the correct form of this assert is. It's violated
509 -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot
510 -- files without corresponding hs files.
511 -- bad_boot_mods = [s | s <- mod_graph, isBootSummary s,
512 -- not (ms_mod_name s `elem` all_home_mods)]
513 -- assert (null bad_boot_mods ) return ()
514
515 -- check that the module given in HowMuch actually exists, otherwise
516 -- topSortModuleGraph will bomb later.
517 let checkHowMuch (LoadUpTo m) = checkMod m
518 checkHowMuch (LoadDependenciesOf m) = checkMod m
519 checkHowMuch _ = id
520
521 checkMod m and_then
522 | m `elementOfUniqSet` all_home_mods = and_then
523 | otherwise = do
524 liftIO $ errorMsg logger
525 (text "no such module:" <+> quotes (ppr m))
526 return (Failed, [])
527
528 checkHowMuch how_much $ do
529
530 -- mg2_with_srcimps drops the hi-boot nodes, returning a
531 -- graph with cycles. It is just used for warning about unecessary source imports.
532 let mg2_with_srcimps :: [SCC ModuleGraphNode]
533 mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
534
535 -- If we can determine that any of the {-# SOURCE #-} imports
536 -- are definitely unnecessary, then emit a warning.
537 warnUnnecessarySourceImports (filterToposortToModules mg2_with_srcimps)
538
539 let maybe_top_mod = case how_much of
540 LoadUpTo m -> Just m
541 LoadDependenciesOf m -> Just m
542 _ -> Nothing
543
544 build_plan = createBuildPlan mod_graph maybe_top_mod
545
546
547
548
549 let
550 -- prune the HPT so everything is not retained when doing an
551 -- upsweep.
552 !pruned_cache = pruneCache cache
553 (flattenSCCs (filterToposortToModules mg2_with_srcimps))
554
555
556 -- before we unload anything, make sure we don't leave an old
557 -- interactive context around pointing to dead bindings. Also,
558 -- write an empty HPT to allow the old HPT to be GC'd.
559 setSession $ discardIC $ hscUpdateHPT (const emptyHomePackageTable) hsc_env
560
561 -- Unload everything
562 liftIO $ unload interp hsc_env
563
564 liftIO $ debugTraceMsg logger 2 (hang (text "Ready for upsweep")
565 2 (ppr build_plan))
566
567 let direct_deps = mkDepsMap (mgModSummaries' mod_graph)
568
569 n_jobs <- case parMakeCount dflags of
570 Nothing -> liftIO getNumProcessors
571 Just n -> return n
572
573 setSession $ hscUpdateHPT (const emptyHomePackageTable) hsc_env
574 hsc_env <- getSession
575 (upsweep_ok, hsc_env1, new_cache) <- withDeferredDiagnostics $
576 liftIO $ upsweep n_jobs hsc_env mHscMessage (toCache pruned_cache) direct_deps build_plan
577 setSession hsc_env1
578 fmap (, new_cache) $ case upsweep_ok of
579 Failed -> loadFinish upsweep_ok Succeeded
580
581 Succeeded -> do
582 -- Make modsDone be the summaries for each home module now
583 -- available; this should equal the domain of hpt3.
584 -- Get in in a roughly top .. bottom order (hence reverse).
585
586 -- Try and do linking in some form, depending on whether the
587 -- upsweep was completely or only partially successful.
588
589 -- Easy; just relink it all.
590 do liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.")
591
592 -- Clean up after ourselves
593 hsc_env1 <- getSession
594 liftIO $ cleanCurrentModuleTempFilesMaybe logger (hsc_tmpfs hsc_env1) dflags
595
596 -- Issue a warning for the confusing case where the user
597 -- said '-o foo' but we're not going to do any linking.
598 -- We attempt linking if either (a) one of the modules is
599 -- called Main, or (b) the user said -no-hs-main, indicating
600 -- that main() is going to come from somewhere else.
601 --
602 let ofile = outputFile_ dflags
603 let no_hs_main = gopt Opt_NoHsMain dflags
604 let
605 main_mod = mainModIs hsc_env
606 a_root_is_Main = mgElemModule mod_graph main_mod
607 do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib
608
609 -- link everything together
610 hsc_env <- getSession
611 linkresult <- liftIO $ link (ghcLink dflags)
612 logger
613 (hsc_tmpfs hsc_env)
614 (hsc_hooks hsc_env)
615 dflags
616 (hsc_unit_env hsc_env)
617 do_linking
618 (hsc_HPT hsc_env1)
619
620 if ghcLink dflags == LinkBinary && isJust ofile && not do_linking
621 then do
622 liftIO $ errorMsg logger $ text
623 ("output was redirected with -o, " ++
624 "but no output will be generated\n" ++
625 "because there is no " ++
626 moduleNameString (moduleName main_mod) ++ " module.")
627 -- This should be an error, not a warning (#10895).
628 loadFinish Failed linkresult
629 else
630 loadFinish Succeeded linkresult
631
632 partitionNodes
633 :: [ModuleGraphNode]
634 -> ( [InstantiatedUnit]
635 , [ExtendedModSummary]
636 )
637 partitionNodes ns = partitionEithers $ flip fmap ns $ \case
638 InstantiationNode x -> Left x
639 ModuleNode x -> Right x
640
641 -- | Finish up after a load.
642 loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag
643
644 -- If the link failed, unload everything and return.
645 loadFinish _all_ok Failed
646 = do hsc_env <- getSession
647 let interp = hscInterp hsc_env
648 liftIO $ unload interp hsc_env
649 modifySession discardProg
650 return Failed
651
652 -- Empty the interactive context and set the module context to the topmost
653 -- newly loaded module, or the Prelude if none were loaded.
654 loadFinish all_ok Succeeded
655 = do modifySession discardIC
656 return all_ok
657
658
659 -- | Forget the current program, but retain the persistent info in HscEnv
660 discardProg :: HscEnv -> HscEnv
661 discardProg hsc_env
662 = discardIC
663 $ hscUpdateHPT (const emptyHomePackageTable)
664 $ hsc_env { hsc_mod_graph = emptyMG }
665
666 -- | Discard the contents of the InteractiveContext, but keep the DynFlags and
667 -- the loaded plugins. It will also keep ic_int_print and ic_monad if their
668 -- names are from external packages.
669 discardIC :: HscEnv -> HscEnv
670 discardIC hsc_env
671 = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print
672 , ic_monad = new_ic_monad
673 , ic_plugins = old_plugins
674 } }
675 where
676 -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic
677 !new_ic_int_print = keep_external_name ic_int_print
678 !new_ic_monad = keep_external_name ic_monad
679 !old_plugins = ic_plugins old_ic
680 dflags = ic_dflags old_ic
681 old_ic = hsc_IC hsc_env
682 empty_ic = emptyInteractiveContext dflags
683 keep_external_name ic_name
684 | nameIsFromExternalPackage home_unit old_name = old_name
685 | otherwise = ic_name empty_ic
686 where
687 home_unit = hsc_home_unit hsc_env
688 old_name = ic_name old_ic
689
690 -- | If there is no -o option, guess the name of target executable
691 -- by using top-level source file name as a base.
692 guessOutputFile :: GhcMonad m => m ()
693 guessOutputFile = modifySession $ \env ->
694 let dflags = hsc_dflags env
695 platform = targetPlatform dflags
696 -- Force mod_graph to avoid leaking env
697 !mod_graph = hsc_mod_graph env
698 mainModuleSrcPath :: Maybe String
699 mainModuleSrcPath = do
700 ms <- mgLookupModule mod_graph (mainModIs env)
701 ml_hs_file (ms_location ms)
702 name = fmap dropExtension mainModuleSrcPath
703
704 !name_exe = do
705 -- we must add the .exe extension unconditionally here, otherwise
706 -- when name has an extension of its own, the .exe extension will
707 -- not be added by GHC.Driver.Pipeline.exeFileName. See #2248
708 !name' <- if platformOS platform == OSMinGW32
709 then fmap (<.> "exe") name
710 else name
711 mainModuleSrcPath' <- mainModuleSrcPath
712 -- #9930: don't clobber input files (unless they ask for it)
713 if name' == mainModuleSrcPath'
714 then throwGhcException . UsageError $
715 "default output name would overwrite the input file; " ++
716 "must specify -o explicitly"
717 else Just name'
718 in
719 case outputFile_ dflags of
720 Just _ -> env
721 Nothing -> hscSetFlags (dflags { outputFile_ = name_exe }) env
722
723 -- -----------------------------------------------------------------------------
724 --
725 -- | Prune the HomePackageTable
726 --
727 -- Before doing an upsweep, we can throw away:
728 --
729 -- - all ModDetails, all linked code
730 -- - all unlinked code that is out of date with respect to
731 -- the source file
732 --
733 -- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
734 -- space at the end of the upsweep, because the topmost ModDetails of the
735 -- old HPT holds on to the entire type environment from the previous
736 -- compilation.
737 -- Note [GHC Heap Invariants]
738 pruneCache :: [HomeModInfo]
739 -> [ModSummary]
740 -> [HomeModInfo]
741 pruneCache hpt summ
742 = strictMap prune hpt
743 where prune hmi = hmi'{ hm_details = emptyModDetails }
744 where
745 modl = moduleName (mi_module (hm_iface hmi))
746 hmi' | Just ms <- lookupUFM ms_map modl
747 , mi_src_hash (hm_iface hmi) /= ms_hs_hash ms
748 = hmi{ hm_linkable = Nothing }
749 | otherwise
750 = hmi
751
752 ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
753
754 -- ---------------------------------------------------------------------------
755 --
756 -- | Unloading
757 unload :: Interp -> HscEnv -> IO ()
758 unload interp hsc_env
759 = case ghcLink (hsc_dflags hsc_env) of
760 LinkInMemory -> Linker.unload interp hsc_env []
761 _other -> return ()
762
763
764 {- Parallel Upsweep
765
766 The parallel upsweep attempts to concurrently compile the modules in the
767 compilation graph using multiple Haskell threads.
768
769 The Algorithm
770
771 * The list of `MakeAction`s are created by `interpretBuildPlan`. A `MakeAction` is
772 a pair of an `IO a` action and a `MVar a`, where to place the result.
773 The list is sorted topologically, so can be executed in order without fear of
774 blocking.
775 * runPipelines takes this list and eventually passes it to runLoop which executes
776 each action and places the result into the right MVar.
777 * The amount of parrelism is controlled by a semaphore. This is just used around the
778 module compilation step, so that only the right number of modules are compiled at
779 the same time which reduces overal memory usage and allocations.
780 * Each proper node has a LogQueue, which dictates where to send it's output.
781 * The LogQueue is placed into the LogQueueQueue when the action starts and a worker
782 thread processes the LogQueueQueue printing logs for each module in a stable order.
783 * The result variable for an action producing `a` is of type `Maybe a`, therefore
784 it is still filled on a failure. If a module fails to compile, the
785 failure is propagated through the whole module graph and any modules which didn't
786 depend on the failure can still be compiled. This behaviour also makes the code
787 quite a bit cleaner.
788 -}
789
790
791 {-
792
793 Note [--make mode]
794 ~~~~~~~~~~~~~~~~~
795
796 There are two main parts to `--make` mode.
797
798 1. `downsweep`: Starts from the top of the module graph and computes dependencies.
799 2. `upsweep`: Starts from the bottom of the module graph and compiles modules.
800
801 The result of the downsweep is a 'ModuleGraph', which is then passed to 'upsweep' which
802 computers how to build this ModuleGraph.
803
804 Note [Upsweep]
805 ~~~~~~~~~~~~~~
806
807 Upsweep takes a 'ModuleGraph' as input, computes a build plan and then executes
808 the plan in order to compile the project.
809
810 The first step is computing the build plan from a 'ModuleGraph'.
811
812 The output of this step is a `[BuildPlan]`, which is a topologically sorted plan for
813 how to build all the modules.
814
815 ```
816 data BuildPlan = SingleModule ModuleGraphNode -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle
817 | ResolvedCycle [ModuleGraphNode] -- A resolved cycle, linearised by hs-boot files
818 | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files
819 ```
820
821 The plan is computed in two steps:
822
823 Step 1: Topologically sort the module graph without hs-boot files. This returns a [SCC ModuleGraphNode] which contains
824 cycles.
825 Step 2: For each cycle, topologically sort the modules in the cycle *with* the relevant hs-boot files. This should
826 result in an acyclic build plan if the hs-boot files are sufficient to resolve the cycle.
827
828
829 The `[BuildPlan]` is then interpreted by the `interpretBuildPlan` function.
830
831 * SingleModule nodes are compiled normally by either the upsweep_inst or upsweep_mod functions.
832 * ResolvedCycles need to compiled "together" so that the information which ends up in
833 the interface files at the end is accurate (and doesn't contain temporary information from
834 the hs-boot files.)
835 - During the initial compilation, a `KnotVars` is created which stores an IORef TypeEnv for
836 each module of the loop. These IORefs are gradually updated as the loop completes and provide
837 the required laziness to typecheck the module loop.
838 - At the end of typechecking, all the interface files are typechecked again in
839 the retypecheck loop. This time, the knot-tying is done by the normal laziness
840 based tying, so the environment is run without the KnotVars.
841 * UnresolvedCycles are indicative of a proper cycle, unresolved by hs-boot files
842 and are reported as an error to the user.
843
844 The main trickiness of `interpretBuildPlan` is deciding which version of a dependency
845 is visible from each module. For modules which are not in a cycle, there is just
846 one version of a module, so that is always used. For modules in a cycle, there are two versions of
847 'HomeModInfo'.
848
849 1. Internal to loop: The version created whilst compiling the loop by upsweep_mod.
850 2. External to loop: The knot-tied version created by typecheckLoop.
851
852 Whilst compiling a module inside the loop, we need to use the (1). For a module which
853 is outside of the loop which depends on something from in the loop, the (2) version
854 is used.
855
856 As the plan is interpreted, which version of a HomeModInfo is visible is updated
857 by updating a map held in a state monad. So after a loop has finished being compiled,
858 the visible module is the one created by typecheckLoop and the internal version is not
859 used again.
860
861 This plan also ensures the most important invariant to do with module loops:
862
863 > If you depend on anything within a module loop, before you can use the dependency,
864 the whole loop has to finish compiling.
865
866 The end result of `interpretBuildPlan` is a `[MakeAction]`, which are pairs
867 of `IO a` actions and a `MVar (Maybe a)`, somewhere to put the result of running
868 the action. This list is topologically sorted, so can be run in order to compute
869 the whole graph.
870
871 As well as this `interpretBuildPlan` also outputs an `IO [Maybe (Maybe HomeModInfo)]` which
872 can be queried at the end to get the result of all modules at the end, with their proper
873 visibility. For example, if any module in a loop fails then all modules in that loop will
874 report as failed because the visible node at the end will be the result of retypechecking
875 those modules together.
876
877 -}
878
879 -- | Simple wrapper around MVar which allows a functor instance.
880 data ResultVar b = forall a . ResultVar (a -> b) (MVar (Maybe a))
881
882 instance Functor ResultVar where
883 fmap f (ResultVar g var) = ResultVar (f . g) var
884
885 mkResultVar :: MVar (Maybe a) -> ResultVar a
886 mkResultVar = ResultVar id
887
888 -- | Block until the result is ready.
889 waitResult :: ResultVar a -> MaybeT IO a
890 waitResult (ResultVar f var) = MaybeT (fmap f <$> readMVar var)
891
892
893 data BuildLoopState = BuildLoopState { buildDep :: M.Map NodeKey (SDoc, ResultVar (Maybe HomeModInfo))
894 -- The current way to build a specific TNodeKey, without cycles this just points to
895 -- the appropiate result of compiling a module but with
896 -- cycles there can be additional indirection and can point to the result of typechecking a loop
897 , nNODE :: Int
898 , hpt_var :: MVar HomePackageTable
899 -- A global variable which is incrementally updated with the result
900 -- of compiling modules.
901 }
902
903 nodeId :: BuildM Int
904 nodeId = do
905 n <- gets nNODE
906 modify (\m -> m { nNODE = n + 1 })
907 return n
908
909 setModulePipeline :: NodeKey -> SDoc -> ResultVar (Maybe HomeModInfo) -> BuildM ()
910 setModulePipeline mgn doc wrapped_pipeline = do
911 modify (\m -> m { buildDep = M.insert mgn (doc, wrapped_pipeline) (buildDep m) })
912
913 getBuildMap :: BuildM (M.Map
914 NodeKey (SDoc, ResultVar (Maybe HomeModInfo)))
915 getBuildMap = gets buildDep
916
917 type BuildM a = StateT BuildLoopState IO a
918
919
920 -- | Abstraction over the operations of a semaphore which allows usage with the
921 -- -j1 case
922 data AbstractSem = AbstractSem { acquireSem :: IO ()
923 , releaseSem :: IO () }
924
925 withAbstractSem :: AbstractSem -> IO b -> IO b
926 withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem)
927
928 -- | Environment used when compiling a module
929 data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be augmented for each module
930 , compile_sem :: !AbstractSem
931 -- Modify the environment for module k, with the supplied logger modification function.
932 -- For -j1, this wrapper doesn't do anything
933 -- For -jn, the wrapper initialised a log queue and then modifies the logger to pipe its output
934 -- into the log queue.
935 , withLogger :: forall a . Int -> ((Logger -> Logger) -> RunMakeM a) -> RunMakeM a
936 , env_messager :: !(Maybe Messager)
937 }
938
939 type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a
940
941 -- | Given the build plan, creates a graph which indicates where each NodeKey should
942 -- get its direct dependencies from. This might not be the corresponding build action
943 -- if the module participates in a loop. This step also labels each node with a number for the output.
944 -- See Note [Upsweep] for a high-level description.
945 interpretBuildPlan :: (M.Map ModuleNameWithIsBoot HomeModInfo)
946 -> (NodeKey -> [NodeKey])
947 -> [BuildPlan]
948 -> IO ( Maybe [ModuleGraphNode] -- Is there an unresolved cycle
949 , [MakeAction] -- Actions we need to run in order to build everything
950 , IO [Maybe (Maybe HomeModInfo)]) -- An action to query to get all the built modules at the end.
951 interpretBuildPlan old_hpt deps_map plan = do
952 hpt_var <- newMVar emptyHomePackageTable
953 ((mcycle, plans), build_map) <- runStateT (buildLoop plan) (BuildLoopState M.empty 1 hpt_var)
954 return (mcycle, plans, collect_results (buildDep build_map))
955
956 where
957 collect_results build_map = mapM (\(_doc, res_var) -> runMaybeT (waitResult res_var)) (M.elems build_map)
958
959 n_mods = sum (map countMods plan)
960
961 buildLoop :: [BuildPlan]
962 -> BuildM (Maybe [ModuleGraphNode], [MakeAction])
963 -- Build the abstract pipeline which we can execute
964 -- Building finished
965 buildLoop [] = return (Nothing, [])
966 buildLoop (plan:plans) =
967 case plan of
968 -- If there was no cycle, then typecheckLoop is not necessary
969 SingleModule m -> do
970 (one_plan, _) <- buildSingleModule Nothing m
971 (cycle, all_plans) <- buildLoop plans
972 return (cycle, one_plan : all_plans)
973
974 -- For a resolved cycle, depend on everything in the loop, then update
975 -- the cache to point to this node rather than directly to the module build
976 -- nodes
977 ResolvedCycle ms -> do
978 pipes <- buildModuleLoop ms
979 (cycle, graph) <- buildLoop plans
980 return (cycle, pipes ++ graph)
981
982 -- Can't continue past this point as the cycle is unresolved.
983 UnresolvedCycle ns -> return (Just ns, [])
984
985 buildSingleModule :: Maybe (ModuleEnv (IORef TypeEnv)) -> ModuleGraphNode -> BuildM (MakeAction, ResultVar (Maybe HomeModInfo))
986 buildSingleModule knot_var mod = do
987 mod_idx <- nodeId
988 home_mod_map <- getBuildMap
989 hpt_var <- gets hpt_var
990 -- 1. Get the transitive dependencies of this module, by looking up in the dependency map
991 let direct_deps = deps_map (mkNodeKey mod)
992 doc_build_deps = catMaybes $ map (flip M.lookup home_mod_map) direct_deps
993 build_deps = map snd doc_build_deps
994 -- 2. Set the default way to build this node, not in a loop here
995 let build_action =
996 case mod of
997 InstantiationNode iu -> const Nothing <$> executeInstantiationNode mod_idx n_mods (wait_deps_hpt hpt_var build_deps) iu
998 ModuleNode ms -> do
999 let !old_hmi = M.lookup (msKey $ emsModSummary ms) old_hpt
1000 hmi <- executeCompileNode mod_idx n_mods old_hmi (wait_deps_hpt hpt_var build_deps) knot_var (emsModSummary ms)
1001 -- This global MVar is incrementally modified in order to avoid having to
1002 -- recreate the HPT before compiling each module which leads to a quadratic amount of work.
1003 liftIO $ modifyMVar_ hpt_var (\hpt -> return $! addHomeModInfoToHpt hmi hpt)
1004 return (Just hmi)
1005
1006 res_var <- liftIO newEmptyMVar
1007 let result_var = mkResultVar res_var
1008 setModulePipeline (mkNodeKey mod) (text "N") result_var
1009 return $ (MakeAction build_action res_var, result_var)
1010
1011
1012 buildModuleLoop :: [ModuleGraphNode] -> BuildM [MakeAction]
1013 buildModuleLoop ms = do
1014 let ms_mods = mapMaybe (\case InstantiationNode {} -> Nothing; ModuleNode ems -> Just (ms_mod (emsModSummary ems))) ms
1015 knot_var <- liftIO $ mkModuleEnv <$> mapM (\m -> (m,) <$> newIORef emptyNameEnv) ms_mods
1016
1017 -- 1. Build all the dependencies in this loop
1018 (build_modules, wait_modules) <- mapAndUnzipM (buildSingleModule (Just knot_var)) ms
1019 hpt_var <- gets hpt_var
1020 res_var <- liftIO newEmptyMVar
1021 let loop_action = do
1022 !hmis <- executeTypecheckLoop (readMVar hpt_var) (wait_deps wait_modules)
1023 liftIO $ modifyMVar_ hpt_var (\hpt -> return $! foldl' (flip addHomeModInfoToHpt) hpt hmis)
1024 return hmis
1025
1026
1027 let fanout i = Just . (!! i) <$> mkResultVar res_var
1028 -- From outside the module loop, anyone must wait for the loop to finish and then
1029 -- use the result of the retypechecked iface.
1030 let update_module_pipeline (m, i) = setModulePipeline (NodeKey_Module m) (text "T") (fanout i)
1031
1032 let ms_i = zip (mapMaybe (fmap (msKey . emsModSummary) . moduleGraphNodeModule) ms) [0..]
1033 mapM update_module_pipeline ms_i
1034 return $ build_modules ++ [MakeAction loop_action res_var]
1035
1036
1037
1038
1039 upsweep
1040 :: Int -- ^ The number of workers we wish to run in parallel
1041 -> HscEnv -- ^ The base HscEnv, which is augmented for each module
1042 -> Maybe Messager
1043 -> M.Map ModuleNameWithIsBoot HomeModInfo
1044 -> (NodeKey -> [NodeKey]) -- A function which computes the direct dependencies of a NodeKey
1045 -> [BuildPlan]
1046 -> IO (SuccessFlag, HscEnv, [HomeModInfo])
1047 upsweep n_jobs hsc_env mHscMessage old_hpt direct_deps build_plan = do
1048 (cycle, pipelines, collect_result) <- interpretBuildPlan old_hpt direct_deps build_plan
1049 runPipelines n_jobs hsc_env mHscMessage pipelines
1050 res <- collect_result
1051
1052 let completed = [m | Just (Just m) <- res]
1053 let hsc_env' = addDepsToHscEnv completed hsc_env
1054
1055 -- Handle any cycle in the original compilation graph and return the result
1056 -- of the upsweep.
1057 case cycle of
1058 Just mss -> do
1059 let logger = hsc_logger hsc_env
1060 liftIO $ fatalErrorMsg logger (cyclicModuleErr mss)
1061 return (Failed, hsc_env, completed)
1062 Nothing -> do
1063 let success_flag = successIf (all isJust res)
1064 return (success_flag, hsc_env', completed)
1065
1066 toCache :: [HomeModInfo] -> M.Map ModuleNameWithIsBoot HomeModInfo
1067 toCache hmis = M.fromList ([(mi_mnwib $ hm_iface hmi, hmi) | hmi <- hmis])
1068
1069 upsweep_inst :: HscEnv
1070 -> Maybe Messager
1071 -> Int -- index of module
1072 -> Int -- total number of modules
1073 -> InstantiatedUnit
1074 -> IO ()
1075 upsweep_inst hsc_env mHscMessage mod_index nmods iuid = do
1076 case mHscMessage of
1077 Just hscMessage -> hscMessage hsc_env (mod_index, nmods) MustCompile (InstantiationNode iuid)
1078 Nothing -> return ()
1079 runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ tcRnCheckUnit hsc_env $ VirtUnit iuid
1080 pure ()
1081
1082 -- | Compile a single module. Always produce a Linkable for it if
1083 -- successful. If no compilation happened, return the old Linkable.
1084 upsweep_mod :: HscEnv
1085 -> Maybe Messager
1086 -> Maybe HomeModInfo
1087 -> ModSummary
1088 -> Int -- index of module
1089 -> Int -- total number of modules
1090 -> IO HomeModInfo
1091 upsweep_mod hsc_env mHscMessage old_hmi summary mod_index nmods = do
1092 hmi <- compileOne' mHscMessage hsc_env summary
1093 mod_index nmods (hm_iface <$> old_hmi) (old_hmi >>= hm_linkable)
1094
1095 -- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module
1096 -- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I
1097 -- am unsure if this is sound (wrt running TH splices for example).
1098 -- This function only does anything if the linkable produced is a BCO, which only happens with the
1099 -- bytecode backend, no need to guard against the backend type additionally.
1100 addSptEntries (hscUpdateHPT (\hpt -> addToHpt hpt (ms_mod_name summary) hmi) hsc_env)
1101 (ms_mnwib summary)
1102 (hm_linkable hmi)
1103
1104 return hmi
1105
1106 -- | Add the entries from a BCO linkable to the SPT table, see
1107 -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
1108 addSptEntries :: HscEnv -> ModuleNameWithIsBoot -> Maybe Linkable -> IO ()
1109 addSptEntries hsc_env mnwib mlinkable =
1110 hscAddSptEntries hsc_env (Just mnwib)
1111 [ spt
1112 | Just linkable <- [mlinkable]
1113 , unlinked <- linkableUnlinked linkable
1114 , BCOs _ spts <- pure unlinked
1115 , spt <- spts
1116 ]
1117
1118 {- Note [-fno-code mode]
1119 ~~~~~~~~~~~~~~~~~~~~~~~~
1120 GHC offers the flag -fno-code for the purpose of parsing and typechecking a
1121 program without generating object files. This is intended to be used by tooling
1122 and IDEs to provide quick feedback on any parser or type errors as cheaply as
1123 possible.
1124
1125 When GHC is invoked with -fno-code no object files or linked output will be
1126 generated. As many errors and warnings as possible will be generated, as if
1127 -fno-code had not been passed. The session DynFlags will have
1128 backend == NoBackend.
1129
1130 -fwrite-interface
1131 ~~~~~~~~~~~~~~~~
1132 Whether interface files are generated in -fno-code mode is controlled by the
1133 -fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is
1134 not also passed. Recompilation avoidance requires interface files, so passing
1135 -fno-code without -fwrite-interface should be avoided. If -fno-code were
1136 re-implemented today, -fwrite-interface would be discarded and it would be
1137 considered always on; this behaviour is as it is for backwards compatibility.
1138
1139 ================================================================
1140 IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER
1141 ================================================================
1142
1143 Template Haskell
1144 ~~~~~~~~~~~~~~~~
1145 A module using template haskell may invoke an imported function from inside a
1146 splice. This will cause the type-checker to attempt to execute that code, which
1147 would fail if no object files had been generated. See #8025. To rectify this,
1148 during the downsweep we patch the DynFlags in the ModSummary of any home module
1149 that is imported by a module that uses template haskell, to generate object
1150 code.
1151
1152 The flavour of generated object code is chosen by defaultObjectTarget for the
1153 target platform. It would likely be faster to generate bytecode, but this is not
1154 supported on all platforms(?Please Confirm?), and does not support the entirety
1155 of GHC haskell. See #1257.
1156
1157 The object files (and interface files if -fwrite-interface is disabled) produced
1158 for template haskell are written to temporary files.
1159
1160 Note that since template haskell can run arbitrary IO actions, -fno-code mode
1161 is no more secure than running without it.
1162
1163 Potential TODOS:
1164 ~~~~~
1165 * Remove -fwrite-interface and have interface files always written in -fno-code
1166 mode
1167 * Both .o and .dyn_o files are generated for template haskell, but we only need
1168 .dyn_o. Fix it.
1169 * In make mode, a message like
1170 Compiling A (A.hs, /tmp/ghc_123.o)
1171 is shown if downsweep enabled object code generation for A. Perhaps we should
1172 show "nothing" or "temporary object file" instead. Note that one
1173 can currently use -keep-tmp-files and inspect the generated file with the
1174 current behaviour.
1175 * Offer a -no-codedir command line option, and write what were temporary
1176 object files there. This would speed up recompilation.
1177 * Use existing object files (if they are up to date) instead of always
1178 generating temporary ones.
1179 -}
1180
1181 -- Note [When source is considered modified]
1182 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1183 -- A number of functions in GHC.Driver accept a SourceModified argument, which
1184 -- is part of how GHC determines whether recompilation may be avoided (see the
1185 -- definition of the SourceModified data type for details).
1186 --
1187 -- Determining whether or not a source file is considered modified depends not
1188 -- only on the source file itself, but also on the output files which compiling
1189 -- that module would produce. This is done because GHC supports a number of
1190 -- flags which control which output files should be produced, e.g. -fno-code
1191 -- -fwrite-interface and -fwrite-ide-file; we must check not only whether the
1192 -- source file has been modified since the last compile, but also whether the
1193 -- source file has been modified since the last compile which produced all of
1194 -- the output files which have been requested.
1195 --
1196 -- Specifically, a source file is considered unmodified if it is up-to-date
1197 -- relative to all of the output files which have been requested. Whether or
1198 -- not an output file is up-to-date depends on what kind of file it is:
1199 --
1200 -- * iface (.hi) files are considered up-to-date if (and only if) their
1201 -- mi_src_hash field matches the hash of the source file,
1202 --
1203 -- * all other output files (.o, .dyn_o, .hie, etc) are considered up-to-date
1204 -- if (and only if) their modification times on the filesystem are greater
1205 -- than or equal to the modification time of the corresponding .hi file.
1206 --
1207 -- Why do we use '>=' rather than '>' for output files other than the .hi file?
1208 -- If the filesystem has poor resolution for timestamps (e.g. FAT32 has a
1209 -- resolution of 2 seconds), we may often find that the .hi and .o files have
1210 -- the same modification time. Using >= is slightly unsafe, but it matches
1211 -- make's behaviour.
1212 --
1213 -- This strategy allows us to do the minimum work necessary in order to ensure
1214 -- that all the files the user cares about are up-to-date; e.g. we should not
1215 -- worry about .o files if the user has indicated that they are not interested
1216 -- in them via -fno-code. See also #9243.
1217 --
1218 -- Note that recompilation avoidance is dependent on .hi files being produced,
1219 -- which does not happen if -fno-write-interface -fno-code is passed. That is,
1220 -- passing -fno-write-interface -fno-code means that you cannot benefit from
1221 -- recompilation avoidance. See also Note [-fno-code mode].
1222 --
1223 -- The correctness of this strategy depends on an assumption that whenever we
1224 -- are producing multiple output files, the .hi file is always written first.
1225 -- If this assumption is violated, we risk recompiling unnecessarily by
1226 -- incorrectly regarding non-.hi files as outdated.
1227 --
1228
1229 -- ---------------------------------------------------------------------------
1230 -- Typecheck module loops
1231 {-
1232 See bug #930. This code fixes a long-standing bug in --make. The
1233 problem is that when compiling the modules *inside* a loop, a data
1234 type that is only defined at the top of the loop looks opaque; but
1235 after the loop is done, the structure of the data type becomes
1236 apparent.
1237
1238 The difficulty is then that two different bits of code have
1239 different notions of what the data type looks like.
1240
1241 The idea is that after we compile a module which also has an .hs-boot
1242 file, we re-generate the ModDetails for each of the modules that
1243 depends on the .hs-boot file, so that everyone points to the proper
1244 TyCons, Ids etc. defined by the real module, not the boot module.
1245 Fortunately re-generating a ModDetails from a ModIface is easy: the
1246 function GHC.IfaceToCore.typecheckIface does exactly that.
1247
1248 Following this fix, GHC can compile itself with --make -O2.
1249 -}
1250
1251 typecheckLoop :: HscEnv -> [HomeModInfo] -> IO [(ModuleName, HomeModInfo)]
1252 typecheckLoop hsc_env hmis = do
1253 debugTraceMsg logger 2 $
1254 text "Re-typechecking loop: "
1255 fixIO $ \new_mods -> do
1256 let new_hpt = addListToHpt old_hpt new_mods
1257 let new_hsc_env = hscUpdateHPT (const new_hpt) hsc_env
1258 -- Crucial, crucial: initIfaceLoad clears the if_rec_types field.
1259 -- See [KnotVars invariants]
1260 -- Note [GHC Heap Invariants]
1261 mds <- initIfaceLoad new_hsc_env $
1262 mapM (typecheckIface . hm_iface) hmis
1263 let new_mods = [ (mn,hmi{ hm_details = details })
1264 | (hmi,details) <- zip hmis mds
1265 , let mn = moduleName (mi_module (hm_iface hmi)) ]
1266 return new_mods
1267
1268 where
1269 logger = hsc_logger hsc_env
1270 to_delete = (map (moduleName . mi_module . hm_iface) hmis)
1271 -- Filter out old modules before tying the knot, otherwise we can end
1272 -- up with a thunk which keeps reference to the old HomeModInfo.
1273 !old_hpt = foldl' delFromHpt (hsc_HPT hsc_env) to_delete
1274
1275 -- ---------------------------------------------------------------------------
1276 --
1277 -- | Topological sort of the module graph
1278 topSortModuleGraph
1279 :: Bool
1280 -- ^ Drop hi-boot nodes? (see below)
1281 -> ModuleGraph
1282 -> Maybe ModuleName
1283 -- ^ Root module name. If @Nothing@, use the full graph.
1284 -> [SCC ModuleGraphNode]
1285 -- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
1286 -- The resulting list of strongly-connected-components is in topologically
1287 -- sorted order, starting with the module(s) at the bottom of the
1288 -- dependency graph (ie compile them first) and ending with the ones at
1289 -- the top.
1290 --
1291 -- Drop hi-boot nodes (first boolean arg)?
1292 --
1293 -- - @False@: treat the hi-boot summaries as nodes of the graph,
1294 -- so the graph must be acyclic
1295 --
1296 -- - @True@: eliminate the hi-boot nodes, and instead pretend
1297 -- the a source-import of Foo is an import of Foo
1298 -- The resulting graph has no hi-boot nodes, but can be cyclic
1299 topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod =
1300 -- stronglyConnCompG flips the original order, so if we reverse
1301 -- the summaries we get a stable topological sort.
1302 topSortModules drop_hs_boot_nodes (reverse $ mgModSummaries' module_graph) mb_root_mod
1303
1304 topSortModules :: Bool -> [ModuleGraphNode] -> Maybe ModuleName -> [SCC ModuleGraphNode]
1305 topSortModules drop_hs_boot_nodes summaries mb_root_mod
1306 = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
1307 where
1308 (graph, lookup_node) =
1309 moduleGraphNodes drop_hs_boot_nodes summaries
1310
1311 initial_graph = case mb_root_mod of
1312 Nothing -> graph
1313 Just root_mod ->
1314 -- restrict the graph to just those modules reachable from
1315 -- the specified module. We do this by building a graph with
1316 -- the full set of nodes, and determining the reachable set from
1317 -- the specified node.
1318 let root | Just node <- lookup_node $ NodeKey_Module $ GWIB root_mod NotBoot
1319 , graph `hasVertexG` node
1320 = node
1321 | otherwise
1322 = throwGhcException (ProgramError "module does not exist")
1323 in graphFromEdgedVerticesUniq (seq root (reachableG graph root))
1324
1325 type SummaryNode = Node Int ModuleGraphNode
1326
1327 summaryNodeKey :: SummaryNode -> Int
1328 summaryNodeKey = node_key
1329
1330 summaryNodeSummary :: SummaryNode -> ModuleGraphNode
1331 summaryNodeSummary = node_payload
1332
1333 -- | Collect the immediate dependencies of a ModuleGraphNode,
1334 -- optionally avoiding hs-boot dependencies.
1335 -- If the drop_hs_boot_nodes flag is False, and if this is a .hs and there is
1336 -- an equivalent .hs-boot, add a link from the former to the latter. This
1337 -- has the effect of detecting bogus cases where the .hs-boot depends on the
1338 -- .hs, by introducing a cycle. Additionally, it ensures that we will always
1339 -- process the .hs-boot before the .hs, and so the HomePackageTable will always
1340 -- have the most up to date information.
1341 unfilteredEdges :: Bool -> ModuleGraphNode -> [NodeKey]
1342 unfilteredEdges drop_hs_boot_nodes = \case
1343 InstantiationNode iuid ->
1344 NodeKey_Module . flip GWIB NotBoot <$> uniqDSetToList (instUnitHoles iuid)
1345 ModuleNode (ExtendedModSummary ms bds) ->
1346 [ NodeKey_Unit inst_unit | inst_unit <- bds ] ++
1347 (NodeKey_Module . flip GWIB hs_boot_key . unLoc <$> ms_home_srcimps ms) ++
1348 [ NodeKey_Module $ GWIB (ms_mod_name ms) IsBoot
1349 | not $ drop_hs_boot_nodes || ms_hsc_src ms == HsBootFile
1350 ] ++
1351 (NodeKey_Module . flip GWIB NotBoot . unLoc <$> ms_home_imps ms)
1352 where
1353 -- Drop hs-boot nodes by using HsSrcFile as the key
1354 hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature
1355 | otherwise = IsBoot
1356
1357 moduleGraphNodes :: Bool -> [ModuleGraphNode]
1358 -> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
1359 moduleGraphNodes drop_hs_boot_nodes summaries =
1360 (graphFromEdgedVerticesUniq nodes, lookup_node)
1361 where
1362 numbered_summaries = zip summaries [1..]
1363
1364 lookup_node :: NodeKey -> Maybe SummaryNode
1365 lookup_node key = Map.lookup key (unNodeMap node_map)
1366
1367 lookup_key :: NodeKey -> Maybe Int
1368 lookup_key = fmap summaryNodeKey . lookup_node
1369
1370 node_map :: NodeMap SummaryNode
1371 node_map = NodeMap $
1372 Map.fromList [ (mkNodeKey s, node)
1373 | node <- nodes
1374 , let s = summaryNodeSummary node
1375 ]
1376
1377 -- We use integers as the keys for the SCC algorithm
1378 nodes :: [SummaryNode]
1379 nodes = [ DigraphNode s key $ out_edge_keys $ unfilteredEdges drop_hs_boot_nodes s
1380 | (s, key) <- numbered_summaries
1381 -- Drop the hi-boot ones if told to do so
1382 , case s of
1383 InstantiationNode _ -> True
1384 ModuleNode ems -> not $ isBootSummary (emsModSummary ems) == IsBoot && drop_hs_boot_nodes
1385 ]
1386
1387 out_edge_keys :: [NodeKey] -> [Int]
1388 out_edge_keys = mapMaybe lookup_key
1389 -- If we want keep_hi_boot_nodes, then we do lookup_key with
1390 -- IsBoot; else False
1391
1392 -- The nodes of the graph are keyed by (mod, is boot?) pairs for the current
1393 -- modules, and indefinite unit IDs for dependencies which are instantiated with
1394 -- our holes.
1395 --
1396 -- NB: hsig files show up as *normal* nodes (not boot!), since they don't
1397 -- participate in cycles (for now)
1398 type ModNodeKey = ModuleNameWithIsBoot
1399 newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a }
1400 deriving (Functor, Traversable, Foldable)
1401
1402 emptyModNodeMap :: ModNodeMap a
1403 emptyModNodeMap = ModNodeMap Map.empty
1404
1405 modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a
1406 modNodeMapInsert k v (ModNodeMap m) = ModNodeMap (Map.insert k v m)
1407
1408 modNodeMapElems :: ModNodeMap a -> [a]
1409 modNodeMapElems (ModNodeMap m) = Map.elems m
1410
1411 modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a
1412 modNodeMapLookup k (ModNodeMap m) = Map.lookup k m
1413
1414 data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit | NodeKey_Module {-# UNPACK #-} !ModNodeKey
1415 deriving (Eq, Ord)
1416
1417 instance Outputable NodeKey where
1418 ppr nk = pprNodeKey nk
1419
1420 newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a }
1421 deriving (Functor, Traversable, Foldable)
1422
1423 mkNodeKey :: ModuleGraphNode -> NodeKey
1424 mkNodeKey = \case
1425 InstantiationNode x -> NodeKey_Unit x
1426 ModuleNode x -> NodeKey_Module $ mkHomeBuildModule0 (emsModSummary x)
1427
1428 mkHomeBuildModule0 :: ModSummary -> ModuleNameWithIsBoot
1429 mkHomeBuildModule0 ms = GWIB
1430 { gwib_mod = moduleName $ ms_mod ms
1431 , gwib_isBoot = isBootSummary ms
1432 }
1433
1434 msKey :: ModSummary -> ModuleNameWithIsBoot
1435 msKey = mkHomeBuildModule0
1436
1437 pprNodeKey :: NodeKey -> SDoc
1438 pprNodeKey (NodeKey_Unit iu) = ppr iu
1439 pprNodeKey (NodeKey_Module mk) = ppr mk
1440
1441 mkNodeMap :: [ExtendedModSummary] -> ModNodeMap ExtendedModSummary
1442 mkNodeMap summaries = ModNodeMap $ Map.fromList
1443 [ (mkHomeBuildModule0 $ emsModSummary s, s) | s <- summaries]
1444
1445 -- | Efficiently construct a map from a NodeKey to its list of transitive dependencies
1446 mkDepsMap :: [ModuleGraphNode] -> (NodeKey -> [NodeKey])
1447 mkDepsMap nodes =
1448 -- Important that we force this before returning a lambda so we can share the module graph
1449 -- for each node
1450 let !(mg, lookup_node) = moduleGraphNodes False nodes
1451 in \nk -> map (mkNodeKey . node_payload) $ outgoingG mg (expectJust "mkDepsMap" (lookup_node nk))
1452
1453 -- | If there are {-# SOURCE #-} imports between strongly connected
1454 -- components in the topological sort, then those imports can
1455 -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
1456 -- were necessary, then the edge would be part of a cycle.
1457 warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
1458 warnUnnecessarySourceImports sccs = do
1459 diag_opts <- initDiagOpts <$> getDynFlags
1460 when (diag_wopt Opt_WarnUnusedImports diag_opts) $ do
1461 let check ms =
1462 let mods_in_this_cycle = map ms_mod_name ms in
1463 [ warn i | m <- ms, i <- ms_home_srcimps m,
1464 unLoc i `notElem` mods_in_this_cycle ]
1465
1466 warn :: Located ModuleName -> MsgEnvelope GhcMessage
1467 warn (L loc mod) = GhcDriverMessage <$> mkPlainMsgEnvelope diag_opts
1468 loc (DriverUnnecessarySourceImports mod)
1469 logDiagnostics (mkMessages $ listToBag (concatMap (check . flattenSCC) sccs))
1470
1471
1472 -----------------------------------------------------------------------------
1473 --
1474 -- | Downsweep (dependency analysis)
1475 --
1476 -- Chase downwards from the specified root set, returning summaries
1477 -- for all home modules encountered. Only follow source-import
1478 -- links.
1479 --
1480 -- We pass in the previous collection of summaries, which is used as a
1481 -- cache to avoid recalculating a module summary if the source is
1482 -- unchanged.
1483 --
1484 -- The returned list of [ModSummary] nodes has one node for each home-package
1485 -- module, plus one for any hs-boot files. The imports of these nodes
1486 -- are all there, including the imports of non-home-package modules.
1487 downsweep :: HscEnv
1488 -> [ExtendedModSummary]
1489 -- ^ Old summaries
1490 -> [ModuleName] -- Ignore dependencies on these; treat
1491 -- them as if they were package modules
1492 -> Bool -- True <=> allow multiple targets to have
1493 -- the same module name; this is
1494 -- very useful for ghc -M
1495 -> IO [Either DriverMessages ExtendedModSummary]
1496 -- The non-error elements of the returned list all have distinct
1497 -- (Modules, IsBoot) identifiers, unless the Bool is true in
1498 -- which case there can be repeats
1499 downsweep hsc_env old_summaries excl_mods allow_dup_roots
1500 = do
1501 rootSummaries <- mapM getRootSummary roots
1502 let (errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549
1503 root_map = mkRootMap rootSummariesOk
1504 checkDuplicates root_map
1505 map0 <- loop (concatMap calcDeps rootSummariesOk) root_map
1506 -- if we have been passed -fno-code, we enable code generation
1507 -- for dependencies of modules that have -XTemplateHaskell,
1508 -- otherwise those modules will fail to compile.
1509 -- See Note [-fno-code mode] #8025
1510 let default_backend = platformDefaultBackend (targetPlatform dflags)
1511 let home_unit = hsc_home_unit hsc_env
1512 let tmpfs = hsc_tmpfs hsc_env
1513 map1 <- case backend dflags of
1514 NoBackend -> enableCodeGenForTH logger tmpfs home_unit default_backend map0
1515 _ -> return map0
1516 if null errs
1517 then pure $ concat $ modNodeMapElems map1
1518 else pure $ map Left errs
1519 where
1520 -- TODO(@Ericson2314): Probably want to include backpack instantiations
1521 -- in the map eventually for uniformity
1522 calcDeps (ExtendedModSummary ms _bkp_deps) = msDeps ms
1523
1524 dflags = hsc_dflags hsc_env
1525 logger = hsc_logger hsc_env
1526 roots = hsc_targets hsc_env
1527
1528 old_summary_map :: ModNodeMap ExtendedModSummary
1529 old_summary_map = mkNodeMap old_summaries
1530
1531 getRootSummary :: Target -> IO (Either DriverMessages ExtendedModSummary)
1532 getRootSummary Target { targetId = TargetFile file mb_phase
1533 , targetContents = maybe_buf
1534 }
1535 = do exists <- liftIO $ doesFileExist file
1536 if exists || isJust maybe_buf
1537 then summariseFile hsc_env old_summaries file mb_phase
1538 maybe_buf
1539 else return $ Left $ singleMessage
1540 $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound file)
1541 getRootSummary Target { targetId = TargetModule modl
1542 , targetContents = maybe_buf
1543 }
1544 = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot
1545 (L rootLoc modl)
1546 maybe_buf excl_mods
1547 case maybe_summary of
1548 Nothing -> return $ Left $ moduleNotFoundErr modl
1549 Just s -> return s
1550
1551 rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
1552
1553 -- In a root module, the filename is allowed to diverge from the module
1554 -- name, so we have to check that there aren't multiple root files
1555 -- defining the same module (otherwise the duplicates will be silently
1556 -- ignored, leading to confusing behaviour).
1557 checkDuplicates
1558 :: ModNodeMap
1559 [Either DriverMessages
1560 ExtendedModSummary]
1561 -> IO ()
1562 checkDuplicates root_map
1563 | allow_dup_roots = return ()
1564 | null dup_roots = return ()
1565 | otherwise = liftIO $ multiRootsErr (emsModSummary <$> head dup_roots)
1566 where
1567 dup_roots :: [[ExtendedModSummary]] -- Each at least of length 2
1568 dup_roots = filterOut isSingleton $ map rights $ modNodeMapElems root_map
1569
1570 loop :: [GenWithIsBoot (Located ModuleName)]
1571 -- Work list: process these modules
1572 -> ModNodeMap [Either DriverMessages ExtendedModSummary]
1573 -- Visited set; the range is a list because
1574 -- the roots can have the same module names
1575 -- if allow_dup_roots is True
1576 -> IO (ModNodeMap [Either DriverMessages ExtendedModSummary])
1577 -- The result is the completed NodeMap
1578 loop [] done = return done
1579 loop (s : ss) done
1580 | Just summs <- modNodeMapLookup key done
1581 = if isSingleton summs then
1582 loop ss done
1583 else
1584 do { multiRootsErr (emsModSummary <$> rights summs)
1585 ; return (ModNodeMap Map.empty)
1586 }
1587 | otherwise
1588 = do mb_s <- summariseModule hsc_env old_summary_map
1589 is_boot wanted_mod
1590 Nothing excl_mods
1591 case mb_s of
1592 Nothing -> loop ss done
1593 Just (Left e) -> loop ss (modNodeMapInsert key [Left e] done)
1594 Just (Right s)-> do
1595 new_map <-
1596 loop (calcDeps s) (modNodeMapInsert key [Right s] done)
1597 loop ss new_map
1598 where
1599 GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = s
1600 wanted_mod = L loc mod
1601 key = GWIB
1602 { gwib_mod = unLoc wanted_mod
1603 , gwib_isBoot = is_boot
1604 }
1605
1606 -- | Update the every ModSummary that is depended on
1607 -- by a module that needs template haskell. We enable codegen to
1608 -- the specified target, disable optimization and change the .hi
1609 -- and .o file locations to be temporary files.
1610 -- See Note [-fno-code mode]
1611 enableCodeGenForTH
1612 :: Logger
1613 -> TmpFs
1614 -> HomeUnit
1615 -> Backend
1616 -> ModNodeMap [Either DriverMessages ExtendedModSummary]
1617 -> IO (ModNodeMap [Either DriverMessages ExtendedModSummary])
1618 enableCodeGenForTH logger tmpfs home_unit =
1619 enableCodeGenWhen logger tmpfs condition should_modify TFL_CurrentModule TFL_GhcSession
1620 where
1621 condition = isTemplateHaskellOrQQNonBoot
1622 should_modify (ModSummary { ms_hspp_opts = dflags }) =
1623 backend dflags == NoBackend &&
1624 -- Don't enable codegen for TH on indefinite packages; we
1625 -- can't compile anything anyway! See #16219.
1626 isHomeUnitDefinite home_unit
1627
1628 -- | Helper used to implement 'enableCodeGenForTH'.
1629 -- In particular, this enables
1630 -- unoptimized code generation for all modules that meet some
1631 -- condition (first parameter), or are dependencies of those
1632 -- modules. The second parameter is a condition to check before
1633 -- marking modules for code generation.
1634 enableCodeGenWhen
1635 :: Logger
1636 -> TmpFs
1637 -> (ModSummary -> Bool)
1638 -> (ModSummary -> Bool)
1639 -> TempFileLifetime
1640 -> TempFileLifetime
1641 -> Backend
1642 -> ModNodeMap [Either DriverMessages ExtendedModSummary]
1643 -> IO (ModNodeMap [Either DriverMessages ExtendedModSummary])
1644 enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife bcknd nodemap =
1645 traverse (traverse (traverse enable_code_gen)) nodemap
1646 where
1647 enable_code_gen :: ExtendedModSummary -> IO ExtendedModSummary
1648 enable_code_gen (ExtendedModSummary ms bkp_deps)
1649 | ModSummary
1650 { ms_mod = ms_mod
1651 , ms_location = ms_location
1652 , ms_hsc_src = HsSrcFile
1653 , ms_hspp_opts = dflags
1654 } <- ms
1655 , should_modify ms
1656 , ms_mod `Set.member` needs_codegen_set
1657 = do
1658 let new_temp_file suf dynsuf = do
1659 tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf
1660 let dyn_tn = tn -<.> dynsuf
1661 addFilesToClean tmpfs dynLife [dyn_tn]
1662 return (tn, dyn_tn)
1663 -- We don't want to create .o or .hi files unless we have been asked
1664 -- to by the user. But we need them, so we patch their locations in
1665 -- the ModSummary with temporary files.
1666 --
1667 ((hi_file, dyn_hi_file), (o_file, dyn_o_file)) <-
1668 -- If ``-fwrite-interface` is specified, then the .o and .hi files
1669 -- are written into `-odir` and `-hidir` respectively. #16670
1670 if gopt Opt_WriteInterface dflags
1671 then return ((ml_hi_file ms_location, ml_dyn_hi_file ms_location)
1672 , (ml_obj_file ms_location, ml_dyn_obj_file ms_location))
1673 else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))
1674 <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))
1675 let ms' = ms
1676 { ms_location =
1677 ms_location { ml_hi_file = hi_file
1678 , ml_obj_file = o_file
1679 , ml_dyn_hi_file = dyn_hi_file
1680 , ml_dyn_obj_file = dyn_o_file }
1681 , ms_hspp_opts = updOptLevel 0 $ dflags {backend = bcknd}
1682 }
1683 pure (ExtendedModSummary ms' bkp_deps)
1684 | otherwise = return (ExtendedModSummary ms bkp_deps)
1685
1686 needs_codegen_set = transitive_deps_set
1687 [ ms
1688 | mss <- modNodeMapElems nodemap
1689 , Right (ExtendedModSummary { emsModSummary = ms }) <- mss
1690 , condition ms
1691 ]
1692
1693 -- find the set of all transitive dependencies of a list of modules.
1694 transitive_deps_set :: [ModSummary] -> Set.Set Module
1695 transitive_deps_set modSums = foldl' go Set.empty modSums
1696 where
1697 go marked_mods ms@ModSummary{ms_mod}
1698 | ms_mod `Set.member` marked_mods = marked_mods
1699 | otherwise =
1700 let deps =
1701 [ dep_ms
1702 -- If a module imports a boot module, msDeps helpfully adds a
1703 -- dependency to that non-boot module in it's result. This
1704 -- means we don't have to think about boot modules here.
1705 | dep <- msDeps ms
1706 , NotBoot == gwib_isBoot dep
1707 , dep_ms_0 <- toList $ modNodeMapLookup (unLoc <$> dep) nodemap
1708 , dep_ms_1 <- toList $ dep_ms_0
1709 , (ExtendedModSummary { emsModSummary = dep_ms }) <- toList $ dep_ms_1
1710 ]
1711 new_marked_mods = Set.insert ms_mod marked_mods
1712 in foldl' go new_marked_mods deps
1713
1714 mkRootMap
1715 :: [ExtendedModSummary]
1716 -> ModNodeMap [Either DriverMessages ExtendedModSummary]
1717 mkRootMap summaries = ModNodeMap $ Map.insertListWith
1718 (flip (++))
1719 [ (msKey $ emsModSummary s, [Right s]) | s <- summaries ]
1720 Map.empty
1721
1722 -- | Returns the dependencies of the ModSummary s.
1723 -- A wrinkle is that for a {-# SOURCE #-} import we return
1724 -- *both* the hs-boot file
1725 -- *and* the source file
1726 -- as "dependencies". That ensures that the list of all relevant
1727 -- modules always contains B.hs if it contains B.hs-boot.
1728 -- Remember, this pass isn't doing the topological sort. It's
1729 -- just gathering the list of all relevant ModSummaries
1730 msDeps :: ModSummary -> [GenWithIsBoot (Located ModuleName)]
1731 msDeps s = [ d
1732 | m <- ms_home_srcimps s
1733 , d <- [ GWIB { gwib_mod = m, gwib_isBoot = IsBoot }
1734 , GWIB { gwib_mod = m, gwib_isBoot = NotBoot }
1735 ]
1736 ]
1737 ++ [ GWIB { gwib_mod = m, gwib_isBoot = NotBoot }
1738 | m <- ms_home_imps s
1739 ]
1740
1741 -----------------------------------------------------------------------------
1742 -- Summarising modules
1743
1744 -- We have two types of summarisation:
1745 --
1746 -- * Summarise a file. This is used for the root module(s) passed to
1747 -- cmLoadModules. The file is read, and used to determine the root
1748 -- module name. The module name may differ from the filename.
1749 --
1750 -- * Summarise a module. We are given a module name, and must provide
1751 -- a summary. The finder is used to locate the file in which the module
1752 -- resides.
1753
1754 summariseFile
1755 :: HscEnv
1756 -> [ExtendedModSummary] -- old summaries
1757 -> FilePath -- source file name
1758 -> Maybe Phase -- start phase
1759 -> Maybe (StringBuffer,UTCTime)
1760 -> IO (Either DriverMessages ExtendedModSummary)
1761
1762 summariseFile hsc_env old_summaries src_fn mb_phase maybe_buf
1763 -- we can use a cached summary if one is available and the
1764 -- source file hasn't changed, But we have to look up the summary
1765 -- by source file, rather than module name as we do in summarise.
1766 | Just old_summary <- findSummaryBySourceFile old_summaries src_fn
1767 = do
1768 let location = ms_location $ emsModSummary old_summary
1769
1770 src_hash <- get_src_hash
1771 -- The file exists; we checked in getRootSummary above.
1772 -- If it gets removed subsequently, then this
1773 -- getFileHash may fail, but that's the right
1774 -- behaviour.
1775
1776 -- return the cached summary if the source didn't change
1777 checkSummaryHash
1778 hsc_env (new_summary src_fn)
1779 old_summary location src_hash
1780
1781 | otherwise
1782 = do src_hash <- get_src_hash
1783 new_summary src_fn src_hash
1784 where
1785 -- src_fn does not necessarily exist on the filesystem, so we need to
1786 -- check what kind of target we are dealing with
1787 get_src_hash = case maybe_buf of
1788 Just (buf,_) -> return $ fingerprintStringBuffer buf
1789 Nothing -> liftIO $ getFileHash src_fn
1790
1791 new_summary src_fn src_hash = runExceptT $ do
1792 preimps@PreprocessedImports {..}
1793 <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf
1794
1795 let fopts = initFinderOpts (hsc_dflags hsc_env)
1796
1797 -- Make a ModLocation for this file
1798 let location = mkHomeModLocation fopts pi_mod_name src_fn
1799
1800 -- Tell the Finder cache where it is, so that subsequent calls
1801 -- to findModule will find it, even if it's not on any search path
1802 mod <- liftIO $ do
1803 let home_unit = hsc_home_unit hsc_env
1804 let fc = hsc_FC hsc_env
1805 addHomeModuleToFinder fc home_unit pi_mod_name location
1806
1807 liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
1808 { nms_src_fn = src_fn
1809 , nms_src_hash = src_hash
1810 , nms_is_boot = NotBoot
1811 , nms_hsc_src =
1812 if isHaskellSigFilename src_fn
1813 then HsigFile
1814 else HsSrcFile
1815 , nms_location = location
1816 , nms_mod = mod
1817 , nms_preimps = preimps
1818 }
1819
1820 findSummaryBySourceFile :: [ExtendedModSummary] -> FilePath -> Maybe ExtendedModSummary
1821 findSummaryBySourceFile summaries file = case
1822 [ ms
1823 | ms <- summaries
1824 , HsSrcFile <- [ms_hsc_src $ emsModSummary ms]
1825 , let derived_file = ml_hs_file $ ms_location $ emsModSummary ms
1826 , expectJust "findSummaryBySourceFile" derived_file == file
1827 ]
1828 of
1829 [] -> Nothing
1830 (x:_) -> Just x
1831
1832 checkSummaryHash
1833 :: HscEnv
1834 -> (Fingerprint -> IO (Either e ExtendedModSummary))
1835 -> ExtendedModSummary -> ModLocation -> Fingerprint
1836 -> IO (Either e ExtendedModSummary)
1837 checkSummaryHash
1838 hsc_env new_summary
1839 (ExtendedModSummary { emsModSummary = old_summary, emsInstantiatedUnits = bkp_deps})
1840 location src_hash
1841 | ms_hs_hash old_summary == src_hash &&
1842 not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do
1843 -- update the object-file timestamp
1844 obj_timestamp <- modificationTimeIfExists (ml_obj_file location)
1845
1846 -- We have to repopulate the Finder's cache for file targets
1847 -- because the file might not even be on the regular search path
1848 -- and it was likely flushed in depanal. This is not technically
1849 -- needed when we're called from sumariseModule but it shouldn't
1850 -- hurt.
1851 _ <- do
1852 let home_unit = hsc_home_unit hsc_env
1853 let fc = hsc_FC hsc_env
1854 addHomeModuleToFinder fc home_unit
1855 (moduleName (ms_mod old_summary)) location
1856
1857 hi_timestamp <- modificationTimeIfExists (ml_hi_file location)
1858 hie_timestamp <- modificationTimeIfExists (ml_hie_file location)
1859
1860 return $ Right
1861 ( ExtendedModSummary { emsModSummary = old_summary
1862 { ms_obj_date = obj_timestamp
1863 , ms_iface_date = hi_timestamp
1864 , ms_hie_date = hie_timestamp
1865 }
1866 , emsInstantiatedUnits = bkp_deps
1867 }
1868 )
1869
1870 | otherwise =
1871 -- source changed: re-summarise.
1872 new_summary src_hash
1873
1874 -- Summarise a module, and pick up source and timestamp.
1875 summariseModule
1876 :: HscEnv
1877 -> ModNodeMap ExtendedModSummary
1878 -- ^ Map of old summaries
1879 -> IsBootInterface -- True <=> a {-# SOURCE #-} import
1880 -> Located ModuleName -- Imported module to be summarised
1881 -> Maybe (StringBuffer, UTCTime)
1882 -> [ModuleName] -- Modules to exclude
1883 -> IO (Maybe (Either DriverMessages ExtendedModSummary)) -- Its new summary
1884
1885 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
1886 maybe_buf excl_mods
1887 | wanted_mod `elem` excl_mods
1888 = return Nothing
1889
1890 | Just old_summary <- modNodeMapLookup
1891 (GWIB { gwib_mod = wanted_mod, gwib_isBoot = is_boot })
1892 old_summary_map
1893 = do -- Find its new timestamp; all the
1894 -- ModSummaries in the old map have valid ml_hs_files
1895 let location = ms_location $ emsModSummary old_summary
1896 src_fn = expectJust "summariseModule" (ml_hs_file location)
1897
1898 -- check the hash on the source file, and
1899 -- return the cached summary if it hasn't changed. If the
1900 -- file has disappeared, we need to call the Finder again.
1901 case maybe_buf of
1902 Just (buf,_) ->
1903 Just <$> check_hash old_summary location src_fn (fingerprintStringBuffer buf)
1904 Nothing -> do
1905 mb_hash <- fileHashIfExists src_fn
1906 case mb_hash of
1907 Just hash -> Just <$> check_hash old_summary location src_fn hash
1908 Nothing -> find_it
1909
1910 | otherwise = find_it
1911 where
1912 dflags = hsc_dflags hsc_env
1913 fopts = initFinderOpts dflags
1914 home_unit = hsc_home_unit hsc_env
1915 fc = hsc_FC hsc_env
1916 units = hsc_units hsc_env
1917
1918 check_hash old_summary location src_fn =
1919 checkSummaryHash
1920 hsc_env
1921 (new_summary location (ms_mod $ emsModSummary old_summary) src_fn)
1922 old_summary location
1923
1924 find_it = do
1925 found <- findImportedModule fc fopts units home_unit wanted_mod NoPkgQual
1926 case found of
1927 Found location mod
1928 | isJust (ml_hs_file location) ->
1929 -- Home package
1930 Just <$> just_found location mod
1931
1932 _ -> return Nothing
1933 -- Not found
1934 -- (If it is TRULY not found at all, we'll
1935 -- error when we actually try to compile)
1936
1937 just_found location mod = do
1938 -- Adjust location to point to the hs-boot source file,
1939 -- hi file, object file, when is_boot says so
1940 let location' = case is_boot of
1941 IsBoot -> addBootSuffixLocn location
1942 NotBoot -> location
1943 src_fn = expectJust "summarise2" (ml_hs_file location')
1944
1945 -- Check that it exists
1946 -- It might have been deleted since the Finder last found it
1947 maybe_h <- fileHashIfExists src_fn
1948 case maybe_h of
1949 Nothing -> return $ Left $ noHsFileErr loc src_fn
1950 Just h -> new_summary location' mod src_fn h
1951
1952 new_summary location mod src_fn src_hash
1953 = runExceptT $ do
1954 preimps@PreprocessedImports {..}
1955 <- getPreprocessedImports hsc_env src_fn Nothing maybe_buf
1956
1957 -- NB: Despite the fact that is_boot is a top-level parameter, we
1958 -- don't actually know coming into this function what the HscSource
1959 -- of the module in question is. This is because we may be processing
1960 -- this module because another module in the graph imported it: in this
1961 -- case, we know if it's a boot or not because of the {-# SOURCE #-}
1962 -- annotation, but we don't know if it's a signature or a regular
1963 -- module until we actually look it up on the filesystem.
1964 let hsc_src
1965 | is_boot == IsBoot = HsBootFile
1966 | isHaskellSigFilename src_fn = HsigFile
1967 | otherwise = HsSrcFile
1968
1969 when (pi_mod_name /= wanted_mod) $
1970 throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc
1971 $ DriverFileModuleNameMismatch pi_mod_name wanted_mod
1972
1973 when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (homeUnitInstantiations home_unit))) $
1974 let instantiations = homeUnitInstantiations home_unit
1975 in throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc
1976 $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations
1977
1978 liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
1979 { nms_src_fn = src_fn
1980 , nms_src_hash = src_hash
1981 , nms_is_boot = is_boot
1982 , nms_hsc_src = hsc_src
1983 , nms_location = location
1984 , nms_mod = mod
1985 , nms_preimps = preimps
1986 }
1987
1988 -- | Convenience named arguments for 'makeNewModSummary' only used to make
1989 -- code more readable, not exported.
1990 data MakeNewModSummary
1991 = MakeNewModSummary
1992 { nms_src_fn :: FilePath
1993 , nms_src_hash :: Fingerprint
1994 , nms_is_boot :: IsBootInterface
1995 , nms_hsc_src :: HscSource
1996 , nms_location :: ModLocation
1997 , nms_mod :: Module
1998 , nms_preimps :: PreprocessedImports
1999 }
2000
2001 makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ExtendedModSummary
2002 makeNewModSummary hsc_env MakeNewModSummary{..} = do
2003 let PreprocessedImports{..} = nms_preimps
2004 obj_timestamp <- modificationTimeIfExists (ml_obj_file nms_location)
2005 dyn_obj_timestamp <- modificationTimeIfExists (ml_dyn_obj_file nms_location)
2006 hi_timestamp <- modificationTimeIfExists (ml_hi_file nms_location)
2007 hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)
2008
2009 extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name
2010 (implicit_sigs, inst_deps) <- implicitRequirementsShallow hsc_env pi_theimps
2011
2012 return $ ExtendedModSummary
2013 { emsModSummary =
2014 ModSummary
2015 { ms_mod = nms_mod
2016 , ms_hsc_src = nms_hsc_src
2017 , ms_location = nms_location
2018 , ms_hspp_file = pi_hspp_fn
2019 , ms_hspp_opts = pi_local_dflags
2020 , ms_hspp_buf = Just pi_hspp_buf
2021 , ms_parsed_mod = Nothing
2022 , ms_srcimps = pi_srcimps
2023 , ms_ghc_prim_import = pi_ghc_prim_import
2024 , ms_textual_imps =
2025 ((,) NoPkgQual . noLoc <$> extra_sig_imports) ++
2026 ((,) NoPkgQual . noLoc <$> implicit_sigs) ++
2027 pi_theimps
2028 , ms_hs_hash = nms_src_hash
2029 , ms_iface_date = hi_timestamp
2030 , ms_hie_date = hie_timestamp
2031 , ms_obj_date = obj_timestamp
2032 , ms_dyn_obj_date = dyn_obj_timestamp
2033 }
2034 , emsInstantiatedUnits = inst_deps
2035 }
2036
2037 data PreprocessedImports
2038 = PreprocessedImports
2039 { pi_local_dflags :: DynFlags
2040 , pi_srcimps :: [(PkgQual, Located ModuleName)]
2041 , pi_theimps :: [(PkgQual, Located ModuleName)]
2042 , pi_ghc_prim_import :: Bool
2043 , pi_hspp_fn :: FilePath
2044 , pi_hspp_buf :: StringBuffer
2045 , pi_mod_name_loc :: SrcSpan
2046 , pi_mod_name :: ModuleName
2047 }
2048
2049 -- Preprocess the source file and get its imports
2050 -- The pi_local_dflags contains the OPTIONS pragmas
2051 getPreprocessedImports
2052 :: HscEnv
2053 -> FilePath
2054 -> Maybe Phase
2055 -> Maybe (StringBuffer, UTCTime)
2056 -- ^ optional source code buffer and modification time
2057 -> ExceptT DriverMessages IO PreprocessedImports
2058 getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
2059 (pi_local_dflags, pi_hspp_fn)
2060 <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase
2061 pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn
2062 (pi_srcimps', pi_theimps', pi_ghc_prim_import, L pi_mod_name_loc pi_mod_name)
2063 <- ExceptT $ do
2064 let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags
2065 popts = initParserOpts pi_local_dflags
2066 mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn
2067 return (first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps)
2068 let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
2069 let rn_imps = fmap (first rn_pkg_qual)
2070 let pi_srcimps = rn_imps pi_srcimps'
2071 let pi_theimps = rn_imps pi_theimps'
2072 return PreprocessedImports {..}
2073
2074
2075 -----------------------------------------------------------------------------
2076 -- Error messages
2077 -----------------------------------------------------------------------------
2078
2079 -- Defer and group warning, error and fatal messages so they will not get lost
2080 -- in the regular output.
2081 withDeferredDiagnostics :: GhcMonad m => m a -> m a
2082 withDeferredDiagnostics f = do
2083 dflags <- getDynFlags
2084 if not $ gopt Opt_DeferDiagnostics dflags
2085 then f
2086 else do
2087 warnings <- liftIO $ newIORef []
2088 errors <- liftIO $ newIORef []
2089 fatals <- liftIO $ newIORef []
2090 logger <- getLogger
2091
2092 let deferDiagnostics _dflags !msgClass !srcSpan !msg = do
2093 let action = logMsg logger msgClass srcSpan msg
2094 case msgClass of
2095 MCDiagnostic SevWarning _reason
2096 -> atomicModifyIORef' warnings $ \i -> (action: i, ())
2097 MCDiagnostic SevError _reason
2098 -> atomicModifyIORef' errors $ \i -> (action: i, ())
2099 MCFatal
2100 -> atomicModifyIORef' fatals $ \i -> (action: i, ())
2101 _ -> action
2102
2103 printDeferredDiagnostics = liftIO $
2104 forM_ [warnings, errors, fatals] $ \ref -> do
2105 -- This IORef can leak when the dflags leaks, so let us always
2106 -- reset the content.
2107 actions <- atomicModifyIORef' ref $ \i -> ([], i)
2108 sequence_ $ reverse actions
2109
2110 MC.bracket
2111 (pushLogHookM (const deferDiagnostics))
2112 (\_ -> popLogHookM >> printDeferredDiagnostics)
2113 (\_ -> f)
2114
2115 noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage
2116 -- ToDo: we don't have a proper line number for this error
2117 noModError hsc_env loc wanted_mod err
2118 = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $
2119 cannotFindModule hsc_env wanted_mod err
2120
2121 noHsFileErr :: SrcSpan -> String -> DriverMessages
2122 noHsFileErr loc path
2123 = singleMessage $ mkPlainErrorMsgEnvelope loc (DriverFileNotFound path)
2124
2125 moduleNotFoundErr :: ModuleName -> DriverMessages
2126 moduleNotFoundErr mod
2127 = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound mod)
2128
2129 multiRootsErr :: [ModSummary] -> IO ()
2130 multiRootsErr [] = panic "multiRootsErr"
2131 multiRootsErr summs@(summ1:_)
2132 = throwOneError $ fmap GhcDriverMessage $
2133 mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files
2134 where
2135 mod = ms_mod summ1
2136 files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
2137
2138 cyclicModuleErr :: [ModuleGraphNode] -> SDoc
2139 -- From a strongly connected component we find
2140 -- a single cycle to report
2141 cyclicModuleErr mss
2142 = assert (not (null mss)) $
2143 case findCycle graph of
2144 Nothing -> text "Unexpected non-cycle" <+> ppr mss
2145 Just path0 -> vcat
2146 [ case partitionNodes path0 of
2147 ([],_) -> text "Module imports form a cycle:"
2148 (_,[]) -> text "Module instantiations form a cycle:"
2149 _ -> text "Module imports and instantiations form a cycle:"
2150 , nest 2 (show_path path0)]
2151 where
2152 graph :: [Node NodeKey ModuleGraphNode]
2153 graph =
2154 [ DigraphNode
2155 { node_payload = ms
2156 , node_key = mkNodeKey ms
2157 , node_dependencies = get_deps ms
2158 }
2159 | ms <- mss
2160 ]
2161
2162 get_deps :: ModuleGraphNode -> [NodeKey]
2163 get_deps = \case
2164 InstantiationNode iuid ->
2165 [ NodeKey_Module $ GWIB { gwib_mod = hole, gwib_isBoot = NotBoot }
2166 | hole <- uniqDSetToList $ instUnitHoles iuid
2167 ]
2168 ModuleNode (ExtendedModSummary ms bds) ->
2169 [ NodeKey_Module $ GWIB { gwib_mod = unLoc m, gwib_isBoot = IsBoot }
2170 | m <- ms_home_srcimps ms ] ++
2171 [ NodeKey_Unit inst_unit
2172 | inst_unit <- bds ] ++
2173 [ NodeKey_Module $ GWIB { gwib_mod = unLoc m, gwib_isBoot = NotBoot }
2174 | m <- ms_home_imps ms ]
2175
2176 show_path :: [ModuleGraphNode] -> SDoc
2177 show_path [] = panic "show_path"
2178 show_path [m] = ppr_node m <+> text "imports itself"
2179 show_path (m1:m2:ms) = vcat ( nest 6 (ppr_node m1)
2180 : nest 6 (text "imports" <+> ppr_node m2)
2181 : go ms )
2182 where
2183 go [] = [text "which imports" <+> ppr_node m1]
2184 go (m:ms) = (text "which imports" <+> ppr_node m) : go ms
2185
2186 ppr_node :: ModuleGraphNode -> SDoc
2187 ppr_node (ModuleNode m) = text "module" <+> ppr_ms (emsModSummary m)
2188 ppr_node (InstantiationNode u) = text "instantiated unit" <+> ppr u
2189
2190 ppr_ms :: ModSummary -> SDoc
2191 ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>
2192 (parens (text (msHsFilePath ms)))
2193
2194
2195 cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m ()
2196 cleanCurrentModuleTempFilesMaybe logger tmpfs dflags =
2197 unless (gopt Opt_KeepTmpFiles dflags) $
2198 liftIO $ cleanCurrentModuleTempFiles logger tmpfs
2199
2200
2201 addDepsToHscEnv :: [HomeModInfo] -> HscEnv -> HscEnv
2202 addDepsToHscEnv deps hsc_env =
2203 hscUpdateHPT (const $ listHMIToHpt deps) hsc_env
2204
2205 setHPT :: HomePackageTable -> HscEnv -> HscEnv
2206 setHPT deps hsc_env =
2207 hscUpdateHPT (const $ deps) hsc_env
2208
2209 -- | Wrap an action to catch and handle exceptions.
2210 wrapAction :: HscEnv -> IO a -> IO (Maybe a)
2211 wrapAction hsc_env k = do
2212 let lcl_logger = hsc_logger hsc_env
2213 lcl_dynflags = hsc_dflags hsc_env
2214 let logg err = printMessages lcl_logger (initDiagOpts lcl_dynflags) (srcErrorMessages err)
2215 -- MP: It is a bit strange how prettyPrintGhcErrors handles some errors but then we handle
2216 -- SourceError and ThreadKilled differently directly below. TODO: Refactor to use `catches`
2217 -- directly. MP should probably use safeTry here to not catch async exceptions but that will regress performance due to
2218 -- internally using forkIO.
2219 mres <- MC.try $ liftIO $ prettyPrintGhcErrors lcl_logger $ k
2220 case mres of
2221 Right res -> return $ Just res
2222 Left exc -> do
2223 case fromException exc of
2224 Just (err :: SourceError)
2225 -> logg err
2226 Nothing -> case fromException exc of
2227 -- ThreadKilled in particular needs to actually kill the thread.
2228 -- So rethrow that and the other async exceptions
2229 Just (err :: SomeAsyncException) -> throwIO err
2230 _ -> errorMsg lcl_logger (text (show exc))
2231 return Nothing
2232
2233 withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> RunMakeM b) -> RunMakeM b
2234 withParLog lqq_var k cont = do
2235 let init_log = liftIO $ do
2236 -- Make a new log queue
2237 lq <- newLogQueue k
2238 -- Add it into the LogQueueQueue
2239 atomically $ initLogQueue lqq_var lq
2240 return lq
2241 finish_log lq = liftIO (finishLogQueue lq)
2242 MC.bracket init_log finish_log $ \lq -> cont (pushLogHook (const (parLogAction lq)))
2243
2244 withLoggerHsc :: Int -> (HscEnv -> RunMakeM a) -> RunMakeM a
2245 withLoggerHsc k cont = do
2246 MakeEnv{withLogger, hsc_env} <- ask
2247 withLogger k $ \modifyLogger -> do
2248 let lcl_logger = modifyLogger (hsc_logger hsc_env)
2249 hsc_env' = hsc_env { hsc_logger = lcl_logger }
2250 -- Run continuation with modified logger
2251 cont hsc_env'
2252
2253 -- Executing compilation graph nodes
2254
2255 executeInstantiationNode :: Int
2256 -> Int
2257 -> RunMakeM HomePackageTable
2258 -> InstantiatedUnit
2259 -> RunMakeM ()
2260 executeInstantiationNode k n wait_deps iu = do
2261 withLoggerHsc k $ \hsc_env -> do
2262 -- Wait for the dependencies of this node
2263 deps <- wait_deps
2264 -- Output of the logger is mediated by a central worker to
2265 -- avoid output interleaving
2266 let lcl_hsc_env = setHPT deps hsc_env
2267 msg <- asks env_messager
2268 lift $ MaybeT $ wrapAction lcl_hsc_env $ do
2269 res <- upsweep_inst lcl_hsc_env msg k n iu
2270 cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env)
2271 return res
2272
2273 executeCompileNode :: Int
2274 -> Int
2275 -> Maybe HomeModInfo
2276 -> RunMakeM HomePackageTable
2277 -> Maybe (ModuleEnv (IORef TypeEnv))
2278 -> ModSummary
2279 -> RunMakeM HomeModInfo
2280 executeCompileNode k n !old_hmi wait_deps mknot_var mod = do
2281 MakeEnv{..} <- ask
2282 let mk_mod = case ms_hsc_src mod of
2283 HsigFile ->
2284 -- MP: It is probably a bit of a misimplementation in backpack that
2285 -- compiling a signature requires an knot_var for that unit.
2286 -- If you remove this then a lot of backpack tests fail.
2287 let mod_name = homeModuleInstantiation (hsc_home_unit hsc_env) (ms_mod mod)
2288 in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv
2289 _ -> return emptyModuleEnv
2290 knot_var <- liftIO $ maybe mk_mod return mknot_var
2291 deps <- wait_deps
2292 withLoggerHsc k $ \hsc_env -> do
2293 let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas
2294 lcl_dynflags = ms_hspp_opts mod
2295 let lcl_hsc_env =
2296 -- Localise the hsc_env to use the cached flags
2297 setHPT deps $
2298 hscSetFlags lcl_dynflags $
2299 hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var }
2300 -- Compile the module, locking with a semphore to avoid too many modules
2301 -- being compiled at the same time leading to high memory usage.
2302 lift $ MaybeT (withAbstractSem compile_sem $ wrapAction lcl_hsc_env $ do
2303 res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n
2304 cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags
2305 return res)
2306
2307 executeTypecheckLoop :: IO HomePackageTable -- Dependencies of the loop
2308 -> RunMakeM [HomeModInfo] -- The loop itself
2309 -> RunMakeM [HomeModInfo]
2310 executeTypecheckLoop wait_other_deps wait_local_deps = do
2311 hsc_env <- asks hsc_env
2312 hmis <- wait_local_deps
2313 other_deps <- liftIO wait_other_deps
2314 let lcl_hsc_env = setHPT other_deps hsc_env
2315 -- Notice that we do **not** have to pass the knot variables into this function.
2316 -- That's the whole point of typecheckLoop, to replace the IORef calls with normal
2317 -- knot-tying.
2318 lift $ MaybeT $ Just . map snd <$> typecheckLoop lcl_hsc_env hmis
2319
2320 -- | Wait for some dependencies to finish and then read from the given MVar.
2321 wait_deps_hpt :: MVar b -> [ResultVar (Maybe HomeModInfo)] -> ReaderT MakeEnv (MaybeT IO) b
2322 wait_deps_hpt hpt_var deps = do
2323 _ <- wait_deps deps
2324 liftIO $ readMVar hpt_var
2325
2326
2327 -- | Wait for dependencies to finish, and then return their results.
2328 wait_deps :: [ResultVar (Maybe HomeModInfo)] -> RunMakeM [HomeModInfo]
2329 wait_deps [] = return []
2330 wait_deps (x:xs) = do
2331 res <- lift $ waitResult x
2332 case res of
2333 Nothing -> wait_deps xs
2334 Just hmi -> (hmi:) <$> wait_deps xs
2335
2336
2337 -- Executing the pipelines
2338
2339 -- | Start a thread which reads from the LogQueueQueue
2340 logThread :: Logger -> TVar Bool -- Signal that no more new logs will be added, clear the queue and exit
2341 -> TVar LogQueueQueue -- Queue for logs
2342 -> IO (IO ())
2343 logThread logger stopped lqq_var = do
2344 finished_var <- newEmptyMVar
2345 _ <- forkIO $ print_logs *> putMVar finished_var ()
2346 return (takeMVar finished_var)
2347 where
2348 finish = mapM (printLogs logger)
2349
2350 print_logs = join $ atomically $ do
2351 lqq <- readTVar lqq_var
2352 case dequeueLogQueueQueue lqq of
2353 Just (lq, lqq') -> do
2354 writeTVar lqq_var lqq'
2355 return (printLogs logger lq *> print_logs)
2356 Nothing -> do
2357 -- No log to print, check if we are finished.
2358 stopped <- readTVar stopped
2359 if not stopped then retry
2360 else return (finish (allLogQueues lqq))
2361
2362
2363 label_self :: String -> IO ()
2364 label_self thread_name = do
2365 self_tid <- CC.myThreadId
2366 CC.labelThread self_tid thread_name
2367
2368
2369 runPipelines :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
2370 runPipelines n_job orig_hsc_env mHscMessager all_pipelines = do
2371 liftIO $ label_self "main --make thread"
2372
2373 plugins_hsc_env <- initializePlugins orig_hsc_env Nothing
2374 case n_job of
2375 1 -> runSeqPipelines plugins_hsc_env mHscMessager all_pipelines
2376 _n -> runParPipelines n_job plugins_hsc_env mHscMessager all_pipelines
2377
2378 runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
2379 runSeqPipelines plugin_hsc_env mHscMessager all_pipelines =
2380 let env = MakeEnv { hsc_env = plugin_hsc_env
2381 , withLogger = \_ k -> k id
2382 , compile_sem = AbstractSem (return ()) (return ())
2383 , env_messager = mHscMessager
2384 }
2385 in runAllPipelines 1 env all_pipelines
2386
2387
2388 -- | Build and run a pipeline
2389 runParPipelines :: Int -- ^ How many capabilities to use
2390 -> HscEnv -- ^ The basic HscEnv which is augmented with specific info for each module
2391 -> Maybe Messager -- ^ Optional custom messager to use to report progress
2392 -> [MakeAction] -- ^ The build plan for all the module nodes
2393 -> IO ()
2394 runParPipelines n_jobs plugin_hsc_env mHscMessager all_pipelines = do
2395
2396
2397 -- A variable which we write to when an error has happened and we have to tell the
2398 -- logging thread to gracefully shut down.
2399 stopped_var <- newTVarIO False
2400 -- The queue of LogQueues which actions are able to write to. When an action starts it
2401 -- will add it's LogQueue into this queue.
2402 log_queue_queue_var <- newTVarIO newLogQueueQueue
2403 -- Thread which coordinates the printing of logs
2404 wait_log_thread <- logThread (hsc_logger plugin_hsc_env) stopped_var log_queue_queue_var
2405
2406
2407 -- Make the logger thread-safe, in case there is some output which isn't sent via the LogQueue.
2408 thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env)
2409 let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger }
2410
2411 let updNumCapabilities = liftIO $ do
2412 n_capabilities <- getNumCapabilities
2413 n_cpus <- getNumProcessors
2414 -- Setting number of capabilities more than
2415 -- CPU count usually leads to high userspace
2416 -- lock contention. #9221
2417 let n_caps = min n_jobs n_cpus
2418 unless (n_capabilities /= 1) $ setNumCapabilities n_caps
2419 return n_capabilities
2420
2421 let resetNumCapabilities orig_n = do
2422 liftIO $ setNumCapabilities orig_n
2423 atomically $ writeTVar stopped_var True
2424 wait_log_thread
2425
2426 compile_sem <- newQSem n_jobs
2427 let abstract_sem = AbstractSem (waitQSem compile_sem) (signalQSem compile_sem)
2428 -- Reset the number of capabilities once the upsweep ends.
2429 let env = MakeEnv { hsc_env = thread_safe_hsc_env
2430 , withLogger = withParLog log_queue_queue_var
2431 , compile_sem = abstract_sem
2432 , env_messager = mHscMessager
2433 }
2434
2435 MC.bracket updNumCapabilities resetNumCapabilities $ \_ ->
2436 runAllPipelines n_jobs env all_pipelines
2437
2438 withLocalTmpFS :: RunMakeM a -> RunMakeM a
2439 withLocalTmpFS act = do
2440 let initialiser = do
2441 MakeEnv{..} <- ask
2442 lcl_tmpfs <- liftIO $ forkTmpFsFrom (hsc_tmpfs hsc_env)
2443 return $ hsc_env { hsc_tmpfs = lcl_tmpfs }
2444 finaliser lcl_env = do
2445 gbl_env <- ask
2446 liftIO $ mergeTmpFsInto (hsc_tmpfs lcl_env) (hsc_tmpfs (hsc_env gbl_env))
2447 -- Add remaining files which weren't cleaned up into local tmp fs for
2448 -- clean-up later.
2449 -- Clear the logQueue if this node had it's own log queue
2450 MC.bracket initialiser finaliser $ \lcl_hsc_env -> local (\env -> env { hsc_env = lcl_hsc_env}) act
2451
2452 -- | Run the given actions and then wait for them all to finish.
2453 runAllPipelines :: Int -> MakeEnv -> [MakeAction] -> IO ()
2454 runAllPipelines n_jobs env acts = do
2455 let spawn_actions :: IO [ThreadId]
2456 spawn_actions = if n_jobs == 1
2457 then (:[]) <$> (forkIOWithUnmask $ \unmask -> void $ runLoop (\io -> io unmask) env acts)
2458 else runLoop forkIOWithUnmask env acts
2459
2460 kill_actions :: [ThreadId] -> IO ()
2461 kill_actions tids = mapM_ killThread tids
2462
2463 MC.bracket spawn_actions kill_actions $ \_ -> do
2464 mapM_ waitMakeAction acts
2465
2466 -- | Execute each action in order, limiting the amount of parrelism by the given
2467 -- semaphore.
2468 runLoop :: (((forall a. IO a -> IO a) -> IO ()) -> IO a) -> MakeEnv -> [MakeAction] -> IO [a]
2469 runLoop _ _env [] = return []
2470 runLoop fork_thread env (MakeAction act res_var :acts) = do
2471 new_thread <-
2472 fork_thread $ \unmask -> (do
2473 mres <- (unmask $ run_pipeline (withLocalTmpFS act))
2474 `MC.onException` (putMVar res_var Nothing) -- Defensive: If there's an unhandled exception then still signal the failure.
2475 putMVar res_var mres)
2476 threads <- runLoop fork_thread env acts
2477 return (new_thread : threads)
2478 where
2479 run_pipeline :: RunMakeM a -> IO (Maybe a)
2480 run_pipeline p = runMaybeT (runReaderT p env)
2481
2482 data MakeAction = forall a . MakeAction (RunMakeM a) (MVar (Maybe a))
2483
2484 waitMakeAction :: MakeAction -> IO ()
2485 waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar
2486
2487 {- Note [GHC Heap Invariants]
2488
2489 This note is a general place to explain some of the heap invariants which should
2490 hold for a program compiled with --make mode. These invariants are all things
2491 which can be checked easily using ghc-debug.
2492
2493 1. No HomeModInfo are reachable via the EPS.
2494 Why? Interfaces are lazily loaded into the EPS and the lazy thunk retains
2495 a reference to the entire HscEnv, if we are not careful the HscEnv will
2496 contain the HomePackageTable at the time the interface was loaded and
2497 it will never be released.
2498 Where? dontLeakTheHPT in GHC.Iface.Load
2499
2500 2. No KnotVars are live at the end of upsweep (#20491)
2501 Why? KnotVars contains an old stale reference to the TypeEnv for modules
2502 which participate in a loop. At the end of a loop all the KnotVars references
2503 should be removed by the call to typecheckLoop.
2504 Where? typecheckLoop in GHC.Driver.Make.
2505
2506 3. Immediately after a reload, no ModDetails are live.
2507 Why? During the upsweep all old ModDetails are replaced with a new ModDetails
2508 generated from a ModIface. If we don't clear the ModDetails before the
2509 reload takes place then memory usage during the reload is twice as much
2510 as it should be as we retain a copy of the ModDetails for too long.
2511 Where? pruneCache in GHC.Driver.Make
2512
2513 -}