We also need to retypecheck before when we do parallel make.
[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 unless (n_capabilities /= 1) $ setNumCapabilities n_jobs
766 return n_capabilities
767 -- Reset the number of capabilities once the upsweep ends.
768 let resetNumCapabilities orig_n = liftIO $ setNumCapabilities orig_n
769
770 gbracket updNumCapabilities resetNumCapabilities $ \_ -> do
771
772 -- Sync the global session with the latest HscEnv once the upsweep ends.
773 let finallySyncSession io = io `gfinally` do
774 hsc_env <- liftIO $ readMVar hsc_env_var
775 setSession hsc_env
776
777 finallySyncSession $ do
778
779 -- Build the compilation graph out of the list of SCCs. Module cycles are
780 -- handled at the very end, after some useful work gets done. Note that
781 -- this list is topologically sorted (by virtue of 'sccs' being sorted so).
782 (comp_graph,cycle) <- liftIO $ buildCompGraph sccs
783 let comp_graph_w_idx = zip comp_graph [1..]
784
785 -- The list of all loops in the compilation graph.
786 -- NB: For convenience, the last module of each loop (aka the module that
787 -- finishes the loop) is prepended to the beginning of the loop.
788 let comp_graph_loops = go (map fstOf3 (reverse comp_graph))
789 where
790 go [] = []
791 go (ms:mss) | Just loop <- getModLoop ms (ms:mss)
792 = map mkBuildModule (ms:loop) : go mss
793 | otherwise
794 = go mss
795
796 -- Build a Map out of the compilation graph with which we can efficiently
797 -- look up the result MVar associated with a particular home module.
798 let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)
799 home_mod_map =
800 Map.fromList [ (mkBuildModule ms, (mvar, idx))
801 | ((ms,mvar,_),idx) <- comp_graph_w_idx ]
802
803
804 liftIO $ label_self "main --make thread"
805 -- For each module in the module graph, spawn a worker thread that will
806 -- compile this module.
807 let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) ->
808 forkIOWithUnmask $ \unmask -> do
809 liftIO $ label_self $ unwords
810 [ "worker --make thread"
811 , "for module"
812 , show (moduleNameString (ms_mod_name mod))
813 , "number"
814 , show mod_idx
815 ]
816 -- Replace the default log_action with one that writes each
817 -- message to the module's log_queue. The main thread will
818 -- deal with synchronously printing these messages.
819 --
820 -- Use a local filesToClean var so that we can clean up
821 -- intermediate files in a timely fashion (as soon as
822 -- compilation for that module is finished) without having to
823 -- worry about accidentally deleting a simultaneous compile's
824 -- important files.
825 lcl_files_to_clean <- newIORef []
826 let lcl_dflags = dflags { log_action = parLogAction log_queue
827 , filesToClean = lcl_files_to_clean }
828
829 -- Unmask asynchronous exceptions and perform the thread-local
830 -- work to compile the module (see parUpsweep_one).
831 m_res <- try $ unmask $ prettyPrintGhcErrors lcl_dflags $
832 parUpsweep_one mod home_mod_map comp_graph_loops
833 lcl_dflags cleanup
834 par_sem hsc_env_var old_hpt_var
835 stable_mods mod_idx (length sccs)
836
837 res <- case m_res of
838 Right flag -> return flag
839 Left exc -> do
840 -- Don't print ThreadKilled exceptions: they are used
841 -- to kill the worker thread in the event of a user
842 -- interrupt, and the user doesn't have to be informed
843 -- about that.
844 when (fromException exc /= Just ThreadKilled)
845 (errorMsg lcl_dflags (text (show exc)))
846 return Failed
847
848 -- Populate the result MVar.
849 putMVar mvar res
850
851 -- Write the end marker to the message queue, telling the main
852 -- thread that it can stop waiting for messages from this
853 -- particular compile.
854 writeLogQueue log_queue Nothing
855
856 -- Add the remaining files that weren't cleaned up to the
857 -- global filesToClean ref, for cleanup later.
858 files_kept <- readIORef (filesToClean lcl_dflags)
859 addFilesToClean dflags files_kept
860
861
862 -- Kill all the workers, masking interrupts (since killThread is
863 -- interruptible). XXX: This is not ideal.
864 ; killWorkers = uninterruptibleMask_ . mapM_ killThread }
865
866
867 -- Spawn the workers, making sure to kill them later. Collect the results
868 -- of each compile.
869 results <- liftIO $ bracket spawnWorkers killWorkers $ \_ ->
870 -- Loop over each module in the compilation graph in order, printing
871 -- each message from its log_queue.
872 forM comp_graph $ \(mod,mvar,log_queue) -> do
873 printLogs dflags log_queue
874 result <- readMVar mvar
875 if succeeded result then return (Just mod) else return Nothing
876
877
878 -- Collect and return the ModSummaries of all the successful compiles.
879 -- NB: Reverse this list to maintain output parity with the sequential upsweep.
880 let ok_results = reverse (catMaybes results)
881
882 -- Handle any cycle in the original compilation graph and return the result
883 -- of the upsweep.
884 case cycle of
885 Just mss -> do
886 liftIO $ fatalErrorMsg dflags (cyclicModuleErr mss)
887 return (Failed,ok_results)
888 Nothing -> do
889 let success_flag = successIf (all isJust results)
890 return (success_flag,ok_results)
891
892 where
893 writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,PprStyle,MsgDoc) -> IO ()
894 writeLogQueue (LogQueue ref sem) msg = do
895 atomicModifyIORef' ref $ \msgs -> (msg:msgs,())
896 _ <- tryPutMVar sem ()
897 return ()
898
899 -- The log_action callback that is used to synchronize messages from a
900 -- worker thread.
901 parLogAction :: LogQueue -> LogAction
902 parLogAction log_queue _dflags !reason !severity !srcSpan !style !msg = do
903 writeLogQueue log_queue (Just (reason,severity,srcSpan,style,msg))
904
905 -- Print each message from the log_queue using the log_action from the
906 -- session's DynFlags.
907 printLogs :: DynFlags -> LogQueue -> IO ()
908 printLogs !dflags (LogQueue ref sem) = read_msgs
909 where read_msgs = do
910 takeMVar sem
911 msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs)
912 print_loop msgs
913
914 print_loop [] = read_msgs
915 print_loop (x:xs) = case x of
916 Just (reason,severity,srcSpan,style,msg) -> do
917 log_action dflags dflags reason severity srcSpan style msg
918 print_loop xs
919 -- Exit the loop once we encounter the end marker.
920 Nothing -> return ()
921
922 -- The interruptible subset of the worker threads' work.
923 parUpsweep_one
924 :: ModSummary
925 -- ^ The module we wish to compile
926 -> Map BuildModule (MVar SuccessFlag, Int)
927 -- ^ The map of home modules and their result MVar
928 -> [[BuildModule]]
929 -- ^ The list of all module loops within the compilation graph.
930 -> DynFlags
931 -- ^ The thread-local DynFlags
932 -> (HscEnv -> IO ())
933 -- ^ The callback for cleaning up intermediate files
934 -> QSem
935 -- ^ The semaphore for limiting the number of simultaneous compiles
936 -> MVar HscEnv
937 -- ^ The MVar that synchronizes updates to the global HscEnv
938 -> IORef HomePackageTable
939 -- ^ The old HPT
940 -> ([ModuleName],[ModuleName])
941 -- ^ Lists of stable objects and BCOs
942 -> Int
943 -- ^ The index of this module
944 -> Int
945 -- ^ The total number of modules
946 -> IO SuccessFlag
947 -- ^ The result of this compile
948 parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags cleanup par_sem
949 hsc_env_var old_hpt_var stable_mods mod_index num_mods = do
950
951 let this_build_mod = mkBuildModule mod
952
953 let home_imps = map unLoc $ ms_home_imps mod
954 let home_src_imps = map unLoc $ ms_home_srcimps mod
955
956 -- All the textual imports of this module.
957 let textual_deps = Set.fromList $ mapFst (mkModule (thisPackage lcl_dflags)) $
958 zip home_imps (repeat NotBoot) ++
959 zip home_src_imps (repeat IsBoot)
960
961 -- Dealing with module loops
962 -- ~~~~~~~~~~~~~~~~~~~~~~~~~
963 --
964 -- Not only do we have to deal with explicit textual dependencies, we also
965 -- have to deal with implicit dependencies introduced by import cycles that
966 -- are broken by an hs-boot file. We have to ensure that:
967 --
968 -- 1. A module that breaks a loop must depend on all the modules in the
969 -- loop (transitively or otherwise). This is normally always fulfilled
970 -- by the module's textual dependencies except in degenerate loops,
971 -- e.g.:
972 --
973 -- A.hs imports B.hs-boot
974 -- B.hs doesn't import A.hs
975 -- C.hs imports A.hs, B.hs
976 --
977 -- In this scenario, getModLoop will detect the module loop [A,B] but
978 -- the loop finisher B doesn't depend on A. So we have to explicitly add
979 -- A in as a dependency of B when we are compiling B.
980 --
981 -- 2. A module that depends on a module in an external loop can't proceed
982 -- until the entire loop is re-typechecked.
983 --
984 -- These two invariants have to be maintained to correctly build a
985 -- compilation graph with one or more loops.
986
987
988 -- The loop that this module will finish. After this module successfully
989 -- compiles, this loop is going to get re-typechecked.
990 let finish_loop = listToMaybe
991 [ tail loop | loop <- comp_graph_loops
992 , head loop == this_build_mod ]
993
994 -- If this module finishes a loop then it must depend on all the other
995 -- modules in that loop because the entire module loop is going to be
996 -- re-typechecked once this module gets compiled. These extra dependencies
997 -- are this module's "internal" loop dependencies, because this module is
998 -- inside the loop in question.
999 let int_loop_deps = Set.fromList $
1000 case finish_loop of
1001 Nothing -> []
1002 Just loop -> filter (/= this_build_mod) loop
1003
1004 -- If this module depends on a module within a loop then it must wait for
1005 -- that loop to get re-typechecked, i.e. it must wait on the module that
1006 -- finishes that loop. These extra dependencies are this module's
1007 -- "external" loop dependencies, because this module is outside of the
1008 -- loop(s) in question.
1009 let ext_loop_deps = Set.fromList
1010 [ head loop | loop <- comp_graph_loops
1011 , any (`Set.member` textual_deps) loop
1012 , this_build_mod `notElem` loop ]
1013
1014
1015 let all_deps = foldl1 Set.union [textual_deps, int_loop_deps, ext_loop_deps]
1016
1017 -- All of the module's home-module dependencies.
1018 let home_deps_with_idx =
1019 [ home_dep | dep <- Set.toList all_deps
1020 , Just home_dep <- [Map.lookup dep home_mod_map] ]
1021
1022 -- Sort the list of dependencies in reverse-topological order. This way, by
1023 -- the time we get woken up by the result of an earlier dependency,
1024 -- subsequent dependencies are more likely to have finished. This step
1025 -- effectively reduces the number of MVars that each thread blocks on.
1026 let home_deps = map fst $ sortBy (flip (comparing snd)) home_deps_with_idx
1027
1028 -- Wait for the all the module's dependencies to finish building.
1029 deps_ok <- allM (fmap succeeded . readMVar) home_deps
1030
1031 -- We can't build this module if any of its dependencies failed to build.
1032 if not deps_ok
1033 then return Failed
1034 else do
1035 -- Any hsc_env at this point is OK to use since we only really require
1036 -- that the HPT contains the HMIs of our dependencies.
1037 hsc_env <- readMVar hsc_env_var
1038 old_hpt <- readIORef old_hpt_var
1039
1040 let logger err = printBagOfErrors lcl_dflags (srcErrorMessages err)
1041
1042 -- Limit the number of parallel compiles.
1043 let withSem sem = bracket_ (waitQSem sem) (signalQSem sem)
1044 mb_mod_info <- withSem par_sem $
1045 handleSourceError (\err -> do logger err; return Nothing) $ do
1046 -- Have the ModSummary and HscEnv point to our local log_action
1047 -- and filesToClean var.
1048 let lcl_mod = localize_mod mod
1049 let lcl_hsc_env = localize_hsc_env hsc_env
1050
1051 -- Re-typecheck the loop
1052 type_env_var <- liftIO $ newIORef emptyNameEnv
1053 let lcl_hsc_env' = lcl_hsc_env { hsc_type_env_var =
1054 Just (ms_mod lcl_mod, type_env_var) }
1055 lcl_hsc_env'' <- case finish_loop of
1056 Nothing -> return lcl_hsc_env'
1057 Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $
1058 map (moduleName . fst) loop
1059
1060 -- Compile the module.
1061 mod_info <- upsweep_mod lcl_hsc_env'' old_hpt stable_mods
1062 lcl_mod mod_index num_mods
1063 return (Just mod_info)
1064
1065 case mb_mod_info of
1066 Nothing -> return Failed
1067 Just mod_info -> do
1068 let this_mod = ms_mod_name mod
1069
1070 -- Prune the old HPT unless this is an hs-boot module.
1071 unless (isBootSummary mod) $
1072 atomicModifyIORef' old_hpt_var $ \old_hpt ->
1073 (delFromHpt old_hpt this_mod, ())
1074
1075 -- Update and fetch the global HscEnv.
1076 lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do
1077 let hsc_env' = hsc_env
1078 { hsc_HPT = addToHpt (hsc_HPT hsc_env)
1079 this_mod mod_info }
1080 -- If this module is a loop finisher, now is the time to
1081 -- re-typecheck the loop.
1082 hsc_env'' <- case finish_loop of
1083 Nothing -> return hsc_env'
1084 Just loop -> typecheckLoop lcl_dflags hsc_env' $
1085 map (moduleName . fst) loop
1086 return (hsc_env'', localize_hsc_env hsc_env'')
1087
1088 -- Clean up any intermediate files.
1089 cleanup lcl_hsc_env'
1090 return Succeeded
1091
1092 where
1093 localize_mod mod
1094 = mod { ms_hspp_opts = (ms_hspp_opts mod)
1095 { log_action = log_action lcl_dflags
1096 , filesToClean = filesToClean lcl_dflags } }
1097
1098 localize_hsc_env hsc_env
1099 = hsc_env { hsc_dflags = (hsc_dflags hsc_env)
1100 { log_action = log_action lcl_dflags
1101 , filesToClean = filesToClean lcl_dflags } }
1102
1103 -- -----------------------------------------------------------------------------
1104 --
1105 -- | The upsweep
1106 --
1107 -- This is where we compile each module in the module graph, in a pass
1108 -- from the bottom to the top of the graph.
1109 --
1110 -- There better had not be any cyclic groups here -- we check for them.
1111 upsweep
1112 :: GhcMonad m
1113 => HomePackageTable -- ^ HPT from last time round (pruned)
1114 -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)
1115 -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files
1116 -> [SCC ModSummary] -- ^ Mods to do (the worklist)
1117 -> m (SuccessFlag,
1118 [ModSummary])
1119 -- ^ Returns:
1120 --
1121 -- 1. A flag whether the complete upsweep was successful.
1122 -- 2. The 'HscEnv' in the monad has an updated HPT
1123 -- 3. A list of modules which succeeded loading.
1124
1125 upsweep old_hpt stable_mods cleanup sccs = do
1126 (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs)
1127 return (res, reverse done)
1128 where
1129
1130 upsweep' _old_hpt done
1131 [] _ _
1132 = return (Succeeded, done)
1133
1134 upsweep' _old_hpt done
1135 (CyclicSCC ms:_) _ _
1136 = do dflags <- getSessionDynFlags
1137 liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
1138 return (Failed, done)
1139
1140 upsweep' old_hpt done
1141 (AcyclicSCC mod:mods) mod_index nmods
1142 = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
1143 -- show (map (moduleUserString.moduleName.mi_module.hm_iface)
1144 -- (moduleEnvElts (hsc_HPT hsc_env)))
1145 let logger _mod = defaultWarnErrLogger
1146
1147 hsc_env <- getSession
1148
1149 -- Remove unwanted tmp files between compilations
1150 liftIO (cleanup hsc_env)
1151
1152 -- Get ready to tie the knot
1153 type_env_var <- liftIO $ newIORef emptyNameEnv
1154 let hsc_env1 = hsc_env { hsc_type_env_var =
1155 Just (ms_mod mod, type_env_var) }
1156 setSession hsc_env1
1157
1158 -- Lazily reload the HPT modules participating in the loop.
1159 -- See Note [Tying the knot]--if we don't throw out the old HPT
1160 -- and reinitalize the knot-tying process, anything that was forced
1161 -- while we were previously typechecking won't get updated.
1162 hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done
1163 setSession hsc_env2
1164
1165 mb_mod_info
1166 <- handleSourceError
1167 (\err -> do logger mod (Just err); return Nothing) $ do
1168 mod_info <- liftIO $ upsweep_mod hsc_env2 old_hpt stable_mods
1169 mod mod_index nmods
1170 logger mod Nothing -- log warnings
1171 return (Just mod_info)
1172
1173 case mb_mod_info of
1174 Nothing -> return (Failed, done)
1175 Just mod_info -> do
1176 let this_mod = ms_mod_name mod
1177
1178 -- Add new info to hsc_env
1179 hpt1 = addToHpt (hsc_HPT hsc_env2) this_mod mod_info
1180 hsc_env3 = hsc_env2 { hsc_HPT = hpt1, hsc_type_env_var = Nothing }
1181
1182 -- Space-saving: delete the old HPT entry
1183 -- for mod BUT if mod is a hs-boot
1184 -- node, don't delete it. For the
1185 -- interface, the HPT entry is probaby for the
1186 -- main Haskell source file. Deleting it
1187 -- would force the real module to be recompiled
1188 -- every time.
1189 old_hpt1 | isBootSummary mod = old_hpt
1190 | otherwise = delFromHpt old_hpt this_mod
1191
1192 done' = mod:done
1193
1194 -- fixup our HomePackageTable after we've finished compiling
1195 -- a mutually-recursive loop. We have to do this again
1196 -- to make sure we have the final unfoldings, which may
1197 -- not have been computed accurately in the previous
1198 -- retypecheck.
1199 hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done'
1200 setSession hsc_env4
1201
1202 upsweep' old_hpt1 done' mods (mod_index+1) nmods
1203
1204 maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)
1205 maybeGetIfaceDate dflags location
1206 | writeInterfaceOnlyMode dflags
1207 -- Minor optimization: it should be harmless to check the hi file location
1208 -- always, but it's better to avoid hitting the filesystem if possible.
1209 = modificationTimeIfExists (ml_hi_file location)
1210 | otherwise
1211 = return Nothing
1212
1213 -- | Compile a single module. Always produce a Linkable for it if
1214 -- successful. If no compilation happened, return the old Linkable.
1215 upsweep_mod :: HscEnv
1216 -> HomePackageTable
1217 -> ([ModuleName],[ModuleName])
1218 -> ModSummary
1219 -> Int -- index of module
1220 -> Int -- total number of modules
1221 -> IO HomeModInfo
1222 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
1223 = let
1224 this_mod_name = ms_mod_name summary
1225 this_mod = ms_mod summary
1226 mb_obj_date = ms_obj_date summary
1227 mb_if_date = ms_iface_date summary
1228 obj_fn = ml_obj_file (ms_location summary)
1229 hs_date = ms_hs_date summary
1230
1231 is_stable_obj = this_mod_name `elem` stable_obj
1232 is_stable_bco = this_mod_name `elem` stable_bco
1233
1234 old_hmi = lookupHpt old_hpt this_mod_name
1235
1236 -- We're using the dflags for this module now, obtained by
1237 -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
1238 dflags = ms_hspp_opts summary
1239 prevailing_target = hscTarget (hsc_dflags hsc_env)
1240 local_target = hscTarget dflags
1241
1242 -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that
1243 -- we don't do anything dodgy: these should only work to change
1244 -- from -fllvm to -fasm and vice-versa, otherwise we could
1245 -- end up trying to link object code to byte code.
1246 target = if prevailing_target /= local_target
1247 && (not (isObjectTarget prevailing_target)
1248 || not (isObjectTarget local_target))
1249 then prevailing_target
1250 else local_target
1251
1252 -- store the corrected hscTarget into the summary
1253 summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }
1254
1255 -- The old interface is ok if
1256 -- a) we're compiling a source file, and the old HPT
1257 -- entry is for a source file
1258 -- b) we're compiling a hs-boot file
1259 -- Case (b) allows an hs-boot file to get the interface of its
1260 -- real source file on the second iteration of the compilation
1261 -- manager, but that does no harm. Otherwise the hs-boot file
1262 -- will always be recompiled
1263
1264 mb_old_iface
1265 = case old_hmi of
1266 Nothing -> Nothing
1267 Just hm_info | isBootSummary summary -> Just iface
1268 | not (mi_boot iface) -> Just iface
1269 | otherwise -> Nothing
1270 where
1271 iface = hm_iface hm_info
1272
1273 compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo
1274 compile_it mb_linkable src_modified =
1275 compileOne hsc_env summary' mod_index nmods
1276 mb_old_iface mb_linkable src_modified
1277
1278 compile_it_discard_iface :: Maybe Linkable -> SourceModified
1279 -> IO HomeModInfo
1280 compile_it_discard_iface mb_linkable src_modified =
1281 compileOne hsc_env summary' mod_index nmods
1282 Nothing mb_linkable src_modified
1283
1284 -- With the HscNothing target we create empty linkables to avoid
1285 -- recompilation. We have to detect these to recompile anyway if
1286 -- the target changed since the last compile.
1287 is_fake_linkable
1288 | Just hmi <- old_hmi, Just l <- hm_linkable hmi =
1289 null (linkableUnlinked l)
1290 | otherwise =
1291 -- we have no linkable, so it cannot be fake
1292 False
1293
1294 implies False _ = True
1295 implies True x = x
1296
1297 in
1298 case () of
1299 _
1300 -- Regardless of whether we're generating object code or
1301 -- byte code, we can always use an existing object file
1302 -- if it is *stable* (see checkStability).
1303 | is_stable_obj, Just hmi <- old_hmi -> do
1304 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1305 (text "skipping stable obj mod:" <+> ppr this_mod_name)
1306 return hmi
1307 -- object is stable, and we have an entry in the
1308 -- old HPT: nothing to do
1309
1310 | is_stable_obj, isNothing old_hmi -> do
1311 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1312 (text "compiling stable on-disk mod:" <+> ppr this_mod_name)
1313 linkable <- liftIO $ findObjectLinkable this_mod obj_fn
1314 (expectJust "upsweep1" mb_obj_date)
1315 compile_it (Just linkable) SourceUnmodifiedAndStable
1316 -- object is stable, but we need to load the interface
1317 -- off disk to make a HMI.
1318
1319 | not (isObjectTarget target), is_stable_bco,
1320 (target /= HscNothing) `implies` not is_fake_linkable ->
1321 ASSERT(isJust old_hmi) -- must be in the old_hpt
1322 let Just hmi = old_hmi in do
1323 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1324 (text "skipping stable BCO mod:" <+> ppr this_mod_name)
1325 return hmi
1326 -- BCO is stable: nothing to do
1327
1328 | not (isObjectTarget target),
1329 Just hmi <- old_hmi,
1330 Just l <- hm_linkable hmi,
1331 not (isObjectLinkable l),
1332 (target /= HscNothing) `implies` not is_fake_linkable,
1333 linkableTime l >= ms_hs_date summary -> do
1334 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1335 (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)
1336 compile_it (Just l) SourceUnmodified
1337 -- we have an old BCO that is up to date with respect
1338 -- to the source: do a recompilation check as normal.
1339
1340 -- When generating object code, if there's an up-to-date
1341 -- object file on the disk, then we can use it.
1342 -- However, if the object file is new (compared to any
1343 -- linkable we had from a previous compilation), then we
1344 -- must discard any in-memory interface, because this
1345 -- means the user has compiled the source file
1346 -- separately and generated a new interface, that we must
1347 -- read from the disk.
1348 --
1349 | isObjectTarget target,
1350 Just obj_date <- mb_obj_date,
1351 obj_date >= hs_date -> do
1352 case old_hmi of
1353 Just hmi
1354 | Just l <- hm_linkable hmi,
1355 isObjectLinkable l && linkableTime l == obj_date -> do
1356 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1357 (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)
1358 compile_it (Just l) SourceUnmodified
1359 _otherwise -> do
1360 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1361 (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)
1362 linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
1363 compile_it_discard_iface (Just linkable) SourceUnmodified
1364
1365 -- See Note [Recompilation checking when typechecking only]
1366 | writeInterfaceOnlyMode dflags,
1367 Just if_date <- mb_if_date,
1368 if_date >= hs_date -> do
1369 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1370 (text "skipping tc'd mod:" <+> ppr this_mod_name)
1371 compile_it Nothing SourceUnmodified
1372
1373 _otherwise -> do
1374 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
1375 (text "compiling mod:" <+> ppr this_mod_name)
1376 compile_it Nothing SourceModified
1377
1378 -- Note [Recompilation checking when typechecking only]
1379 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1380 -- If we are compiling with -fno-code -fwrite-interface, there won't
1381 -- be any object code that we can compare against, nor should there
1382 -- be: we're *just* generating interface files. In this case, we
1383 -- want to check if the interface file is new, in lieu of the object
1384 -- file. See also Trac #9243.
1385
1386
1387 -- Filter modules in the HPT
1388 retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
1389 retainInTopLevelEnvs keep_these hpt
1390 = listToHpt [ (mod, expectJust "retain" mb_mod_info)
1391 | mod <- keep_these
1392 , let mb_mod_info = lookupHpt hpt mod
1393 , isJust mb_mod_info ]
1394
1395 -- ---------------------------------------------------------------------------
1396 -- Typecheck module loops
1397 {-
1398 See bug #930. This code fixes a long-standing bug in --make. The
1399 problem is that when compiling the modules *inside* a loop, a data
1400 type that is only defined at the top of the loop looks opaque; but
1401 after the loop is done, the structure of the data type becomes
1402 apparent.
1403
1404 The difficulty is then that two different bits of code have
1405 different notions of what the data type looks like.
1406
1407 The idea is that after we compile a module which also has an .hs-boot
1408 file, we re-generate the ModDetails for each of the modules that
1409 depends on the .hs-boot file, so that everyone points to the proper
1410 TyCons, Ids etc. defined by the real module, not the boot module.
1411 Fortunately re-generating a ModDetails from a ModIface is easy: the
1412 function TcIface.typecheckIface does exactly that.
1413
1414 Picking the modules to re-typecheck is slightly tricky. Starting from
1415 the module graph consisting of the modules that have already been
1416 compiled, we reverse the edges (so they point from the imported module
1417 to the importing module), and depth-first-search from the .hs-boot
1418 node. This gives us all the modules that depend transitively on the
1419 .hs-boot module, and those are exactly the modules that we need to
1420 re-typecheck.
1421
1422 Following this fix, GHC can compile itself with --make -O2.
1423 -}
1424
1425 reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
1426 reTypecheckLoop hsc_env ms graph
1427 | Just loop <- getModLoop ms graph
1428 -- SOME hs-boot files should still
1429 -- get used, just not the loop-closer.
1430 , let non_boot = filter (\l -> not (isBootSummary l &&
1431 ms_mod l == ms_mod ms)) loop
1432 = typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot)
1433 | otherwise
1434 = return hsc_env
1435
1436 getModLoop :: ModSummary -> ModuleGraph -> Maybe [ModSummary]
1437 getModLoop ms graph
1438 | not (isBootSummary ms)
1439 , any (\m -> ms_mod m == this_mod && isBootSummary m) graph
1440 , let mss = reachableBackwards (ms_mod_name ms) graph
1441 = Just mss
1442 | otherwise
1443 = Nothing
1444 where
1445 this_mod = ms_mod ms
1446
1447 typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
1448 typecheckLoop dflags hsc_env mods = do
1449 debugTraceMsg dflags 2 $
1450 text "Re-typechecking loop: " <> ppr mods
1451 new_hpt <-
1452 fixIO $ \new_hpt -> do
1453 let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }
1454 mds <- initIfaceCheck (text "typecheckLoop") new_hsc_env $
1455 mapM (typecheckIface . hm_iface) hmis
1456 let new_hpt = addListToHpt old_hpt
1457 (zip mods [ hmi{ hm_details = details }
1458 | (hmi,details) <- zip hmis mds ])
1459 return new_hpt
1460 return hsc_env{ hsc_HPT = new_hpt }
1461 where
1462 old_hpt = hsc_HPT hsc_env
1463 hmis = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods
1464
1465 reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
1466 reachableBackwards mod summaries
1467 = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]
1468 where -- the rest just sets up the graph:
1469 (graph, lookup_node) = moduleGraphNodes False summaries
1470 root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
1471
1472 -- ---------------------------------------------------------------------------
1473 --
1474 -- | Topological sort of the module graph
1475 topSortModuleGraph
1476 :: Bool
1477 -- ^ Drop hi-boot nodes? (see below)
1478 -> [ModSummary]
1479 -> Maybe ModuleName
1480 -- ^ Root module name. If @Nothing@, use the full graph.
1481 -> [SCC ModSummary]
1482 -- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
1483 -- The resulting list of strongly-connected-components is in topologically
1484 -- sorted order, starting with the module(s) at the bottom of the
1485 -- dependency graph (ie compile them first) and ending with the ones at
1486 -- the top.
1487 --
1488 -- Drop hi-boot nodes (first boolean arg)?
1489 --
1490 -- - @False@: treat the hi-boot summaries as nodes of the graph,
1491 -- so the graph must be acyclic
1492 --
1493 -- - @True@: eliminate the hi-boot nodes, and instead pretend
1494 -- the a source-import of Foo is an import of Foo
1495 -- The resulting graph has no hi-boot nodes, but can be cyclic
1496
1497 topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
1498 = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
1499 where
1500 (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries
1501
1502 initial_graph = case mb_root_mod of
1503 Nothing -> graph
1504 Just root_mod ->
1505 -- restrict the graph to just those modules reachable from
1506 -- the specified module. We do this by building a graph with
1507 -- the full set of nodes, and determining the reachable set from
1508 -- the specified node.
1509 let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node
1510 | otherwise = throwGhcException (ProgramError "module does not exist")
1511 in graphFromEdgedVerticesUniq (seq root (reachableG graph root))
1512
1513 type SummaryNode = (ModSummary, Int, [Int])
1514
1515 summaryNodeKey :: SummaryNode -> Int
1516 summaryNodeKey (_, k, _) = k
1517
1518 summaryNodeSummary :: SummaryNode -> ModSummary
1519 summaryNodeSummary (s, _, _) = s
1520
1521 moduleGraphNodes :: Bool -> [ModSummary]
1522 -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
1523 moduleGraphNodes drop_hs_boot_nodes summaries =
1524 (graphFromEdgedVerticesUniq nodes, lookup_node)
1525 where
1526 numbered_summaries = zip summaries [1..]
1527
1528 lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
1529 lookup_node hs_src mod = Map.lookup (mod, hscSourceToIsBoot hs_src) node_map
1530
1531 lookup_key :: HscSource -> ModuleName -> Maybe Int
1532 lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
1533
1534 node_map :: NodeMap SummaryNode
1535 node_map = Map.fromList [ ((moduleName (ms_mod s),
1536 hscSourceToIsBoot (ms_hsc_src s)), node)
1537 | node@(s, _, _) <- nodes ]
1538
1539 -- We use integers as the keys for the SCC algorithm
1540 nodes :: [SummaryNode]
1541 nodes = [ (s, key, out_keys)
1542 | (s, key) <- numbered_summaries
1543 -- Drop the hi-boot ones if told to do so
1544 , not (isBootSummary s && drop_hs_boot_nodes)
1545 , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++
1546 out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++
1547 (-- see [boot-edges] below
1548 if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
1549 then []
1550 else case lookup_key HsBootFile (ms_mod_name s) of
1551 Nothing -> []
1552 Just k -> [k]) ]
1553
1554 -- [boot-edges] if this is a .hs and there is an equivalent
1555 -- .hs-boot, add a link from the former to the latter. This
1556 -- has the effect of detecting bogus cases where the .hs-boot
1557 -- depends on the .hs, by introducing a cycle. Additionally,
1558 -- it ensures that we will always process the .hs-boot before
1559 -- the .hs, and so the HomePackageTable will always have the
1560 -- most up to date information.
1561
1562 -- Drop hs-boot nodes by using HsSrcFile as the key
1563 hs_boot_key | drop_hs_boot_nodes = HsSrcFile
1564 | otherwise = HsBootFile
1565
1566 out_edge_keys :: HscSource -> [ModuleName] -> [Int]
1567 out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms
1568 -- If we want keep_hi_boot_nodes, then we do lookup_key with
1569 -- IsBoot; else NotBoot
1570
1571 -- The nodes of the graph are keyed by (mod, is boot?) pairs
1572 -- NB: hsig files show up as *normal* nodes (not boot!), since they don't
1573 -- participate in cycles (for now)
1574 type NodeKey = (ModuleName, IsBoot)
1575 type NodeMap a = Map.Map NodeKey a
1576
1577 msKey :: ModSummary -> NodeKey
1578 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot })
1579 = (moduleName mod, hscSourceToIsBoot boot)
1580
1581 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
1582 mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]
1583
1584 nodeMapElts :: NodeMap a -> [a]
1585 nodeMapElts = Map.elems
1586
1587 -- | If there are {-# SOURCE #-} imports between strongly connected
1588 -- components in the topological sort, then those imports can
1589 -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
1590 -- were necessary, then the edge would be part of a cycle.
1591 warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
1592 warnUnnecessarySourceImports sccs = do
1593 dflags <- getDynFlags
1594 when (wopt Opt_WarnUnusedImports dflags)
1595 (logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs)))
1596 where check dflags ms =
1597 let mods_in_this_cycle = map ms_mod_name ms in
1598 [ warn dflags i | m <- ms, i <- ms_home_srcimps m,
1599 unLoc i `notElem` mods_in_this_cycle ]
1600
1601 warn :: DynFlags -> Located ModuleName -> WarnMsg
1602 warn dflags (L loc mod) =
1603 mkPlainErrMsg dflags loc
1604 (text "Warning: {-# SOURCE #-} unnecessary in import of "
1605 <+> quotes (ppr mod))
1606
1607
1608 reportImportErrors :: MonadIO m => [Either ErrMsg b] -> m [b]
1609 reportImportErrors xs | null errs = return oks
1610 | otherwise = throwManyErrors errs
1611 where (errs, oks) = partitionEithers xs
1612
1613 throwManyErrors :: MonadIO m => [ErrMsg] -> m ab
1614 throwManyErrors errs = liftIO $ throwIO $ mkSrcErr $ listToBag errs
1615
1616
1617 -----------------------------------------------------------------------------
1618 --
1619 -- | Downsweep (dependency analysis)
1620 --
1621 -- Chase downwards from the specified root set, returning summaries
1622 -- for all home modules encountered. Only follow source-import
1623 -- links.
1624 --
1625 -- We pass in the previous collection of summaries, which is used as a
1626 -- cache to avoid recalculating a module summary if the source is
1627 -- unchanged.
1628 --
1629 -- The returned list of [ModSummary] nodes has one node for each home-package
1630 -- module, plus one for any hs-boot files. The imports of these nodes
1631 -- are all there, including the imports of non-home-package modules.
1632 downsweep :: HscEnv
1633 -> [ModSummary] -- Old summaries
1634 -> [ModuleName] -- Ignore dependencies on these; treat
1635 -- them as if they were package modules
1636 -> Bool -- True <=> allow multiple targets to have
1637 -- the same module name; this is
1638 -- very useful for ghc -M
1639 -> IO [Either ErrMsg ModSummary]
1640 -- The elts of [ModSummary] all have distinct
1641 -- (Modules, IsBoot) identifiers, unless the Bool is true
1642 -- in which case there can be repeats
1643 downsweep hsc_env old_summaries excl_mods allow_dup_roots
1644 = do
1645 rootSummaries <- mapM getRootSummary roots
1646 rootSummariesOk <- reportImportErrors rootSummaries
1647 let root_map = mkRootMap rootSummariesOk
1648 checkDuplicates root_map
1649 summs <- loop (concatMap calcDeps rootSummariesOk) root_map
1650 return summs
1651 where
1652 -- When we're compiling a signature file, we have an implicit
1653 -- dependency on what-ever the signature's implementation is.
1654 -- (But not when we're type checking!)
1655 calcDeps summ
1656 | HsigFile <- ms_hsc_src summ
1657 , Just m <- getSigOf (hsc_dflags hsc_env) (moduleName (ms_mod summ))
1658 , moduleUnitId m == thisPackage (hsc_dflags hsc_env)
1659 = (noLoc (moduleName m), NotBoot) : msDeps summ
1660 | otherwise = msDeps summ
1661
1662 dflags = hsc_dflags hsc_env
1663 roots = hsc_targets hsc_env
1664
1665 old_summary_map :: NodeMap ModSummary
1666 old_summary_map = mkNodeMap old_summaries
1667
1668 getRootSummary :: Target -> IO (Either ErrMsg ModSummary)
1669 getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
1670 = do exists <- liftIO $ doesFileExist file
1671 if exists
1672 then Right `fmap` summariseFile hsc_env old_summaries file mb_phase
1673 obj_allowed maybe_buf
1674 else return $ Left $ mkPlainErrMsg dflags noSrcSpan $
1675 text "can't find file:" <+> text file
1676 getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
1677 = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot
1678 (L rootLoc modl) obj_allowed
1679 maybe_buf excl_mods
1680 case maybe_summary of
1681 Nothing -> return $ Left $ packageModErr dflags modl
1682 Just s -> return s
1683
1684 rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
1685
1686 -- In a root module, the filename is allowed to diverge from the module
1687 -- name, so we have to check that there aren't multiple root files
1688 -- defining the same module (otherwise the duplicates will be silently
1689 -- ignored, leading to confusing behaviour).
1690 checkDuplicates :: NodeMap [Either ErrMsg ModSummary] -> IO ()
1691 checkDuplicates root_map
1692 | allow_dup_roots = return ()
1693 | null dup_roots = return ()
1694 | otherwise = liftIO $ multiRootsErr dflags (head dup_roots)
1695 where
1696 dup_roots :: [[ModSummary]] -- Each at least of length 2
1697 dup_roots = filterOut isSingleton $ map rights $ nodeMapElts root_map
1698
1699 loop :: [(Located ModuleName,IsBoot)]
1700 -- Work list: process these modules
1701 -> NodeMap [Either ErrMsg ModSummary]
1702 -- Visited set; the range is a list because
1703 -- the roots can have the same module names
1704 -- if allow_dup_roots is True
1705 -> IO [Either ErrMsg ModSummary]
1706 -- The result includes the worklist, except
1707 -- for those mentioned in the visited set
1708 loop [] done = return (concat (nodeMapElts done))
1709 loop ((wanted_mod, is_boot) : ss) done
1710 | Just summs <- Map.lookup key done
1711 = if isSingleton summs then
1712 loop ss done
1713 else
1714 do { multiRootsErr dflags (rights summs); return [] }
1715 | otherwise
1716 = do mb_s <- summariseModule hsc_env old_summary_map
1717 is_boot wanted_mod True
1718 Nothing excl_mods
1719 case mb_s of
1720 Nothing -> loop ss done
1721 Just (Left e) -> loop ss (Map.insert key [Left e] done)
1722 Just (Right s)-> loop (calcDeps s ++ ss)
1723 (Map.insert key [Right s] done)
1724 where
1725 key = (unLoc wanted_mod, is_boot)
1726
1727 mkRootMap :: [ModSummary] -> NodeMap [Either ErrMsg ModSummary]
1728 mkRootMap summaries = Map.insertListWith (flip (++))
1729 [ (msKey s, [Right s]) | s <- summaries ]
1730 Map.empty
1731
1732 -- | Returns the dependencies of the ModSummary s.
1733 -- A wrinkle is that for a {-# SOURCE #-} import we return
1734 -- *both* the hs-boot file
1735 -- *and* the source file
1736 -- as "dependencies". That ensures that the list of all relevant
1737 -- modules always contains B.hs if it contains B.hs-boot.
1738 -- Remember, this pass isn't doing the topological sort. It's
1739 -- just gathering the list of all relevant ModSummaries
1740 msDeps :: ModSummary -> [(Located ModuleName, IsBoot)]
1741 msDeps s =
1742 concat [ [(m,IsBoot), (m,NotBoot)] | m <- ms_home_srcimps s ]
1743 ++ [ (m,NotBoot) | m <- ms_home_imps s ]
1744
1745 home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]
1746 home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps,
1747 isLocal mb_pkg ]
1748 where isLocal Nothing = True
1749 isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
1750 isLocal _ = False
1751
1752 ms_home_allimps :: ModSummary -> [ModuleName]
1753 ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)
1754
1755 -- | Like 'ms_home_imps', but for SOURCE imports.
1756 ms_home_srcimps :: ModSummary -> [Located ModuleName]
1757 ms_home_srcimps = home_imps . ms_srcimps
1758
1759 -- | All of the (possibly) home module imports from a
1760 -- 'ModSummary'; that is to say, each of these module names
1761 -- could be a home import if an appropriately named file
1762 -- existed. (This is in contrast to package qualified
1763 -- imports, which are guaranteed not to be home imports.)
1764 ms_home_imps :: ModSummary -> [Located ModuleName]
1765 ms_home_imps = home_imps . ms_imps
1766
1767 -----------------------------------------------------------------------------
1768 -- Summarising modules
1769
1770 -- We have two types of summarisation:
1771 --
1772 -- * Summarise a file. This is used for the root module(s) passed to
1773 -- cmLoadModules. The file is read, and used to determine the root
1774 -- module name. The module name may differ from the filename.
1775 --
1776 -- * Summarise a module. We are given a module name, and must provide
1777 -- a summary. The finder is used to locate the file in which the module
1778 -- resides.
1779
1780 summariseFile
1781 :: HscEnv
1782 -> [ModSummary] -- old summaries
1783 -> FilePath -- source file name
1784 -> Maybe Phase -- start phase
1785 -> Bool -- object code allowed?
1786 -> Maybe (StringBuffer,UTCTime)
1787 -> IO ModSummary
1788
1789 summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
1790 -- we can use a cached summary if one is available and the
1791 -- source file hasn't changed, But we have to look up the summary
1792 -- by source file, rather than module name as we do in summarise.
1793 | Just old_summary <- findSummaryBySourceFile old_summaries file
1794 = do
1795 let location = ms_location old_summary
1796 dflags = hsc_dflags hsc_env
1797
1798 src_timestamp <- get_src_timestamp
1799 -- The file exists; we checked in getRootSummary above.
1800 -- If it gets removed subsequently, then this
1801 -- getModificationUTCTime may fail, but that's the right
1802 -- behaviour.
1803
1804 -- return the cached summary if the source didn't change
1805 if ms_hs_date old_summary == src_timestamp &&
1806 not (gopt Opt_ForceRecomp (hsc_dflags hsc_env))
1807 then do -- update the object-file timestamp
1808 obj_timestamp <-
1809 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
1810 || obj_allowed -- bug #1205
1811 then liftIO $ getObjTimestamp location NotBoot
1812 else return Nothing
1813 hi_timestamp <- maybeGetIfaceDate dflags location
1814 return old_summary{ ms_obj_date = obj_timestamp
1815 , ms_iface_date = hi_timestamp }
1816 else
1817 new_summary src_timestamp
1818
1819 | otherwise
1820 = do src_timestamp <- get_src_timestamp
1821 new_summary src_timestamp
1822 where
1823 get_src_timestamp = case maybe_buf of
1824 Just (_,t) -> return t
1825 Nothing -> liftIO $ getModificationUTCTime file
1826 -- getMofificationUTCTime may fail
1827
1828 new_summary src_timestamp = do
1829 let dflags = hsc_dflags hsc_env
1830
1831 let hsc_src = if isHaskellSigFilename file then HsigFile else HsSrcFile
1832
1833 (dflags', hspp_fn, buf)
1834 <- preprocessFile hsc_env file mb_phase maybe_buf
1835
1836 (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
1837
1838 -- Make a ModLocation for this file
1839 location <- liftIO $ mkHomeModLocation dflags mod_name file
1840
1841 -- Tell the Finder cache where it is, so that subsequent calls
1842 -- to findModule will find it, even if it's not on any search path
1843 mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
1844
1845 -- when the user asks to load a source file by name, we only
1846 -- use an object file if -fobject-code is on. See #1205.
1847 obj_timestamp <-
1848 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
1849 || obj_allowed -- bug #1205
1850 then liftIO $ modificationTimeIfExists (ml_obj_file location)
1851 else return Nothing
1852
1853 hi_timestamp <- maybeGetIfaceDate dflags location
1854
1855 return (ModSummary { ms_mod = mod, ms_hsc_src = hsc_src,
1856 ms_location = location,
1857 ms_hspp_file = hspp_fn,
1858 ms_hspp_opts = dflags',
1859 ms_hspp_buf = Just buf,
1860 ms_srcimps = srcimps, ms_textual_imps = the_imps,
1861 ms_hs_date = src_timestamp,
1862 ms_iface_date = hi_timestamp,
1863 ms_obj_date = obj_timestamp })
1864
1865 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
1866 findSummaryBySourceFile summaries file
1867 = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
1868 expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
1869 [] -> Nothing
1870 (x:_) -> Just x
1871
1872 -- Summarise a module, and pick up source and timestamp.
1873 summariseModule
1874 :: HscEnv
1875 -> NodeMap ModSummary -- Map of old summaries
1876 -> IsBoot -- IsBoot <=> a {-# SOURCE #-} import
1877 -> Located ModuleName -- Imported module to be summarised
1878 -> Bool -- object code allowed?
1879 -> Maybe (StringBuffer, UTCTime)
1880 -> [ModuleName] -- Modules to exclude
1881 -> IO (Maybe (Either ErrMsg ModSummary)) -- Its new summary
1882
1883 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
1884 obj_allowed maybe_buf excl_mods
1885 | wanted_mod `elem` excl_mods
1886 = return Nothing
1887
1888 | Just old_summary <- Map.lookup (wanted_mod, is_boot) old_summary_map
1889 = do -- Find its new timestamp; all the
1890 -- ModSummaries in the old map have valid ml_hs_files
1891 let location = ms_location old_summary
1892 src_fn = expectJust "summariseModule" (ml_hs_file location)
1893
1894 -- check the modification time on the source file, and
1895 -- return the cached summary if it hasn't changed. If the
1896 -- file has disappeared, we need to call the Finder again.
1897 case maybe_buf of
1898 Just (_,t) -> check_timestamp old_summary location src_fn t
1899 Nothing -> do
1900 m <- tryIO (getModificationUTCTime src_fn)
1901 case m of
1902 Right t -> check_timestamp old_summary location src_fn t
1903 Left e | isDoesNotExistError e -> find_it
1904 | otherwise -> ioError e
1905
1906 | otherwise = find_it
1907 where
1908 dflags = hsc_dflags hsc_env
1909
1910 check_timestamp old_summary location src_fn src_timestamp
1911 | ms_hs_date old_summary == src_timestamp &&
1912 not (gopt Opt_ForceRecomp dflags) = do
1913 -- update the object-file timestamp
1914 obj_timestamp <-
1915 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
1916 || obj_allowed -- bug #1205
1917 then getObjTimestamp location is_boot
1918 else return Nothing
1919 hi_timestamp <- maybeGetIfaceDate dflags location
1920 return (Just (Right old_summary{ ms_obj_date = obj_timestamp
1921 , ms_iface_date = hi_timestamp}))
1922 | otherwise =
1923 -- source changed: re-summarise.
1924 new_summary location (ms_mod old_summary) src_fn src_timestamp
1925
1926 find_it = do
1927 -- Don't use the Finder's cache this time. If the module was
1928 -- previously a package module, it may have now appeared on the
1929 -- search path, so we want to consider it to be a home module. If
1930 -- the module was previously a home module, it may have moved.
1931 uncacheModule hsc_env wanted_mod
1932 found <- findImportedModule hsc_env wanted_mod Nothing
1933 case found of
1934 Found location mod
1935 | isJust (ml_hs_file location) ->
1936 -- Home package
1937 just_found location mod
1938
1939 _ -> return Nothing
1940 -- Not found
1941 -- (If it is TRULY not found at all, we'll
1942 -- error when we actually try to compile)
1943
1944 just_found location mod = do
1945 -- Adjust location to point to the hs-boot source file,
1946 -- hi file, object file, when is_boot says so
1947 let location' | IsBoot <- is_boot = addBootSuffixLocn location
1948 | otherwise = location
1949 src_fn = expectJust "summarise2" (ml_hs_file location')
1950
1951 -- Check that it exists
1952 -- It might have been deleted since the Finder last found it
1953 maybe_t <- modificationTimeIfExists src_fn
1954 case maybe_t of
1955 Nothing -> return $ Just $ Left $ noHsFileErr dflags loc src_fn
1956 Just t -> new_summary location' mod src_fn t
1957
1958
1959 new_summary location mod src_fn src_timestamp
1960 = do
1961 -- Preprocess the source file and get its imports
1962 -- The dflags' contains the OPTIONS pragmas
1963 (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
1964 (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
1965
1966 -- NB: Despite the fact that is_boot is a top-level parameter, we
1967 -- don't actually know coming into this function what the HscSource
1968 -- of the module in question is. This is because we may be processing
1969 -- this module because another module in the graph imported it: in this
1970 -- case, we know if it's a boot or not because of the {-# SOURCE #-}
1971 -- annotation, but we don't know if it's a signature or a regular
1972 -- module until we actually look it up on the filesystem.
1973 let hsc_src = case is_boot of
1974 IsBoot -> HsBootFile
1975 _ | isHaskellSigFilename src_fn -> HsigFile
1976 | otherwise -> HsSrcFile
1977
1978 when (mod_name /= wanted_mod) $
1979 throwOneError $ mkPlainErrMsg dflags' mod_loc $
1980 text "File name does not match module name:"
1981 $$ text "Saw:" <+> quotes (ppr mod_name)
1982 $$ text "Expected:" <+> quotes (ppr wanted_mod)
1983
1984 -- Find the object timestamp, and return the summary
1985 obj_timestamp <-
1986 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
1987 || obj_allowed -- bug #1205
1988 then getObjTimestamp location is_boot
1989 else return Nothing
1990
1991 hi_timestamp <- maybeGetIfaceDate dflags location
1992
1993 return (Just (Right (ModSummary { ms_mod = mod,
1994 ms_hsc_src = hsc_src,
1995 ms_location = location,
1996 ms_hspp_file = hspp_fn,
1997 ms_hspp_opts = dflags',
1998 ms_hspp_buf = Just buf,
1999 ms_srcimps = srcimps,
2000 ms_textual_imps = the_imps,
2001 ms_hs_date = src_timestamp,
2002 ms_iface_date = hi_timestamp,
2003 ms_obj_date = obj_timestamp })))
2004
2005
2006 getObjTimestamp :: ModLocation -> IsBoot -> IO (Maybe UTCTime)
2007 getObjTimestamp location is_boot
2008 = if is_boot == IsBoot then return Nothing
2009 else modificationTimeIfExists (ml_obj_file location)
2010
2011
2012 preprocessFile :: HscEnv
2013 -> FilePath
2014 -> Maybe Phase -- ^ Starting phase
2015 -> Maybe (StringBuffer,UTCTime)
2016 -> IO (DynFlags, FilePath, StringBuffer)
2017 preprocessFile hsc_env src_fn mb_phase Nothing
2018 = do
2019 (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
2020 buf <- hGetStringBuffer hspp_fn
2021 return (dflags', hspp_fn, buf)
2022
2023 preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
2024 = do
2025 let dflags = hsc_dflags hsc_env
2026 let local_opts = getOptions dflags buf src_fn
2027
2028 (dflags', leftovers, warns)
2029 <- parseDynamicFilePragma dflags local_opts
2030 checkProcessArgsResult dflags leftovers
2031 handleFlagWarnings dflags' warns
2032
2033 let needs_preprocessing
2034 | Just (Unlit _) <- mb_phase = True
2035 | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
2036 -- note: local_opts is only required if there's no Unlit phase
2037 | xopt LangExt.Cpp dflags' = True
2038 | gopt Opt_Pp dflags' = True
2039 | otherwise = False
2040
2041 when needs_preprocessing $
2042 throwGhcExceptionIO (ProgramError "buffer needs preprocesing; interactive check disabled")
2043
2044 return (dflags', src_fn, buf)
2045
2046
2047 -----------------------------------------------------------------------------
2048 -- Error messages
2049 -----------------------------------------------------------------------------
2050
2051 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg
2052 -- ToDo: we don't have a proper line number for this error
2053 noModError dflags loc wanted_mod err
2054 = mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err
2055
2056 noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrMsg
2057 noHsFileErr dflags loc path
2058 = mkPlainErrMsg dflags loc $ text "Can't find" <+> text path
2059
2060 packageModErr :: DynFlags -> ModuleName -> ErrMsg
2061 packageModErr dflags mod
2062 = mkPlainErrMsg dflags noSrcSpan $
2063 text "module" <+> quotes (ppr mod) <+> text "is a package module"
2064
2065 multiRootsErr :: DynFlags -> [ModSummary] -> IO ()
2066 multiRootsErr _ [] = panic "multiRootsErr"
2067 multiRootsErr dflags summs@(summ1:_)
2068 = throwOneError $ mkPlainErrMsg dflags noSrcSpan $
2069 text "module" <+> quotes (ppr mod) <+>
2070 text "is defined in multiple files:" <+>
2071 sep (map text files)
2072 where
2073 mod = ms_mod summ1
2074 files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
2075
2076 cyclicModuleErr :: [ModSummary] -> SDoc
2077 -- From a strongly connected component we find
2078 -- a single cycle to report
2079 cyclicModuleErr mss
2080 = ASSERT( not (null mss) )
2081 case findCycle graph of
2082 Nothing -> text "Unexpected non-cycle" <+> ppr mss
2083 Just path -> vcat [ text "Module imports form a cycle:"
2084 , nest 2 (show_path path) ]
2085 where
2086 graph :: [Node NodeKey ModSummary]
2087 graph = [(ms, msKey ms, get_deps ms) | ms <- mss]
2088
2089 get_deps :: ModSummary -> [NodeKey]
2090 get_deps ms = ([ (unLoc m, IsBoot) | m <- ms_home_srcimps ms ] ++
2091 [ (unLoc m, NotBoot) | m <- ms_home_imps ms ])
2092
2093 show_path [] = panic "show_path"
2094 show_path [m] = text "module" <+> ppr_ms m
2095 <+> text "imports itself"
2096 show_path (m1:m2:ms) = vcat ( nest 7 (text "module" <+> ppr_ms m1)
2097 : nest 6 (text "imports" <+> ppr_ms m2)
2098 : go ms )
2099 where
2100 go [] = [text "which imports" <+> ppr_ms m1]
2101 go (m:ms) = (text "which imports" <+> ppr_ms m) : go ms
2102
2103
2104 ppr_ms :: ModSummary -> SDoc
2105 ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>
2106 (parens (text (msHsFilePath ms)))