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