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