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