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