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