Merge remote-tracking branch 'origin/master' into type-nats
[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 | Just t <- ms_obj_date ms = t >= ms_hs_date ms
564 && same_as_prev t
565 | otherwise = False
566 where
567 same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
568 Just hmi | Just l <- hm_linkable hmi
569 -> isObjectLinkable l && t == linkableTime l
570 _other -> True
571 -- why '>=' rather than '>' above? If the filesystem stores
572 -- times to the nearset second, we may occasionally find that
573 -- the object & source have the same modification time,
574 -- especially if the source was automatically generated
575 -- and compiled. Using >= is slightly unsafe, but it matches
576 -- make's behaviour.
577 --
578 -- But see #5527, where someone ran into this and it caused
579 -- a problem.
580
581 bco_ok ms
582 = case lookupUFM hpt (ms_mod_name ms) of
583 Just hmi | Just l <- hm_linkable hmi ->
584 not (isObjectLinkable l) &&
585 linkableTime l >= ms_hs_date ms
586 _other -> False
587
588 -- -----------------------------------------------------------------------------
589 --
590 -- | The upsweep
591 --
592 -- This is where we compile each module in the module graph, in a pass
593 -- from the bottom to the top of the graph.
594 --
595 -- There better had not be any cyclic groups here -- we check for them.
596 upsweep
597 :: GhcMonad m
598 => HomePackageTable -- ^ HPT from last time round (pruned)
599 -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)
600 -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files
601 -> [SCC ModSummary] -- ^ Mods to do (the worklist)
602 -> m (SuccessFlag,
603 [ModSummary])
604 -- ^ Returns:
605 --
606 -- 1. A flag whether the complete upsweep was successful.
607 -- 2. The 'HscEnv' in the monad has an updated HPT
608 -- 3. A list of modules which succeeded loading.
609
610 upsweep old_hpt stable_mods cleanup sccs = do
611 (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs)
612 return (res, reverse done)
613 where
614
615 upsweep' _old_hpt done
616 [] _ _
617 = return (Succeeded, done)
618
619 upsweep' _old_hpt done
620 (CyclicSCC ms:_) _ _
621 = do dflags <- getSessionDynFlags
622 liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
623 return (Failed, done)
624
625 upsweep' old_hpt done
626 (AcyclicSCC mod:mods) mod_index nmods
627 = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
628 -- show (map (moduleUserString.moduleName.mi_module.hm_iface)
629 -- (moduleEnvElts (hsc_HPT hsc_env)))
630 let logger _mod = defaultWarnErrLogger
631
632 hsc_env <- getSession
633
634 -- Remove unwanted tmp files between compilations
635 liftIO (cleanup hsc_env)
636
637 mb_mod_info
638 <- handleSourceError
639 (\err -> do logger mod (Just err); return Nothing) $ do
640 mod_info <- liftIO $ upsweep_mod hsc_env old_hpt stable_mods
641 mod mod_index nmods
642 logger mod Nothing -- log warnings
643 return (Just mod_info)
644
645 case mb_mod_info of
646 Nothing -> return (Failed, done)
647 Just mod_info -> do
648 let this_mod = ms_mod_name mod
649
650 -- Add new info to hsc_env
651 hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info
652 hsc_env1 = hsc_env { hsc_HPT = hpt1 }
653
654 -- Space-saving: delete the old HPT entry
655 -- for mod BUT if mod is a hs-boot
656 -- node, don't delete it. For the
657 -- interface, the HPT entry is probaby for the
658 -- main Haskell source file. Deleting it
659 -- would force the real module to be recompiled
660 -- every time.
661 old_hpt1 | isBootSummary mod = old_hpt
662 | otherwise = delFromUFM old_hpt this_mod
663
664 done' = mod:done
665
666 -- fixup our HomePackageTable after we've finished compiling
667 -- a mutually-recursive loop. See reTypecheckLoop, below.
668 hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done'
669 setSession hsc_env2
670
671 upsweep' old_hpt1 done' mods (mod_index+1) nmods
672
673 -- | Compile a single module. Always produce a Linkable for it if
674 -- successful. If no compilation happened, return the old Linkable.
675 upsweep_mod :: HscEnv
676 -> HomePackageTable
677 -> ([ModuleName],[ModuleName])
678 -> ModSummary
679 -> Int -- index of module
680 -> Int -- total number of modules
681 -> IO HomeModInfo
682 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
683 = let
684 this_mod_name = ms_mod_name summary
685 this_mod = ms_mod summary
686 mb_obj_date = ms_obj_date summary
687 obj_fn = ml_obj_file (ms_location summary)
688 hs_date = ms_hs_date summary
689
690 is_stable_obj = this_mod_name `elem` stable_obj
691 is_stable_bco = this_mod_name `elem` stable_bco
692
693 old_hmi = lookupUFM old_hpt this_mod_name
694
695 -- We're using the dflags for this module now, obtained by
696 -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
697 dflags = ms_hspp_opts summary
698 prevailing_target = hscTarget (hsc_dflags hsc_env)
699 local_target = hscTarget dflags
700
701 -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that
702 -- we don't do anything dodgy: these should only work to change
703 -- from -fvia-C to -fasm and vice-versa, otherwise we could
704 -- end up trying to link object code to byte code.
705 target = if prevailing_target /= local_target
706 && (not (isObjectTarget prevailing_target)
707 || not (isObjectTarget local_target))
708 then prevailing_target
709 else local_target
710
711 -- store the corrected hscTarget into the summary
712 summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }
713
714 -- The old interface is ok if
715 -- a) we're compiling a source file, and the old HPT
716 -- entry is for a source file
717 -- b) we're compiling a hs-boot file
718 -- Case (b) allows an hs-boot file to get the interface of its
719 -- real source file on the second iteration of the compilation
720 -- manager, but that does no harm. Otherwise the hs-boot file
721 -- will always be recompiled
722
723 mb_old_iface
724 = case old_hmi of
725 Nothing -> Nothing
726 Just hm_info | isBootSummary summary -> Just iface
727 | not (mi_boot iface) -> Just iface
728 | otherwise -> Nothing
729 where
730 iface = hm_iface hm_info
731
732 compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo
733 compile_it mb_linkable src_modified =
734 compile hsc_env summary' mod_index nmods
735 mb_old_iface mb_linkable src_modified
736
737 compile_it_discard_iface :: Maybe Linkable -> SourceModified
738 -> IO HomeModInfo
739 compile_it_discard_iface mb_linkable src_modified =
740 compile hsc_env summary' mod_index nmods
741 Nothing mb_linkable src_modified
742
743 -- With the HscNothing target we create empty linkables to avoid
744 -- recompilation. We have to detect these to recompile anyway if
745 -- the target changed since the last compile.
746 is_fake_linkable
747 | Just hmi <- old_hmi, Just l <- hm_linkable hmi =
748 null (linkableUnlinked l)
749 | otherwise =
750 -- we have no linkable, so it cannot be fake
751 False
752
753 implies False _ = True
754 implies True x = x
755
756 in
757 case () of
758 _
759 -- Regardless of whether we're generating object code or
760 -- byte code, we can always use an existing object file
761 -- if it is *stable* (see checkStability).
762 | is_stable_obj, Just hmi <- old_hmi -> do
763 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
764 (text "skipping stable obj mod:" <+> ppr this_mod_name)
765 return hmi
766 -- object is stable, and we have an entry in the
767 -- old HPT: nothing to do
768
769 | is_stable_obj, isNothing old_hmi -> do
770 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
771 (text "compiling stable on-disk mod:" <+> ppr this_mod_name)
772 linkable <- liftIO $ findObjectLinkable this_mod obj_fn
773 (expectJust "upsweep1" mb_obj_date)
774 compile_it (Just linkable) SourceUnmodifiedAndStable
775 -- object is stable, but we need to load the interface
776 -- off disk to make a HMI.
777
778 | not (isObjectTarget target), is_stable_bco,
779 (target /= HscNothing) `implies` not is_fake_linkable ->
780 ASSERT(isJust old_hmi) -- must be in the old_hpt
781 let Just hmi = old_hmi in do
782 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
783 (text "skipping stable BCO mod:" <+> ppr this_mod_name)
784 return hmi
785 -- BCO is stable: nothing to do
786
787 | not (isObjectTarget target),
788 Just hmi <- old_hmi,
789 Just l <- hm_linkable hmi,
790 not (isObjectLinkable l),
791 (target /= HscNothing) `implies` not is_fake_linkable,
792 linkableTime l >= ms_hs_date summary -> do
793 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
794 (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)
795 compile_it (Just l) SourceUnmodified
796 -- we have an old BCO that is up to date with respect
797 -- to the source: do a recompilation check as normal.
798
799 -- When generating object code, if there's an up-to-date
800 -- object file on the disk, then we can use it.
801 -- However, if the object file is new (compared to any
802 -- linkable we had from a previous compilation), then we
803 -- must discard any in-memory interface, because this
804 -- means the user has compiled the source file
805 -- separately and generated a new interface, that we must
806 -- read from the disk.
807 --
808 | isObjectTarget target,
809 Just obj_date <- mb_obj_date,
810 obj_date >= hs_date -> do
811 case old_hmi of
812 Just hmi
813 | Just l <- hm_linkable hmi,
814 isObjectLinkable l && linkableTime l == obj_date -> do
815 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
816 (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)
817 compile_it (Just l) SourceUnmodified
818 _otherwise -> do
819 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
820 (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)
821 linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
822 compile_it_discard_iface (Just linkable) SourceUnmodified
823
824 _otherwise -> do
825 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
826 (text "compiling mod:" <+> ppr this_mod_name)
827 compile_it Nothing SourceModified
828
829
830
831 -- Filter modules in the HPT
832 retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
833 retainInTopLevelEnvs keep_these hpt
834 = listToUFM [ (mod, expectJust "retain" mb_mod_info)
835 | mod <- keep_these
836 , let mb_mod_info = lookupUFM hpt mod
837 , isJust mb_mod_info ]
838
839 -- ---------------------------------------------------------------------------
840 -- Typecheck module loops
841 {-
842 See bug #930. This code fixes a long-standing bug in --make. The
843 problem is that when compiling the modules *inside* a loop, a data
844 type that is only defined at the top of the loop looks opaque; but
845 after the loop is done, the structure of the data type becomes
846 apparent.
847
848 The difficulty is then that two different bits of code have
849 different notions of what the data type looks like.
850
851 The idea is that after we compile a module which also has an .hs-boot
852 file, we re-generate the ModDetails for each of the modules that
853 depends on the .hs-boot file, so that everyone points to the proper
854 TyCons, Ids etc. defined by the real module, not the boot module.
855 Fortunately re-generating a ModDetails from a ModIface is easy: the
856 function TcIface.typecheckIface does exactly that.
857
858 Picking the modules to re-typecheck is slightly tricky. Starting from
859 the module graph consisting of the modules that have already been
860 compiled, we reverse the edges (so they point from the imported module
861 to the importing module), and depth-first-search from the .hs-boot
862 node. This gives us all the modules that depend transitively on the
863 .hs-boot module, and those are exactly the modules that we need to
864 re-typecheck.
865
866 Following this fix, GHC can compile itself with --make -O2.
867 -}
868 reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
869 reTypecheckLoop hsc_env ms graph
870 | not (isBootSummary ms) &&
871 any (\m -> ms_mod m == this_mod && isBootSummary m) graph
872 = do
873 let mss = reachableBackwards (ms_mod_name ms) graph
874 non_boot = filter (not.isBootSummary) mss
875 debugTraceMsg (hsc_dflags hsc_env) 2 $
876 text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot)
877 typecheckLoop hsc_env (map ms_mod_name non_boot)
878 | otherwise
879 = return hsc_env
880 where
881 this_mod = ms_mod ms
882
883 typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv
884 typecheckLoop hsc_env mods = do
885 new_hpt <-
886 fixIO $ \new_hpt -> do
887 let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }
888 mds <- initIfaceCheck new_hsc_env $
889 mapM (typecheckIface . hm_iface) hmis
890 let new_hpt = addListToUFM old_hpt
891 (zip mods [ hmi{ hm_details = details }
892 | (hmi,details) <- zip hmis mds ])
893 return new_hpt
894 return hsc_env{ hsc_HPT = new_hpt }
895 where
896 old_hpt = hsc_HPT hsc_env
897 hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods
898
899 reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
900 reachableBackwards mod summaries
901 = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]
902 where -- the rest just sets up the graph:
903 (graph, lookup_node) = moduleGraphNodes False summaries
904 root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
905
906 -- ---------------------------------------------------------------------------
907 --
908 -- | Topological sort of the module graph
909 topSortModuleGraph
910 :: Bool
911 -- ^ Drop hi-boot nodes? (see below)
912 -> [ModSummary]
913 -> Maybe ModuleName
914 -- ^ Root module name. If @Nothing@, use the full graph.
915 -> [SCC ModSummary]
916 -- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
917 -- The resulting list of strongly-connected-components is in topologically
918 -- sorted order, starting with the module(s) at the bottom of the
919 -- dependency graph (ie compile them first) and ending with the ones at
920 -- the top.
921 --
922 -- Drop hi-boot nodes (first boolean arg)?
923 --
924 -- - @False@: treat the hi-boot summaries as nodes of the graph,
925 -- so the graph must be acyclic
926 --
927 -- - @True@: eliminate the hi-boot nodes, and instead pretend
928 -- the a source-import of Foo is an import of Foo
929 -- The resulting graph has no hi-boot nodes, but can be cyclic
930
931 topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
932 = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
933 where
934 (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries
935
936 initial_graph = case mb_root_mod of
937 Nothing -> graph
938 Just root_mod ->
939 -- restrict the graph to just those modules reachable from
940 -- the specified module. We do this by building a graph with
941 -- the full set of nodes, and determining the reachable set from
942 -- the specified node.
943 let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node
944 | otherwise = ghcError (ProgramError "module does not exist")
945 in graphFromEdgedVertices (seq root (reachableG graph root))
946
947 type SummaryNode = (ModSummary, Int, [Int])
948
949 summaryNodeKey :: SummaryNode -> Int
950 summaryNodeKey (_, k, _) = k
951
952 summaryNodeSummary :: SummaryNode -> ModSummary
953 summaryNodeSummary (s, _, _) = s
954
955 moduleGraphNodes :: Bool -> [ModSummary]
956 -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
957 moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)
958 where
959 numbered_summaries = zip summaries [1..]
960
961 lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
962 lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map
963
964 lookup_key :: HscSource -> ModuleName -> Maybe Int
965 lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
966
967 node_map :: NodeMap SummaryNode
968 node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node)
969 | node@(s, _, _) <- nodes ]
970
971 -- We use integers as the keys for the SCC algorithm
972 nodes :: [SummaryNode]
973 nodes = [ (s, key, out_keys)
974 | (s, key) <- numbered_summaries
975 -- Drop the hi-boot ones if told to do so
976 , not (isBootSummary s && drop_hs_boot_nodes)
977 , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++
978 out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++
979 (-- see [boot-edges] below
980 if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
981 then []
982 else case lookup_key HsBootFile (ms_mod_name s) of
983 Nothing -> []
984 Just k -> [k]) ]
985
986 -- [boot-edges] if this is a .hs and there is an equivalent
987 -- .hs-boot, add a link from the former to the latter. This
988 -- has the effect of detecting bogus cases where the .hs-boot
989 -- depends on the .hs, by introducing a cycle. Additionally,
990 -- it ensures that we will always process the .hs-boot before
991 -- the .hs, and so the HomePackageTable will always have the
992 -- most up to date information.
993
994 -- Drop hs-boot nodes by using HsSrcFile as the key
995 hs_boot_key | drop_hs_boot_nodes = HsSrcFile
996 | otherwise = HsBootFile
997
998 out_edge_keys :: HscSource -> [ModuleName] -> [Int]
999 out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
1000 -- If we want keep_hi_boot_nodes, then we do lookup_key with
1001 -- the IsBootInterface parameter True; else False
1002
1003
1004 type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are
1005 type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs
1006
1007 msKey :: ModSummary -> NodeKey
1008 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
1009
1010 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
1011 mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]
1012
1013 nodeMapElts :: NodeMap a -> [a]
1014 nodeMapElts = Map.elems
1015
1016 -- | If there are {-# SOURCE #-} imports between strongly connected
1017 -- components in the topological sort, then those imports can
1018 -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
1019 -- were necessary, then the edge would be part of a cycle.
1020 warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
1021 warnUnnecessarySourceImports sccs = do
1022 logWarnings (listToBag (concatMap (check.flattenSCC) sccs))
1023 where check ms =
1024 let mods_in_this_cycle = map ms_mod_name ms in
1025 [ warn i | m <- ms, i <- ms_home_srcimps m,
1026 unLoc i `notElem` mods_in_this_cycle ]
1027
1028 warn :: Located ModuleName -> WarnMsg
1029 warn (L loc mod) =
1030 mkPlainErrMsg loc
1031 (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ")
1032 <+> quotes (ppr mod))
1033
1034 -----------------------------------------------------------------------------
1035 --
1036 -- | Downsweep (dependency analysis)
1037 --
1038 -- Chase downwards from the specified root set, returning summaries
1039 -- for all home modules encountered. Only follow source-import
1040 -- links.
1041 --
1042 -- We pass in the previous collection of summaries, which is used as a
1043 -- cache to avoid recalculating a module summary if the source is
1044 -- unchanged.
1045 --
1046 -- The returned list of [ModSummary] nodes has one node for each home-package
1047 -- module, plus one for any hs-boot files. The imports of these nodes
1048 -- are all there, including the imports of non-home-package modules.
1049 downsweep :: HscEnv
1050 -> [ModSummary] -- Old summaries
1051 -> [ModuleName] -- Ignore dependencies on these; treat
1052 -- them as if they were package modules
1053 -> Bool -- True <=> allow multiple targets to have
1054 -- the same module name; this is
1055 -- very useful for ghc -M
1056 -> IO [ModSummary]
1057 -- The elts of [ModSummary] all have distinct
1058 -- (Modules, IsBoot) identifiers, unless the Bool is true
1059 -- in which case there can be repeats
1060 downsweep hsc_env old_summaries excl_mods allow_dup_roots
1061 = do
1062 rootSummaries <- mapM getRootSummary roots
1063 let root_map = mkRootMap rootSummaries
1064 checkDuplicates root_map
1065 summs <- loop (concatMap msDeps rootSummaries) root_map
1066 return summs
1067 where
1068 roots = hsc_targets hsc_env
1069
1070 old_summary_map :: NodeMap ModSummary
1071 old_summary_map = mkNodeMap old_summaries
1072
1073 getRootSummary :: Target -> IO ModSummary
1074 getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
1075 = do exists <- liftIO $ doesFileExist file
1076 if exists
1077 then summariseFile hsc_env old_summaries file mb_phase
1078 obj_allowed maybe_buf
1079 else throwOneError $ mkPlainErrMsg noSrcSpan $
1080 text "can't find file:" <+> text file
1081 getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
1082 = do maybe_summary <- summariseModule hsc_env old_summary_map False
1083 (L rootLoc modl) obj_allowed
1084 maybe_buf excl_mods
1085 case maybe_summary of
1086 Nothing -> packageModErr modl
1087 Just s -> return s
1088
1089 rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
1090
1091 -- In a root module, the filename is allowed to diverge from the module
1092 -- name, so we have to check that there aren't multiple root files
1093 -- defining the same module (otherwise the duplicates will be silently
1094 -- ignored, leading to confusing behaviour).
1095 checkDuplicates :: NodeMap [ModSummary] -> IO ()
1096 checkDuplicates root_map
1097 | allow_dup_roots = return ()
1098 | null dup_roots = return ()
1099 | otherwise = liftIO $ multiRootsErr (head dup_roots)
1100 where
1101 dup_roots :: [[ModSummary]] -- Each at least of length 2
1102 dup_roots = filterOut isSingleton (nodeMapElts root_map)
1103
1104 loop :: [(Located ModuleName,IsBootInterface)]
1105 -- Work list: process these modules
1106 -> NodeMap [ModSummary]
1107 -- Visited set; the range is a list because
1108 -- the roots can have the same module names
1109 -- if allow_dup_roots is True
1110 -> IO [ModSummary]
1111 -- The result includes the worklist, except
1112 -- for those mentioned in the visited set
1113 loop [] done = return (concat (nodeMapElts done))
1114 loop ((wanted_mod, is_boot) : ss) done
1115 | Just summs <- Map.lookup key done
1116 = if isSingleton summs then
1117 loop ss done
1118 else
1119 do { multiRootsErr summs; return [] }
1120 | otherwise
1121 = do mb_s <- summariseModule hsc_env old_summary_map
1122 is_boot wanted_mod True
1123 Nothing excl_mods
1124 case mb_s of
1125 Nothing -> loop ss done
1126 Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done)
1127 where
1128 key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
1129
1130 mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
1131 mkRootMap summaries = Map.insertListWith (flip (++))
1132 [ (msKey s, [s]) | s <- summaries ]
1133 Map.empty
1134
1135 -- | Returns the dependencies of the ModSummary s.
1136 -- A wrinkle is that for a {-# SOURCE #-} import we return
1137 -- *both* the hs-boot file
1138 -- *and* the source file
1139 -- as "dependencies". That ensures that the list of all relevant
1140 -- modules always contains B.hs if it contains B.hs-boot.
1141 -- Remember, this pass isn't doing the topological sort. It's
1142 -- just gathering the list of all relevant ModSummaries
1143 msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
1144 msDeps s =
1145 concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ]
1146 ++ [ (m,False) | m <- ms_home_imps s ]
1147
1148 home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName]
1149 home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ]
1150 where isLocal Nothing = True
1151 isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
1152 isLocal _ = False
1153
1154 ms_home_allimps :: ModSummary -> [ModuleName]
1155 ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)
1156
1157 ms_home_srcimps :: ModSummary -> [Located ModuleName]
1158 ms_home_srcimps = home_imps . ms_srcimps
1159
1160 ms_home_imps :: ModSummary -> [Located ModuleName]
1161 ms_home_imps = home_imps . ms_imps
1162
1163 -----------------------------------------------------------------------------
1164 -- Summarising modules
1165
1166 -- We have two types of summarisation:
1167 --
1168 -- * Summarise a file. This is used for the root module(s) passed to
1169 -- cmLoadModules. The file is read, and used to determine the root
1170 -- module name. The module name may differ from the filename.
1171 --
1172 -- * Summarise a module. We are given a module name, and must provide
1173 -- a summary. The finder is used to locate the file in which the module
1174 -- resides.
1175
1176 summariseFile
1177 :: HscEnv
1178 -> [ModSummary] -- old summaries
1179 -> FilePath -- source file name
1180 -> Maybe Phase -- start phase
1181 -> Bool -- object code allowed?
1182 -> Maybe (StringBuffer,UTCTime)
1183 -> IO ModSummary
1184
1185 summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
1186 -- we can use a cached summary if one is available and the
1187 -- source file hasn't changed, But we have to look up the summary
1188 -- by source file, rather than module name as we do in summarise.
1189 | Just old_summary <- findSummaryBySourceFile old_summaries file
1190 = do
1191 let location = ms_location old_summary
1192
1193 -- return the cached summary if the source didn't change
1194 src_timestamp <- case maybe_buf of
1195 Just (_,t) -> return t
1196 Nothing -> liftIO $ getModificationUTCTime file
1197 -- The file exists; we checked in getRootSummary above.
1198 -- If it gets removed subsequently, then this
1199 -- getModificationUTCTime may fail, but that's the right
1200 -- behaviour.
1201
1202 if ms_hs_date old_summary == src_timestamp
1203 then do -- update the object-file timestamp
1204 obj_timestamp <-
1205 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
1206 || obj_allowed -- bug #1205
1207 then liftIO $ getObjTimestamp location False
1208 else return Nothing
1209 return old_summary{ ms_obj_date = obj_timestamp }
1210 else
1211 new_summary
1212
1213 | otherwise
1214 = new_summary
1215 where
1216 new_summary = do
1217 let dflags = hsc_dflags hsc_env
1218
1219 (dflags', hspp_fn, buf)
1220 <- preprocessFile hsc_env file mb_phase maybe_buf
1221
1222 (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
1223
1224 -- Make a ModLocation for this file
1225 location <- liftIO $ mkHomeModLocation dflags mod_name file
1226
1227 -- Tell the Finder cache where it is, so that subsequent calls
1228 -- to findModule will find it, even if it's not on any search path
1229 mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
1230
1231 src_timestamp <- case maybe_buf of
1232 Just (_,t) -> return t
1233 Nothing -> liftIO $ getModificationUTCTime file
1234 -- getMofificationTime may fail
1235
1236 -- when the user asks to load a source file by name, we only
1237 -- use an object file if -fobject-code is on. See #1205.
1238 obj_timestamp <-
1239 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
1240 || obj_allowed -- bug #1205
1241 then liftIO $ modificationTimeIfExists (ml_obj_file location)
1242 else return Nothing
1243
1244 return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
1245 ms_location = location,
1246 ms_hspp_file = hspp_fn,
1247 ms_hspp_opts = dflags',
1248 ms_hspp_buf = Just buf,
1249 ms_srcimps = srcimps, ms_textual_imps = the_imps,
1250 ms_hs_date = src_timestamp,
1251 ms_obj_date = obj_timestamp })
1252
1253 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
1254 findSummaryBySourceFile summaries file
1255 = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
1256 expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
1257 [] -> Nothing
1258 (x:_) -> Just x
1259
1260 -- Summarise a module, and pick up source and timestamp.
1261 summariseModule
1262 :: HscEnv
1263 -> NodeMap ModSummary -- Map of old summaries
1264 -> IsBootInterface -- True <=> a {-# SOURCE #-} import
1265 -> Located ModuleName -- Imported module to be summarised
1266 -> Bool -- object code allowed?
1267 -> Maybe (StringBuffer, UTCTime)
1268 -> [ModuleName] -- Modules to exclude
1269 -> IO (Maybe ModSummary) -- Its new summary
1270
1271 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
1272 obj_allowed maybe_buf excl_mods
1273 | wanted_mod `elem` excl_mods
1274 = return Nothing
1275
1276 | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map
1277 = do -- Find its new timestamp; all the
1278 -- ModSummaries in the old map have valid ml_hs_files
1279 let location = ms_location old_summary
1280 src_fn = expectJust "summariseModule" (ml_hs_file location)
1281
1282 -- check the modification time on the source file, and
1283 -- return the cached summary if it hasn't changed. If the
1284 -- file has disappeared, we need to call the Finder again.
1285 case maybe_buf of
1286 Just (_,t) -> check_timestamp old_summary location src_fn t
1287 Nothing -> do
1288 m <- tryIO (getModificationUTCTime src_fn)
1289 case m of
1290 Right t -> check_timestamp old_summary location src_fn t
1291 Left e | isDoesNotExistError e -> find_it
1292 | otherwise -> ioError e
1293
1294 | otherwise = find_it
1295 where
1296 dflags = hsc_dflags hsc_env
1297
1298 hsc_src = if is_boot then HsBootFile else HsSrcFile
1299
1300 check_timestamp old_summary location src_fn src_timestamp
1301 | ms_hs_date old_summary == src_timestamp = do
1302 -- update the object-file timestamp
1303 obj_timestamp <-
1304 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
1305 || obj_allowed -- bug #1205
1306 then getObjTimestamp location is_boot
1307 else return Nothing
1308 return (Just old_summary{ ms_obj_date = obj_timestamp })
1309 | otherwise =
1310 -- source changed: re-summarise.
1311 new_summary location (ms_mod old_summary) src_fn src_timestamp
1312
1313 find_it = do
1314 -- Don't use the Finder's cache this time. If the module was
1315 -- previously a package module, it may have now appeared on the
1316 -- search path, so we want to consider it to be a home module. If
1317 -- the module was previously a home module, it may have moved.
1318 uncacheModule hsc_env wanted_mod
1319 found <- findImportedModule hsc_env wanted_mod Nothing
1320 case found of
1321 Found location mod
1322 | isJust (ml_hs_file location) ->
1323 -- Home package
1324 just_found location mod
1325 | otherwise ->
1326 -- Drop external-pkg
1327 ASSERT(modulePackageId mod /= thisPackage dflags)
1328 return Nothing
1329
1330 err -> noModError dflags loc wanted_mod err
1331 -- Not found
1332
1333 just_found location mod = do
1334 -- Adjust location to point to the hs-boot source file,
1335 -- hi file, object file, when is_boot says so
1336 let location' | is_boot = addBootSuffixLocn location
1337 | otherwise = location
1338 src_fn = expectJust "summarise2" (ml_hs_file location')
1339
1340 -- Check that it exists
1341 -- It might have been deleted since the Finder last found it
1342 maybe_t <- modificationTimeIfExists src_fn
1343 case maybe_t of
1344 Nothing -> noHsFileErr loc src_fn
1345 Just t -> new_summary location' mod src_fn t
1346
1347
1348 new_summary location mod src_fn src_timestamp
1349 = do
1350 -- Preprocess the source file and get its imports
1351 -- The dflags' contains the OPTIONS pragmas
1352 (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
1353 (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
1354
1355 when (mod_name /= wanted_mod) $
1356 throwOneError $ mkPlainErrMsg mod_loc $
1357 text "File name does not match module name:"
1358 $$ text "Saw:" <+> quotes (ppr mod_name)
1359 $$ text "Expected:" <+> quotes (ppr wanted_mod)
1360
1361 -- Find the object timestamp, and return the summary
1362 obj_timestamp <-
1363 if isObjectTarget (hscTarget (hsc_dflags hsc_env))
1364 || obj_allowed -- bug #1205
1365 then getObjTimestamp location is_boot
1366 else return Nothing
1367
1368 return (Just (ModSummary { ms_mod = mod,
1369 ms_hsc_src = hsc_src,
1370 ms_location = location,
1371 ms_hspp_file = hspp_fn,
1372 ms_hspp_opts = dflags',
1373 ms_hspp_buf = Just buf,
1374 ms_srcimps = srcimps,
1375 ms_textual_imps = the_imps,
1376 ms_hs_date = src_timestamp,
1377 ms_obj_date = obj_timestamp }))
1378
1379
1380 getObjTimestamp :: ModLocation -> Bool -> IO (Maybe UTCTime)
1381 getObjTimestamp location is_boot
1382 = if is_boot then return Nothing
1383 else modificationTimeIfExists (ml_obj_file location)
1384
1385
1386 preprocessFile :: HscEnv
1387 -> FilePath
1388 -> Maybe Phase -- ^ Starting phase
1389 -> Maybe (StringBuffer,UTCTime)
1390 -> IO (DynFlags, FilePath, StringBuffer)
1391 preprocessFile hsc_env src_fn mb_phase Nothing
1392 = do
1393 (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
1394 buf <- hGetStringBuffer hspp_fn
1395 return (dflags', hspp_fn, buf)
1396
1397 preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
1398 = do
1399 let dflags = hsc_dflags hsc_env
1400 let local_opts = getOptions dflags buf src_fn
1401
1402 (dflags', leftovers, warns)
1403 <- parseDynamicFilePragma dflags local_opts
1404 checkProcessArgsResult leftovers
1405 handleFlagWarnings dflags' warns
1406
1407 let needs_preprocessing
1408 | Just (Unlit _) <- mb_phase = True
1409 | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
1410 -- note: local_opts is only required if there's no Unlit phase
1411 | xopt Opt_Cpp dflags' = True
1412 | dopt Opt_Pp dflags' = True
1413 | otherwise = False
1414
1415 when needs_preprocessing $
1416 ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
1417
1418 return (dflags', src_fn, buf)
1419
1420
1421 -----------------------------------------------------------------------------
1422 -- Error messages
1423 -----------------------------------------------------------------------------
1424
1425 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
1426 -- ToDo: we don't have a proper line number for this error
1427 noModError dflags loc wanted_mod err
1428 = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
1429
1430 noHsFileErr :: SrcSpan -> String -> IO a
1431 noHsFileErr loc path
1432 = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path
1433
1434 packageModErr :: ModuleName -> IO a
1435 packageModErr mod
1436 = throwOneError $ mkPlainErrMsg noSrcSpan $
1437 text "module" <+> quotes (ppr mod) <+> text "is a package module"
1438
1439 multiRootsErr :: [ModSummary] -> IO ()
1440 multiRootsErr [] = panic "multiRootsErr"
1441 multiRootsErr summs@(summ1:_)
1442 = throwOneError $ mkPlainErrMsg noSrcSpan $
1443 text "module" <+> quotes (ppr mod) <+>
1444 text "is defined in multiple files:" <+>
1445 sep (map text files)
1446 where
1447 mod = ms_mod summ1
1448 files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
1449
1450 cyclicModuleErr :: [ModSummary] -> SDoc
1451 -- From a strongly connected component we find
1452 -- a single cycle to report
1453 cyclicModuleErr mss
1454 = ASSERT( not (null mss) )
1455 case findCycle graph of
1456 Nothing -> ptext (sLit "Unexpected non-cycle") <+> ppr mss
1457 Just path -> vcat [ ptext (sLit "Module imports form a cycle:")
1458 , nest 2 (show_path path) ]
1459 where
1460 graph :: [Node NodeKey ModSummary]
1461 graph = [(ms, msKey ms, get_deps ms) | ms <- mss]
1462
1463 get_deps :: ModSummary -> [NodeKey]
1464 get_deps ms = ([ (unLoc m, HsBootFile) | m <- ms_home_srcimps ms ] ++
1465 [ (unLoc m, HsSrcFile) | m <- ms_home_imps ms ])
1466
1467 show_path [] = panic "show_path"
1468 show_path [m] = ptext (sLit "module") <+> ppr_ms m
1469 <+> ptext (sLit "imports itself")
1470 show_path (m1:m2:ms) = vcat ( nest 7 (ptext (sLit "module") <+> ppr_ms m1)
1471 : nest 6 (ptext (sLit "imports") <+> ppr_ms m2)
1472 : go ms )
1473 where
1474 go [] = [ptext (sLit "which imports") <+> ppr_ms m1]
1475 go (m:ms) = (ptext (sLit "which imports") <+> ppr_ms m) : go ms
1476
1477
1478 ppr_ms :: ModSummary -> SDoc
1479 ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>
1480 (parens (text (msHsFilePath ms)))
1481