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