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