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