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