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