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