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