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