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