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