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