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