GHCi: add :seti, for options that apply only at the prompt (#3217)
[ghc.git] / compiler / main / GhcMake.hs
1 {-# LANGUAGE ScopedTypeVariables #-}
2
3 -- -----------------------------------------------------------------------------
4 --
5 -- (c) The University of Glasgow, 2011
6 --
7 -- This module implements multi-module compilation, and is used
8 -- by --make and GHCi.
9 --
10 -- -----------------------------------------------------------------------------
11
12 {-# OPTIONS -fno-warn-tabs #-}
13 -- The above warning supression flag is a temporary kludge.
14 -- While working on this module you are encouraged to remove it and
15 -- detab the module (please do the detabbing in a separate patch). See
16 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
17 -- for details
18
19 module GhcMake(
20 depanal,
21 load, LoadHowMuch(..),
22
23 topSortModuleGraph,
24
25 noModError, cyclicModuleErr
26 ) where
27
28 #include "HsVersions.h"
29
30 #ifdef GHCI
31 import qualified Linker ( unload )
32 #endif
33
34 import DriverPipeline
35 import DriverPhases
36 import GhcMonad
37 import Module
38 import HscTypes
39 import ErrUtils
40 import DynFlags
41 import HsSyn
42 import Finder
43 import HeaderInfo
44 import TcIface ( typecheckIface )
45 import TcRnMonad ( initIfaceCheck )
46 import RdrName ( RdrName )
47
48 import Exception ( evaluate, tryIO )
49 import Panic
50 import SysTools
51 import BasicTypes
52 import SrcLoc
53 import Util
54 import Digraph
55 import Bag ( listToBag )
56 import Maybes ( expectJust, mapCatMaybes )
57 import StringBuffer
58 import FastString
59 import Outputable
60 import UniqFM
61
62 import qualified Data.Map as Map
63 import qualified FiniteMap as Map( insertListWith)
64
65 import System.Directory
66 import System.IO ( fixIO )
67 import System.IO.Error ( isDoesNotExistError )
68 import System.FilePath
69 import Control.Monad
70 import Data.Maybe
71 import Data.List
72 import qualified Data.List as List
73 import Data.Time
74
75 -- -----------------------------------------------------------------------------
76 -- Loading the program
77
78 -- | Perform a dependency analysis starting from the current targets
79 -- and update the session with the new module graph.
80 --
81 -- Dependency analysis entails parsing the @import@ directives and may
82 -- therefore require running certain preprocessors.
83 --
84 -- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.
85 -- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the
86 -- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want to
87 -- changes to the 'DynFlags' to take effect you need to call this function
88 -- again.
89 --
90 depanal :: GhcMonad m =>
91 [ModuleName] -- ^ excluded modules
92 -> Bool -- ^ allow duplicate roots
93 -> m ModuleGraph
94 depanal excluded_mods allow_dup_roots = do
95 hsc_env <- getSession
96 let
97 dflags = hsc_dflags hsc_env
98 targets = hsc_targets hsc_env
99 old_graph = hsc_mod_graph hsc_env
100
101 liftIO $ showPass dflags "Chasing dependencies"
102 liftIO $ debugTraceMsg dflags 2 (hcat [
103 text "Chasing modules from: ",
104 hcat (punctuate comma (map pprTarget targets))])
105
106 mod_graph <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots
107 modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph }
108 return mod_graph
109
110 -- | Describes which modules of the module graph need to be loaded.
111 data LoadHowMuch
112 = LoadAllTargets
113 -- ^ Load all targets and its dependencies.
114 | LoadUpTo ModuleName
115 -- ^ Load only the given module and its dependencies.
116 | LoadDependenciesOf ModuleName
117 -- ^ Load only the dependencies of the given module, but not the module
118 -- itself.
119
120 -- | Try to load the program. See 'LoadHowMuch' for the different modes.
121 --
122 -- This function implements the core of GHC's @--make@ mode. It preprocesses,
123 -- compiles and loads the specified modules, avoiding re-compilation wherever
124 -- possible. Depending on the target (see 'DynFlags.hscTarget') compilating
125 -- and loading may result in files being created on disk.
126 --
127 -- Calls the 'reportModuleCompilationResult' callback after each compiling
128 -- each module, whether successful or not.
129 --
130 -- Throw a 'SourceError' if errors are encountered before the actual
131 -- compilation starts (e.g., during dependency analysis). All other errors
132 -- are reported using the callback.
133 --
134 load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
135 load how_much = do
136 mod_graph <- depanal [] False
137 load2 how_much mod_graph
138
139 load2 :: GhcMonad m => LoadHowMuch -> [ModSummary]
140 -> m SuccessFlag
141 load2 how_much mod_graph = do
142 guessOutputFile
143 hsc_env <- getSession
144
145 let hpt1 = hsc_HPT hsc_env
146 let dflags = hsc_dflags hsc_env
147
148 -- The "bad" boot modules are the ones for which we have
149 -- B.hs-boot in the module graph, but no B.hs
150 -- The downsweep should have ensured this does not happen
151 -- (see msDeps)
152 let all_home_mods = [ms_mod_name s
153 | s <- mod_graph, not (isBootSummary s)]
154 bad_boot_mods = [s | s <- mod_graph, isBootSummary s,
155 not (ms_mod_name s `elem` all_home_mods)]
156 ASSERT( null bad_boot_mods ) return ()
157
158 -- check that the module given in HowMuch actually exists, otherwise
159 -- topSortModuleGraph will bomb later.
160 let checkHowMuch (LoadUpTo m) = checkMod m
161 checkHowMuch (LoadDependenciesOf m) = checkMod m
162 checkHowMuch _ = id
163
164 checkMod m and_then
165 | m `elem` all_home_mods = and_then
166 | otherwise = do
167 liftIO $ errorMsg dflags (text "no such module:" <+>
168 quotes (ppr m))
169 return Failed
170
171 checkHowMuch how_much $ do
172
173 -- mg2_with_srcimps drops the hi-boot nodes, returning a
174 -- graph with cycles. Among other things, it is used for
175 -- backing out partially complete cycles following a failed
176 -- upsweep, and for removing from hpt all the modules
177 -- not in strict downwards closure, during calls to compile.
178 let mg2_with_srcimps :: [SCC ModSummary]
179 mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
180
181 -- If we can determine that any of the {-# SOURCE #-} imports
182 -- are definitely unnecessary, then emit a warning.
183 warnUnnecessarySourceImports mg2_with_srcimps
184
185 let
186 -- check the stability property for each module.
187 stable_mods@(stable_obj,stable_bco)
188 = checkStability hpt1 mg2_with_srcimps all_home_mods
189
190 -- prune bits of the HPT which are definitely redundant now,
191 -- to save space.
192 pruned_hpt = pruneHomePackageTable hpt1
193 (flattenSCCs mg2_with_srcimps)
194 stable_mods
195
196 _ <- liftIO $ evaluate pruned_hpt
197
198 -- before we unload anything, make sure we don't leave an old
199 -- interactive context around pointing to dead bindings. Also,
200 -- write the pruned HPT to allow the old HPT to be GC'd.
201 modifySession $ \_ -> discardIC $ hsc_env { hsc_HPT = pruned_hpt }
202
203 liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
204 text "Stable BCO:" <+> ppr stable_bco)
205
206 -- Unload any modules which are going to be re-linked this time around.
207 let stable_linkables = [ linkable
208 | m <- stable_obj++stable_bco,
209 Just hmi <- [lookupUFM pruned_hpt m],
210 Just linkable <- [hm_linkable hmi] ]
211 liftIO $ unload hsc_env stable_linkables
212
213 -- We could at this point detect cycles which aren't broken by
214 -- a source-import, and complain immediately, but it seems better
215 -- to let upsweep_mods do this, so at least some useful work gets
216 -- done before the upsweep is abandoned.
217 --hPutStrLn stderr "after tsort:\n"
218 --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
219
220 -- Now do the upsweep, calling compile for each module in
221 -- turn. Final result is version 3 of everything.
222
223 -- Topologically sort the module graph, this time including hi-boot
224 -- nodes, and possibly just including the portion of the graph
225 -- reachable from the module specified in the 2nd argument to load.
226 -- This graph should be cycle-free.
227 -- If we're restricting the upsweep to a portion of the graph, we
228 -- also want to retain everything that is still stable.
229 let full_mg :: [SCC ModSummary]
230 full_mg = topSortModuleGraph False mod_graph Nothing
231
232 maybe_top_mod = case how_much of
233 LoadUpTo m -> Just m
234 LoadDependenciesOf m -> Just m
235 _ -> Nothing
236
237 partial_mg0 :: [SCC ModSummary]
238 partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
239
240 -- LoadDependenciesOf m: we want the upsweep to stop just
241 -- short of the specified module (unless the specified module
242 -- is stable).
243 partial_mg
244 | LoadDependenciesOf _mod <- how_much
245 = ASSERT( case last partial_mg0 of
246 AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )
247 List.init partial_mg0
248 | otherwise
249 = partial_mg0
250
251 stable_mg =
252 [ AcyclicSCC ms
253 | AcyclicSCC ms <- full_mg,
254 ms_mod_name ms `elem` stable_obj++stable_bco,
255 ms_mod_name ms `notElem` [ ms_mod_name ms' |
256 AcyclicSCC ms' <- partial_mg ] ]
257
258 mg = stable_mg ++ partial_mg
259
260 -- clean up between compilations
261 let cleanup hsc_env = intermediateCleanTempFiles dflags
262 (flattenSCCs mg2_with_srcimps)
263 hsc_env
264
265 liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
266 2 (ppr mg))
267
268 setSession hsc_env{ hsc_HPT = emptyHomePackageTable }
269 (upsweep_ok, modsUpswept)
270 <- upsweep pruned_hpt stable_mods cleanup mg
271
272 -- Make modsDone be the summaries for each home module now
273 -- available; this should equal the domain of hpt3.
274 -- Get in in a roughly top .. bottom order (hence reverse).
275
276 let modsDone = reverse modsUpswept
277
278 -- Try and do linking in some form, depending on whether the
279 -- upsweep was completely or only partially successful.
280
281 if succeeded upsweep_ok
282
283 then
284 -- Easy; just relink it all.
285 do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")
286
287 -- Clean up after ourselves
288 hsc_env1 <- getSession
289 liftIO $ intermediateCleanTempFiles dflags modsDone hsc_env1
290
291 -- Issue a warning for the confusing case where the user
292 -- said '-o foo' but we're not going to do any linking.
293 -- We attempt linking if either (a) one of the modules is
294 -- called Main, or (b) the user said -no-hs-main, indicating
295 -- that main() is going to come from somewhere else.
296 --
297 let ofile = outputFile dflags
298 let no_hs_main = dopt Opt_NoHsMain dflags
299 let
300 main_mod = mainModIs dflags
301 a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
302 do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib
303
304 when (ghcLink dflags == LinkBinary
305 && isJust ofile && not do_linking) $
306 liftIO $ debugTraceMsg dflags 1 $
307 text ("Warning: output was redirected with -o, " ++
308 "but no output will be generated\n" ++
309 "because there is no " ++
310 moduleNameString (moduleName main_mod) ++ " module.")
311
312 -- link everything together
313 linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
314
315 loadFinish Succeeded linkresult
316
317 else
318 -- Tricky. We need to back out the effects of compiling any
319 -- half-done cycles, both so as to clean up the top level envs
320 -- and to avoid telling the interactive linker to link them.
321 do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")
322
323 let modsDone_names
324 = map ms_mod modsDone
325 let mods_to_zap_names
326 = findPartiallyCompletedCycles modsDone_names
327 mg2_with_srcimps
328 let mods_to_keep
329 = filter ((`notElem` mods_to_zap_names).ms_mod)
330 modsDone
331
332 hsc_env1 <- getSession
333 let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
334 (hsc_HPT hsc_env1)
335
336 -- Clean up after ourselves
337 liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1
338
339 -- there should be no Nothings where linkables should be, now
340 ASSERT(all (isJust.hm_linkable)
341 (eltsUFM (hsc_HPT hsc_env))) do
342
343 -- Link everything together
344 linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4
345
346 modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 }
347 loadFinish Failed linkresult
348
349 -- Finish up after a load.
350
351 -- If the link failed, unload everything and return.
352 loadFinish :: GhcMonad m =>
353 SuccessFlag -> SuccessFlag
354 -> m SuccessFlag
355 loadFinish _all_ok Failed
356 = do hsc_env <- getSession
357 liftIO $ unload hsc_env []
358 modifySession discardProg
359 return Failed
360
361 -- Empty the interactive context and set the module context to the topmost
362 -- newly loaded module, or the Prelude if none were loaded.
363 loadFinish all_ok Succeeded
364 = do modifySession discardIC
365 return all_ok
366
367
368 -- Forget the current program, but retain the persistent info in HscEnv
369 discardProg :: HscEnv -> HscEnv
370 discardProg hsc_env
371 = discardIC $ hsc_env { hsc_mod_graph = emptyMG
372 , hsc_HPT = emptyHomePackageTable }
373
374 -- discard the contents of the InteractiveContext, but keep the DynFlags
375 discardIC :: HscEnv -> HscEnv
376 discardIC hsc_env
377 = hsc_env { hsc_IC = emptyInteractiveContext (ic_dflags (hsc_IC hsc_env)) }
378
379 intermediateCleanTempFiles :: DynFlags -> [ModSummary] -> HscEnv -> IO ()
380 intermediateCleanTempFiles dflags summaries hsc_env
381 = cleanTempFilesExcept dflags except
382 where
383 except =
384 -- Save preprocessed files. The preprocessed file *might* be
385 -- the same as the source file, but that doesn't do any
386 -- harm.
387 map ms_hspp_file summaries ++
388 -- Save object files for loaded modules. The point of this
389 -- is that we might have generated and compiled a stub C
390 -- file, and in the case of GHCi the object file will be a
391 -- temporary file which we must not remove because we need
392 -- to load/link it later.
393 hptObjs (hsc_HPT hsc_env)
394
395 -- | If there is no -o option, guess the name of target executable
396 -- by using top-level source file name as a base.
397 guessOutputFile :: GhcMonad m => m ()
398 guessOutputFile = modifySession $ \env ->
399 let dflags = hsc_dflags env
400 mod_graph = hsc_mod_graph env
401 mainModuleSrcPath :: Maybe String
402 mainModuleSrcPath = do
403 let isMain = (== mainModIs dflags) . ms_mod
404 [ms] <- return (filter isMain mod_graph)
405 ml_hs_file (ms_location ms)
406 name = fmap dropExtension mainModuleSrcPath
407
408 #if defined(mingw32_HOST_OS)
409 -- we must add the .exe extention unconditionally here, otherwise
410 -- when name has an extension of its own, the .exe extension will
411 -- not be added by DriverPipeline.exeFileName. See #2248
412 name_exe = fmap (<.> "exe") name
413 #else
414 name_exe = name
415 #endif
416 in
417 case outputFile dflags of
418 Just _ -> env
419 Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }
420
421 -- -----------------------------------------------------------------------------
422
423 -- | Prune the HomePackageTable
424 --
425 -- Before doing an upsweep, we can throw away:
426 --
427 -- - For non-stable modules:
428 -- - all ModDetails, all linked code
429 -- - all unlinked code that is out of date with respect to
430 -- the source file
431 --
432 -- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
433 -- space at the end of the upsweep, because the topmost ModDetails of the
434 -- old HPT holds on to the entire type environment from the previous
435 -- compilation.
436
437 pruneHomePackageTable
438 :: HomePackageTable
439 -> [ModSummary]
440 -> ([ModuleName],[ModuleName])
441 -> HomePackageTable
442
443 pruneHomePackageTable hpt summ (stable_obj, stable_bco)
444 = mapUFM prune hpt
445 where prune hmi
446 | is_stable modl = hmi'
447 | otherwise = hmi'{ hm_details = emptyModDetails }
448 where
449 modl = moduleName (mi_module (hm_iface hmi))
450 hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
451 = hmi{ hm_linkable = Nothing }
452 | otherwise
453 = hmi
454 where ms = expectJust "prune" (lookupUFM ms_map modl)
455
456 ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
457
458 is_stable m = m `elem` stable_obj || m `elem` stable_bco
459
460 -- -----------------------------------------------------------------------------
461
462 -- Return (names of) all those in modsDone who are part of a cycle
463 -- as defined by theGraph.
464 findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
465 findPartiallyCompletedCycles modsDone theGraph
466 = chew theGraph
467 where
468 chew [] = []
469 chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting.
470 chew ((CyclicSCC vs):rest)
471 = let names_in_this_cycle = nub (map ms_mod vs)
472 mods_in_this_cycle
473 = nub ([done | done <- modsDone,
474 done `elem` names_in_this_cycle])
475 chewed_rest = chew rest
476 in
477 if notNull mods_in_this_cycle
478 && length mods_in_this_cycle < length names_in_this_cycle
479 then mods_in_this_cycle ++ chewed_rest
480 else chewed_rest
481
482
483 -- ---------------------------------------------------------------------------
484 -- Unloading
485
486 unload :: HscEnv -> [Linkable] -> IO ()
487 unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
488 = case ghcLink (hsc_dflags hsc_env) of
489 #ifdef GHCI
490 LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables
491 #else
492 LinkInMemory -> panic "unload: no interpreter"
493 -- urgh. avoid warnings:
494 hsc_env stable_linkables
495 #endif
496 _other -> return ()
497
498 -- -----------------------------------------------------------------------------
499
500 {- |
501
502 Stability tells us which modules definitely do not need to be recompiled.
503 There are two main reasons for having stability:
504
505 - avoid doing a complete upsweep of the module graph in GHCi when
506 modules near the bottom of the tree have not changed.
507
508 - to tell GHCi when it can load object code: we can only load object code
509 for a module when we also load object code fo all of the imports of the
510 module. So we need to know that we will definitely not be recompiling
511 any of these modules, and we can use the object code.
512
513 The stability check is as follows. Both stableObject and
514 stableBCO are used during the upsweep phase later.
515
516 @
517 stable m = stableObject m || stableBCO m
518
519 stableObject m =
520 all stableObject (imports m)
521 && old linkable does not exist, or is == on-disk .o
522 && date(on-disk .o) > date(.hs)
523
524 stableBCO m =
525 all stable (imports m)
526 && date(BCO) > date(.hs)
527 @
528
529 These properties embody the following ideas:
530
531 - if a module is stable, then:
532
533 - if it has been compiled in a previous pass (present in HPT)
534 then it does not need to be compiled or re-linked.
535
536 - if it has not been compiled in a previous pass,
537 then we only need to read its .hi file from disk and
538 link it to produce a 'ModDetails'.
539
540 - if a modules is not stable, we will definitely be at least
541 re-linking, and possibly re-compiling it during the 'upsweep'.
542 All non-stable modules can (and should) therefore be unlinked
543 before the 'upsweep'.
544
545 - Note that objects are only considered stable if they only depend
546 on other objects. We can't link object code against byte code.
547 -}
548
549 checkStability
550 :: HomePackageTable -- HPT from last compilation
551 -> [SCC ModSummary] -- current module graph (cyclic)
552 -> [ModuleName] -- all home modules
553 -> ([ModuleName], -- stableObject
554 [ModuleName]) -- stableBCO
555
556 checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
557 where
558 checkSCC (stable_obj, stable_bco) scc0
559 | stableObjects = (scc_mods ++ stable_obj, stable_bco)
560 | stableBCOs = (stable_obj, scc_mods ++ stable_bco)
561 | otherwise = (stable_obj, stable_bco)
562 where
563 scc = flattenSCC scc0
564 scc_mods = map ms_mod_name scc
565 home_module m = m `elem` all_home_mods && m `notElem` scc_mods
566
567 scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))
568 -- all imports outside the current SCC, but in the home pkg
569
570 stable_obj_imps = map (`elem` stable_obj) scc_allimps
571 stable_bco_imps = map (`elem` stable_bco) scc_allimps
572
573 stableObjects =
574 and stable_obj_imps
575 && all object_ok scc
576
577 stableBCOs =
578 and (zipWith (||) stable_obj_imps stable_bco_imps)
579 && all bco_ok scc
580
581 object_ok ms
582 | Just t <- ms_obj_date ms = t >= ms_hs_date ms
583 && same_as_prev t
584 | otherwise = False
585 where
586 same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
587 Just hmi | Just l <- hm_linkable hmi
588 -> isObjectLinkable l && t == linkableTime l
589 _other -> True
590 -- why '>=' rather than '>' above? If the filesystem stores
591 -- times to the nearset second, we may occasionally find that
592 -- the object & source have the same modification time,
593 -- especially if the source was automatically generated
594 -- and compiled. Using >= is slightly unsafe, but it matches
595 -- make's behaviour.
596 --
597 -- But see #5527, where someone ran into this and it caused
598 -- a problem.
599
600 bco_ok ms
601 = case lookupUFM hpt (ms_mod_name ms) of
602 Just hmi | Just l <- hm_linkable hmi ->
603 not (isObjectLinkable l) &&
604 linkableTime l >= ms_hs_date ms
605 _other -> False
606
607 -- -----------------------------------------------------------------------------
608
609 -- | The upsweep
610 --
611 -- This is where we compile each module in the module graph, in a pass
612 -- from the bottom to the top of the graph.
613 --
614 -- There better had not be any cyclic groups here -- we check for them.
615
616 upsweep
617 :: GhcMonad m
618 => HomePackageTable -- ^ HPT from last time round (pruned)
619 -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)
620 -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files
621 -> [SCC ModSummary] -- ^ Mods to do (the worklist)
622 -> m (SuccessFlag,
623 [ModSummary])
624 -- ^ Returns:
625 --
626 -- 1. A flag whether the complete upsweep was successful.
627 -- 2. The 'HscEnv' in the monad has an updated HPT
628 -- 3. A list of modules which succeeded loading.
629
630 upsweep old_hpt stable_mods cleanup sccs = do
631 (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs)
632 return (res, reverse done)
633 where
634
635 upsweep' _old_hpt done
636 [] _ _
637 = return (Succeeded, done)
638
639 upsweep' _old_hpt done
640 (CyclicSCC ms:_) _ _
641 = do dflags <- getSessionDynFlags
642 liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
643 return (Failed, done)
644
645 upsweep' old_hpt done
646 (AcyclicSCC mod:mods) mod_index nmods
647 = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
648 -- show (map (moduleUserString.moduleName.mi_module.hm_iface)
649 -- (moduleEnvElts (hsc_HPT hsc_env)))
650 let logger _mod = defaultWarnErrLogger
651
652 hsc_env <- getSession
653
654 -- Remove unwanted tmp files between compilations
655 liftIO (cleanup hsc_env)
656
657 mb_mod_info
658 <- handleSourceError
659 (\err -> do logger mod (Just err); return Nothing) $ do
660 mod_info <- liftIO $ upsweep_mod hsc_env old_hpt stable_mods
661 mod mod_index nmods
662 logger mod Nothing -- log warnings
663 return (Just mod_info)
664
665 case mb_mod_info of
666 Nothing -> return (Failed, done)
667 Just mod_info -> do
668 let this_mod = ms_mod_name mod
669
670 -- Add new info to hsc_env
671 hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info
672 hsc_env1 = hsc_env { hsc_HPT = hpt1 }
673
674 -- Space-saving: delete the old HPT entry
675 -- for mod BUT if mod is a hs-boot
676 -- node, don't delete it. For the
677 -- interface, the HPT entry is probaby for the
678 -- main Haskell source file. Deleting it
679 -- would force the real module to be recompiled
680 -- every time.
681 old_hpt1 | isBootSummary mod = old_hpt
682 | otherwise = delFromUFM old_hpt this_mod
683
684 done' = mod:done
685
686 -- fixup our HomePackageTable after we've finished compiling
687 -- a mutually-recursive loop. See reTypecheckLoop, below.
688 hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done'
689 setSession hsc_env2
690
691 upsweep' old_hpt1 done' mods (mod_index+1) nmods
692
693 -- | Compile a single module. Always produce a Linkable for it if
694 -- successful. If no compilation happened, return the old Linkable.
695 upsweep_mod :: HscEnv
696 -> HomePackageTable
697 -> ([ModuleName],[ModuleName])
698 -> ModSummary
699 -> Int -- index of module
700 -> Int -- total number of modules
701 -> IO HomeModInfo
702
703 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
704 = let
705 this_mod_name = ms_mod_name summary
706 this_mod = ms_mod summary
707 mb_obj_date = ms_obj_date summary
708 obj_fn = ml_obj_file (ms_location summary)
709 hs_date = ms_hs_date summary
710
711 is_stable_obj = this_mod_name `elem` stable_obj
712 is_stable_bco = this_mod_name `elem` stable_bco
713
714 old_hmi = lookupUFM old_hpt this_mod_name
715
716 -- We're using the dflags for this module now, obtained by
717 -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
718 dflags = ms_hspp_opts summary
719 prevailing_target = hscTarget (hsc_dflags hsc_env)
720 local_target = hscTarget dflags
721
722 -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that
723 -- we don't do anything dodgy: these should only work to change
724 -- from -fvia-C to -fasm and vice-versa, otherwise we could
725 -- end up trying to link object code to byte code.
726 target = if prevailing_target /= local_target
727 && (not (isObjectTarget prevailing_target)
728 || not (isObjectTarget local_target))
729 then prevailing_target
730 else local_target
731
732 -- store the corrected hscTarget into the summary
733 summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }
734
735 -- The old interface is ok if
736 -- a) we're compiling a source file, and the old HPT
737 -- entry is for a source file
738 -- b) we're compiling a hs-boot file
739 -- Case (b) allows an hs-boot file to get the interface of its
740 -- real source file on the second iteration of the compilation
741 -- manager, but that does no harm. Otherwise the hs-boot file
742 -- will always be recompiled
743
744 mb_old_iface
745 = case old_hmi of
746 Nothing -> Nothing
747 Just hm_info | isBootSummary summary -> Just iface
748 | not (mi_boot iface) -> Just iface
749 | otherwise -> Nothing
750 where
751 iface = hm_iface hm_info
752
753 compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo
754 compile_it mb_linkable src_modified =
755 compile hsc_env summary' mod_index nmods
756 mb_old_iface mb_linkable src_modified
757
758 compile_it_discard_iface :: Maybe Linkable -> SourceModified
759 -> IO HomeModInfo
760 compile_it_discard_iface mb_linkable src_modified =
761 compile hsc_env summary' mod_index nmods
762 Nothing mb_linkable src_modified
763
764 -- With the HscNothing target we create empty linkables to avoid
765 -- recompilation. We have to detect these to recompile anyway if
766 -- the target changed since the last compile.
767 is_fake_linkable
768 | Just hmi <- old_hmi, Just l <- hm_linkable hmi =
769 null (linkableUnlinked l)
770 | otherwise =
771 -- we have no linkable, so it cannot be fake
772 False
773
774 implies False _ = True
775 implies True x = x
776
777 in
778 case () of
779 _
780 -- Regardless of whether we're generating object code or
781 -- byte code, we can always use an existing object file
782 -- if it is *stable* (see checkStability).
783 | is_stable_obj, Just hmi <- old_hmi -> do
784 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
785 (text "skipping stable obj mod:" <+> ppr this_mod_name)
786 return hmi
787 -- object is stable, and we have an entry in the
788 -- old HPT: nothing to do
789
790 | is_stable_obj, isNothing old_hmi -> do
791 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
792 (text "compiling stable on-disk mod:" <+> ppr this_mod_name)
793 linkable <- liftIO $ findObjectLinkable this_mod obj_fn
794 (expectJust "upsweep1" mb_obj_date)
795 compile_it (Just linkable) SourceUnmodifiedAndStable
796 -- object is stable, but we need to load the interface
797 -- off disk to make a HMI.
798
799 | not (isObjectTarget target), is_stable_bco,
800 (target /= HscNothing) `implies` not is_fake_linkable ->
801 ASSERT(isJust old_hmi) -- must be in the old_hpt
802 let Just hmi = old_hmi in do
803 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
804 (text "skipping stable BCO mod:" <+> ppr this_mod_name)
805 return hmi
806 -- BCO is stable: nothing to do
807
808 | not (isObjectTarget target),
809 Just hmi <- old_hmi,
810 Just l <- hm_linkable hmi,
811 not (isObjectLinkable l),
812 (target /= HscNothing) `implies` not is_fake_linkable,
813 linkableTime l >= ms_hs_date summary -> do
814 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
815 (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)
816 compile_it (Just l) SourceUnmodified
817 -- we have an old BCO that is up to date with respect
818 -- to the source: do a recompilation check as normal.
819
820 -- When generating object code, if there's an up-to-date
821 -- object file on the disk, then we can use it.
822 -- However, if the object file is new (compared to any
823 -- linkable we had from a previous compilation), then we
824 -- must discard any in-memory interface, because this
825 -- means the user has compiled the source file
826 -- separately and generated a new interface, that we must
827 -- read from the disk.
828 --
829 | isObjectTarget target,
830 Just obj_date <- mb_obj_date,
831 obj_date >= hs_date -> do
832 case old_hmi of
833 Just hmi
834 | Just l <- hm_linkable hmi,
835 isObjectLinkable l && linkableTime l == obj_date -> do
836 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
837 (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)
838 compile_it (Just l) SourceUnmodified
839 _otherwise -> do
840 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
841 (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)
842 linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
843 compile_it_discard_iface (Just linkable) SourceUnmodified
844
845 _otherwise -> do
846 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
847 (text "compiling mod:" <+> ppr this_mod_name)
848 compile_it Nothing SourceModified
849
850
851
852 -- Filter modules in the HPT
853 retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
854 retainInTopLevelEnvs keep_these hpt
855 = listToUFM [ (mod, expectJust "retain" mb_mod_info)
856 | mod <- keep_these
857 , let mb_mod_info = lookupUFM hpt mod
858 , isJust mb_mod_info ]
859
860 -- ---------------------------------------------------------------------------
861 -- Typecheck module loops
862
863 {-
864 See bug #930. This code fixes a long-standing bug in --make. The
865 problem is that when compiling the modules *inside* a loop, a data
866 type that is only defined at the top of the loop looks opaque; but
867 after the loop is done, the structure of the data type becomes
868 apparent.
869
870 The difficulty is then that two different bits of code have
871 different notions of what the data type looks like.
872
873 The idea is that after we compile a module which also has an .hs-boot
874 file, we re-generate the ModDetails for each of the modules that
875 depends on the .hs-boot file, so that everyone points to the proper
876 TyCons, Ids etc. defined by the real module, not the boot module.
877 Fortunately re-generating a ModDetails from a ModIface is easy: the
878 function TcIface.typecheckIface does exactly that.
879
880 Picking the modules to re-typecheck is slightly tricky. Starting from
881 the module graph consisting of the modules that have already been
882 compiled, we reverse the edges (so they point from the imported module
883 to the importing module), and depth-first-search from the .hs-boot
884 node. This gives us all the modules that depend transitively on the
885 .hs-boot module, and those are exactly the modules that we need to
886 re-typecheck.
887
888 Following this fix, GHC can compile itself with --make -O2.
889 -}
890
891 reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
892 reTypecheckLoop hsc_env ms graph
893 | not (isBootSummary ms) &&
894 any (\m -> ms_mod m == this_mod && isBootSummary m) graph
895 = do
896 let mss = reachableBackwards (ms_mod_name ms) graph
897 non_boot = filter (not.isBootSummary) mss
898 debugTraceMsg (hsc_dflags hsc_env) 2 $
899 text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot)
900 typecheckLoop hsc_env (map ms_mod_name non_boot)
901 | otherwise
902 = return hsc_env
903 where
904 this_mod = ms_mod ms
905
906 typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv
907 typecheckLoop hsc_env mods = do
908 new_hpt <-
909 fixIO $ \new_hpt -> do
910 let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }
911 mds <- initIfaceCheck new_hsc_env $
912 mapM (typecheckIface . hm_iface) hmis
913 let new_hpt = addListToUFM old_hpt
914 (zip mods [ hmi{ hm_details = details }
915 | (hmi,details) <- zip hmis mds ])
916 return new_hpt
917 return hsc_env{ hsc_HPT = new_hpt }
918 where
919 old_hpt = hsc_HPT hsc_env
920 hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods
921
922 reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
923 reachableBackwards mod summaries
924 = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]
925 where -- the rest just sets up the graph:
926 (graph, lookup_node) = moduleGraphNodes False summaries
927 root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
928
929 -- ---------------------------------------------------------------------------
930 -- Topological sort of the module graph
931
932 type SummaryNode = (ModSummary, Int, [Int])
933
934 topSortModuleGraph
935 :: Bool
936 -- ^ Drop hi-boot nodes? (see below)
937 -> [ModSummary]
938 -> Maybe ModuleName
939 -- ^ Root module name. If @Nothing@, use the full graph.
940 -> [SCC ModSummary]
941 -- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
942 -- The resulting list of strongly-connected-components is in topologically
943 -- sorted order, starting with the module(s) at the bottom of the
944 -- dependency graph (ie compile them first) and ending with the ones at
945 -- the top.
946 --
947 -- Drop hi-boot nodes (first boolean arg)?
948 --
949 -- - @False@: treat the hi-boot summaries as nodes of the graph,
950 -- so the graph must be acyclic
951 --
952 -- - @True@: eliminate the hi-boot nodes, and instead pretend
953 -- the a source-import of Foo is an import of Foo
954 -- The resulting graph has no hi-boot nodes, but can be cyclic
955
956 topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
957 = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
958 where
959 (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries
960
961 initial_graph = case mb_root_mod of
962 Nothing -> graph
963 Just root_mod ->
964 -- restrict the graph to just those modules reachable from
965 -- the specified module. We do this by building a graph with
966 -- the full set of nodes, and determining the reachable set from
967 -- the specified node.
968 let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node
969 | otherwise = ghcError (ProgramError "module does not exist")
970 in graphFromEdgedVertices (seq root (reachableG graph root))
971
972 summaryNodeKey :: SummaryNode -> Int
973 summaryNodeKey (_, k, _) = k
974
975 summaryNodeSummary :: SummaryNode -> ModSummary
976 summaryNodeSummary (s, _, _) = s
977
978 moduleGraphNodes :: Bool -> [ModSummary]
979 -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
980 moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)
981 where
982 numbered_summaries = zip summaries [1..]
983
984 lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
985 lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map
986
987 lookup_key :: HscSource -> ModuleName -> Maybe Int
988 lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
989
990 node_map :: NodeMap SummaryNode
991 node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node)
992 | node@(s, _, _) <- nodes ]
993
994 -- We use integers as the keys for the SCC algorithm
995 nodes :: [SummaryNode]
996 nodes = [ (s, key, out_keys)
997 | (s, key) <- numbered_summaries
998 -- Drop the hi-boot ones if told to do so
999 , not (isBootSummary s && drop_hs_boot_nodes)
1000 , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++
1001 out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++
1002 (-- see [boot-edges] below
1003 if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
1004 then []
1005 else case lookup_key HsBootFile (ms_mod_name s) of
1006 Nothing -> []
1007 Just k -> [k]) ]
1008
1009 -- [boot-edges] if this is a .hs and there is an equivalent
1010 -- .hs-boot, add a link from the former to the latter. This
1011 -- has the effect of detecting bogus cases where the .hs-boot
1012 -- depends on the .hs, by introducing a cycle. Additionally,
1013 -- it ensures that we will always process the .hs-boot before
1014 -- the .hs, and so the HomePackageTable will always have the
1015 -- most up to date information.
1016
1017 -- Drop hs-boot nodes by using HsSrcFile as the key
1018 hs_boot_key | drop_hs_boot_nodes = HsSrcFile
1019 | otherwise = HsBootFile
1020
1021 out_edge_keys :: HscSource -> [ModuleName] -> [Int]
1022 out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
1023 -- If we want keep_hi_boot_nodes, then we do lookup_key with
1024 -- the IsBootInterface parameter True; else False
1025
1026
1027 type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are
1028 type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs
1029
1030 msKey :: ModSummary -> NodeKey
1031 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
1032
1033 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
1034 mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]
1035
1036 nodeMapElts :: NodeMap a -> [a]
1037 nodeMapElts = Map.elems
1038
1039 -- | If there are {-# SOURCE #-} imports between strongly connected
1040 -- components in the topological sort, then those imports can
1041 -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
1042 -- were necessary, then the edge would be part of a cycle.
1043 warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
1044 warnUnnecessarySourceImports sccs = do
1045 logWarnings (listToBag (concatMap (check.flattenSCC) sccs))
1046 where check ms =
1047 let mods_in_this_cycle = map ms_mod_name ms in
1048 [ warn i | m <- ms, i <- ms_home_srcimps m,
1049 unLoc i `notElem` mods_in_this_cycle ]
1050
1051 warn :: Located ModuleName -> WarnMsg
1052 warn (L loc mod) =
1053 mkPlainErrMsg loc
1054 (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ")
1055 <+> quotes (ppr mod))
1056
1057 -----------------------------------------------------------------------------
1058 -- Downsweep (dependency analysis)
1059
1060 -- Chase downwards from the specified root set, returning summaries
1061 -- for all home modules encountered. Only follow source-import
1062 -- links.
1063
1064 -- We pass in the previous collection of summaries, which is used as a
1065 -- cache to avoid recalculating a module summary if the source is
1066 -- unchanged.
1067 --
1068 -- The returned list of [ModSummary] nodes has one node for each home-package
1069 -- module, plus one for any hs-boot files. The imports of these nodes
1070 -- are all there, including the imports of non-home-package modules.
1071
1072 downsweep :: HscEnv
1073 -> [ModSummary] -- Old summaries
1074 -> [ModuleName] -- Ignore dependencies on these; treat
1075 -- them as if they were package modules
1076 -> Bool -- True <=> allow multiple targets to have
1077 -- the same module name; this is
1078 -- very useful for ghc -M
1079 -> IO [ModSummary]
1080 -- The elts of [ModSummary] all have distinct
1081 -- (Modules, IsBoot) identifiers, unless the Bool is true
1082 -- in which case there can be repeats
1083 downsweep hsc_env old_summaries excl_mods allow_dup_roots
1084 = do
1085 rootSummaries <- mapM getRootSummary roots
1086 let root_map = mkRootMap rootSummaries
1087 checkDuplicates root_map
1088 summs <- loop (concatMap msDeps rootSummaries) root_map
1089 return summs
1090 where
1091 roots = hsc_targets hsc_env
1092
1093 old_summary_map :: NodeMap ModSummary
1094 old_summary_map = mkNodeMap old_summaries
1095
1096 getRootSummary :: Target -> IO ModSummary
1097 getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
1098 = do exists <- liftIO $ doesFileExist file
1099 if exists
1100 then summariseFile hsc_env old_summaries file mb_phase
1101 obj_allowed maybe_buf
1102 else throwOneError $ mkPlainErrMsg noSrcSpan $
1103 text "can't find file:" <+> text file
1104 getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
1105 = do maybe_summary <- summariseModule hsc_env old_summary_map False
1106 (L rootLoc modl) obj_allowed
1107 maybe_buf excl_mods
1108 case maybe_summary of
1109 Nothing -> packageModErr modl
1110 Just s -> return s
1111
1112 rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
1113
1114 -- In a root module, the filename is allowed to diverge from the module
1115 -- name, so we have to check that there aren't multiple root files
1116 -- defining the same module (otherwise the duplicates will be silently
1117 -- ignored, leading to confusing behaviour).
1118 checkDuplicates :: NodeMap [ModSummary] -> IO ()
1119 checkDuplicates root_map
1120 | allow_dup_roots = return ()
1121 | null dup_roots = return ()
1122 | otherwise = liftIO $ multiRootsErr (head dup_roots)
1123 where
1124 dup_roots :: [[ModSummary]] -- Each at least of length 2
1125 dup_roots = filterOut isSingleton (nodeMapElts root_map)
1126
1127 loop :: [(Located ModuleName,IsBootInterface)]
1128 -- Work list: process these modules
1129 -> NodeMap [ModSummary]
1130 -- Visited set; the range is a list because
1131 -- the roots can have the same module names
1132 -- if allow_dup_roots is True
1133 -> IO [ModSummary]
1134 -- The result includes the worklist, except
1135 -- for those mentioned in the visited set
1136 loop [] done = return (concat (nodeMapElts done))
1137 loop ((wanted_mod, is_boot) : ss) done
1138 | Just summs <- Map.lookup key done
1139 = if isSingleton summs then
1140 loop ss done
1141 else
1142 do { multiRootsErr summs; return [] }
1143 | otherwise
1144 = do mb_s <- summariseModule hsc_env old_summary_map
1145 is_boot wanted_mod True
1146 Nothing excl_mods
1147 case mb_s of
1148 Nothing -> loop ss done
1149 Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done)
1150 where
1151 key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
1152
1153 -- XXX Does the (++) here need to be flipped?
1154 mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
1155 mkRootMap summaries = Map.insertListWith (flip (++))
1156 [ (msKey s, [s]) | s <- summaries ]
1157 Map.empty
1158
1159 msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
1160 -- (msDeps s) returns the dependencies of the ModSummary s.
1161 -- A wrinkle is that for a {-# SOURCE #-} import we return
1162 -- *both* the hs-boot file
1163 -- *and* the source file
1164 -- as "dependencies". That ensures that the list of all relevant
1165 -- modules always contains B.hs if it contains B.hs-boot.
1166 -- Remember, this pass isn't doing the topological sort. It's
1167 -- just gathering the list of all relevant ModSummaries
1168 msDeps s =
1169 concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ]
1170 ++ [ (m,False) | m <- ms_home_imps s ]
1171
1172 home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName]
1173 home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ]
1174 where isLocal Nothing = True
1175 isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
1176 isLocal _ = False
1177
1178 ms_home_allimps :: ModSummary -> [ModuleName]
1179 ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)
1180
1181 ms_home_srcimps :: ModSummary -> [Located ModuleName]
1182 ms_home_srcimps = home_imps . ms_srcimps
1183
1184 ms_home_imps :: ModSummary -> [Located ModuleName]
1185 ms_home_imps = home_imps . ms_imps
1186
1187 -----------------------------------------------------------------------------
1188 -- Summarising modules
1189
1190 -- We have two types of summarisation:
1191 --
1192 -- * Summarise a file. This is used for the root module(s) passed to
1193 -- cmLoadModules. The file is read, and used to determine the root
1194 -- module name. The module name may differ from the filename.
1195 --
1196 -- * Summarise a module. We are given a module name, and must provide
1197 -- a summary. The finder is used to locate the file in which the module
1198 -- resides.
1199
1200 summariseFile
1201 :: HscEnv
1202 -> [ModSummary] -- old summaries
1203 -> FilePath -- source file name
1204 -> Maybe Phase -- start phase
1205 -> Bool -- object code allowed?
1206 -> Maybe (StringBuffer,UTCTime)
1207 -> IO ModSummary
1208
1209 summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
1210 -- we can use a cached summary if one is available and the
1211 -- source file hasn't changed, But we have to look up the summary
1212 -- by source file, rather than module name as we do in summarise.
1213 | Just old_summary <- findSummaryBySourceFile old_summaries file
1214 = do
1215 let location = ms_location old_summary
1216
1217 -- return the cached summary if the source didn't change
1218 src_timestamp <- case maybe_buf of
1219 Just (_,t) -> return t
1220 Nothing -> liftIO $ getModificationUTCTime file
1221 -- The file exists; we checked in getRootSummary above.
1222 -- If it gets removed subsequently, then this
1223 -- getModificationUTCTime may fail, but that's the right
1224 -- behaviour.
1225
1226 if ms_hs_date old_summary == src_timestamp
1227 then do -- update the object-file timestamp
1228 obj_timestamp <-
1229 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
1230 || obj_allowed -- bug #1205
1231 then liftIO $ getObjTimestamp location False
1232 else return Nothing
1233 return old_summary{ ms_obj_date = obj_timestamp }
1234 else
1235 new_summary
1236
1237 | otherwise
1238 = new_summary
1239 where
1240 new_summary = do
1241 let dflags = hsc_dflags hsc_env
1242
1243 (dflags', hspp_fn, buf)
1244 <- preprocessFile hsc_env file mb_phase maybe_buf
1245
1246 (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
1247
1248 -- Make a ModLocation for this file
1249 location <- liftIO $ mkHomeModLocation dflags mod_name file
1250
1251 -- Tell the Finder cache where it is, so that subsequent calls
1252 -- to findModule will find it, even if it's not on any search path
1253 mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
1254
1255 src_timestamp <- case maybe_buf of
1256 Just (_,t) -> return t
1257 Nothing -> liftIO $ getModificationUTCTime file
1258 -- getMofificationTime may fail
1259
1260 -- when the user asks to load a source file by name, we only
1261 -- use an object file if -fobject-code is on. See #1205.
1262 obj_timestamp <-
1263 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
1264 || obj_allowed -- bug #1205
1265 then liftIO $ modificationTimeIfExists (ml_obj_file location)
1266 else return Nothing
1267
1268 return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
1269 ms_location = location,
1270 ms_hspp_file = hspp_fn,
1271 ms_hspp_opts = dflags',
1272 ms_hspp_buf = Just buf,
1273 ms_srcimps = srcimps, ms_textual_imps = the_imps,
1274 ms_hs_date = src_timestamp,
1275 ms_obj_date = obj_timestamp })
1276
1277 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
1278 findSummaryBySourceFile summaries file
1279 = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
1280 expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
1281 [] -> Nothing
1282 (x:_) -> Just x
1283
1284 -- Summarise a module, and pick up source and timestamp.
1285 summariseModule
1286 :: HscEnv
1287 -> NodeMap ModSummary -- Map of old summaries
1288 -> IsBootInterface -- True <=> a {-# SOURCE #-} import
1289 -> Located ModuleName -- Imported module to be summarised
1290 -> Bool -- object code allowed?
1291 -> Maybe (StringBuffer, UTCTime)
1292 -> [ModuleName] -- Modules to exclude
1293 -> IO (Maybe ModSummary) -- Its new summary
1294
1295 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
1296 obj_allowed maybe_buf excl_mods
1297 | wanted_mod `elem` excl_mods
1298 = return Nothing
1299
1300 | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map
1301 = do -- Find its new timestamp; all the
1302 -- ModSummaries in the old map have valid ml_hs_files
1303 let location = ms_location old_summary
1304 src_fn = expectJust "summariseModule" (ml_hs_file location)
1305
1306 -- check the modification time on the source file, and
1307 -- return the cached summary if it hasn't changed. If the
1308 -- file has disappeared, we need to call the Finder again.
1309 case maybe_buf of
1310 Just (_,t) -> check_timestamp old_summary location src_fn t
1311 Nothing -> do
1312 m <- tryIO (getModificationUTCTime src_fn)
1313 case m of
1314 Right t -> check_timestamp old_summary location src_fn t
1315 Left e | isDoesNotExistError e -> find_it
1316 | otherwise -> ioError e
1317
1318 | otherwise = find_it
1319 where
1320 dflags = hsc_dflags hsc_env
1321
1322 hsc_src = if is_boot then HsBootFile else HsSrcFile
1323
1324 check_timestamp old_summary location src_fn src_timestamp
1325 | ms_hs_date old_summary == src_timestamp = do
1326 -- update the object-file timestamp
1327 obj_timestamp <-
1328 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
1329 || obj_allowed -- bug #1205
1330 then getObjTimestamp location is_boot
1331 else return Nothing
1332 return (Just old_summary{ ms_obj_date = obj_timestamp })
1333 | otherwise =
1334 -- source changed: re-summarise.
1335 new_summary location (ms_mod old_summary) src_fn src_timestamp
1336
1337 find_it = do
1338 -- Don't use the Finder's cache this time. If the module was
1339 -- previously a package module, it may have now appeared on the
1340 -- search path, so we want to consider it to be a home module. If
1341 -- the module was previously a home module, it may have moved.
1342 uncacheModule hsc_env wanted_mod
1343 found <- findImportedModule hsc_env wanted_mod Nothing
1344 case found of
1345 Found location mod
1346 | isJust (ml_hs_file location) ->
1347 -- Home package
1348 just_found location mod
1349 | otherwise ->
1350 -- Drop external-pkg
1351 ASSERT(modulePackageId mod /= thisPackage dflags)
1352 return Nothing
1353
1354 err -> noModError dflags loc wanted_mod err
1355 -- Not found
1356
1357 just_found location mod = do
1358 -- Adjust location to point to the hs-boot source file,
1359 -- hi file, object file, when is_boot says so
1360 let location' | is_boot = addBootSuffixLocn location
1361 | otherwise = location
1362 src_fn = expectJust "summarise2" (ml_hs_file location')
1363
1364 -- Check that it exists
1365 -- It might have been deleted since the Finder last found it
1366 maybe_t <- modificationTimeIfExists src_fn
1367 case maybe_t of
1368 Nothing -> noHsFileErr loc src_fn
1369 Just t -> new_summary location' mod src_fn t
1370
1371
1372 new_summary location mod src_fn src_timestamp
1373 = do
1374 -- Preprocess the source file and get its imports
1375 -- The dflags' contains the OPTIONS pragmas
1376 (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
1377 (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
1378
1379 when (mod_name /= wanted_mod) $
1380 throwOneError $ mkPlainErrMsg mod_loc $
1381 text "File name does not match module name:"
1382 $$ text "Saw:" <+> quotes (ppr mod_name)
1383 $$ text "Expected:" <+> quotes (ppr wanted_mod)
1384
1385 -- Find the object timestamp, and return the summary
1386 obj_timestamp <-
1387 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
1388 || obj_allowed -- bug #1205
1389 then getObjTimestamp location is_boot
1390 else return Nothing
1391
1392 return (Just (ModSummary { ms_mod = mod,
1393 ms_hsc_src = hsc_src,
1394 ms_location = location,
1395 ms_hspp_file = hspp_fn,
1396 ms_hspp_opts = dflags',
1397 ms_hspp_buf = Just buf,
1398 ms_srcimps = srcimps,
1399 ms_textual_imps = the_imps,
1400 ms_hs_date = src_timestamp,
1401 ms_obj_date = obj_timestamp }))
1402
1403
1404 getObjTimestamp :: ModLocation -> Bool -> IO (Maybe UTCTime)
1405 getObjTimestamp location is_boot
1406 = if is_boot then return Nothing
1407 else modificationTimeIfExists (ml_obj_file location)
1408
1409
1410 preprocessFile :: HscEnv
1411 -> FilePath
1412 -> Maybe Phase -- ^ Starting phase
1413 -> Maybe (StringBuffer,UTCTime)
1414 -> IO (DynFlags, FilePath, StringBuffer)
1415 preprocessFile hsc_env src_fn mb_phase Nothing
1416 = do
1417 (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
1418 buf <- hGetStringBuffer hspp_fn
1419 return (dflags', hspp_fn, buf)
1420
1421 preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
1422 = do
1423 let dflags = hsc_dflags hsc_env
1424 let local_opts = getOptions dflags buf src_fn
1425
1426 (dflags', leftovers, warns)
1427 <- parseDynamicFilePragma dflags local_opts
1428 checkProcessArgsResult leftovers
1429 handleFlagWarnings dflags' warns
1430
1431 let needs_preprocessing
1432 | Just (Unlit _) <- mb_phase = True
1433 | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
1434 -- note: local_opts is only required if there's no Unlit phase
1435 | xopt Opt_Cpp dflags' = True
1436 | dopt Opt_Pp dflags' = True
1437 | otherwise = False
1438
1439 when needs_preprocessing $
1440 ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
1441
1442 return (dflags', src_fn, buf)
1443
1444
1445 -----------------------------------------------------------------------------
1446 -- Error messages
1447 -----------------------------------------------------------------------------
1448
1449 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
1450 -- ToDo: we don't have a proper line number for this error
1451 noModError dflags loc wanted_mod err
1452 = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
1453
1454 noHsFileErr :: SrcSpan -> String -> IO a
1455 noHsFileErr loc path
1456 = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path
1457
1458 packageModErr :: ModuleName -> IO a
1459 packageModErr mod
1460 = throwOneError $ mkPlainErrMsg noSrcSpan $
1461 text "module" <+> quotes (ppr mod) <+> text "is a package module"
1462
1463 multiRootsErr :: [ModSummary] -> IO ()
1464 multiRootsErr [] = panic "multiRootsErr"
1465 multiRootsErr summs@(summ1:_)
1466 = throwOneError $ mkPlainErrMsg noSrcSpan $
1467 text "module" <+> quotes (ppr mod) <+>
1468 text "is defined in multiple files:" <+>
1469 sep (map text files)
1470 where
1471 mod = ms_mod summ1
1472 files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
1473
1474 cyclicModuleErr :: [ModSummary] -> SDoc
1475 -- From a strongly connected component we find
1476 -- a single cycle to report
1477 cyclicModuleErr mss
1478 = ASSERT( not (null mss) )
1479 case findCycle graph of
1480 Nothing -> ptext (sLit "Unexpected non-cycle") <+> ppr mss
1481 Just path -> vcat [ ptext (sLit "Module imports form a cycle:")
1482 , nest 2 (show_path path) ]
1483 where
1484 graph :: [Node NodeKey ModSummary]
1485 graph = [(ms, msKey ms, get_deps ms) | ms <- mss]
1486
1487 get_deps :: ModSummary -> [NodeKey]
1488 get_deps ms = ([ (unLoc m, HsBootFile) | m <- ms_home_srcimps ms ] ++
1489 [ (unLoc m, HsSrcFile) | m <- ms_home_imps ms ])
1490
1491 show_path [] = panic "show_path"
1492 show_path [m] = ptext (sLit "module") <+> ppr_ms m
1493 <+> ptext (sLit "imports itself")
1494 show_path (m1:m2:ms) = vcat ( nest 7 (ptext (sLit "module") <+> ppr_ms m1)
1495 : nest 6 (ptext (sLit "imports") <+> ppr_ms m2)
1496 : go ms )
1497 where
1498 go [] = [ptext (sLit "which imports") <+> ppr_ms m1]
1499 go (m:ms) = (ptext (sLit "which imports") <+> ppr_ms m) : go ms
1500
1501
1502 ppr_ms :: ModSummary -> SDoc
1503 ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>
1504 (parens (text (msHsFilePath ms)))
1505