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