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