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