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