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