Commit 27d7d930 authored by Simon Marlow's avatar Simon Marlow
Browse files

In --make, give an indication of why a module is being recompiled

e.g.

[3 of 5] Compiling C                (C.hs, C.o)
[4 of 5] Compiling D                (D.hs, D.o) [C changed]
[5 of 5] Compiling E                (E.hs, E.o) [D changed]

The main motivation for this is so that we can give the user a clue
when something is being recompiled because the flags changed:

[1 of 1] Compiling Test2            ( Test2.hs, Test2.o ) [flags changed]
parent c624d285
......@@ -19,6 +19,7 @@ module MkIface (
checkOldIface, -- See if recompilation is required, by
-- comparing version information
RecompileRequired(..), recompileRequired,
tyThingToIfaceDecl -- Converting things to their Iface equivalents
) where
......@@ -1085,11 +1086,28 @@ Trac #5362 for an example. Such Names are always
%* *
Load the old interface file for this module (unless
we have it already), and check whether it is up to date
%* *
%************************************************************************
\begin{code}
data RecompileRequired
= UpToDate
-- ^ everything is up to date, recompilation is not required
| MustCompile
-- ^ The .hs file has been touched, or the .o/.hi file does not exist
| RecompBecause String
-- ^ The .o/.hi files are up to date, but something else has changed
-- to force recompilation; the String says what (one-line summary)
| RecompForcedByTH
-- ^ recompile is forced due to use of TH by the module
deriving Eq
recompileRequired :: RecompileRequired -> Bool
recompileRequired UpToDate = False
recompileRequired _ = True
-- | Top level function to check if the version of an old interface file
-- is equivalent to the current source file the user asked us to compile.
-- If the same, we can avoid recompilation. We return a tuple where the
......@@ -1109,7 +1127,7 @@ checkOldIface hsc_env mod_summary source_modified maybe_iface
check_old_iface hsc_env mod_summary source_modified maybe_iface
check_old_iface :: HscEnv -> ModSummary -> SourceModified -> Maybe ModIface
-> IfG (Bool, Maybe ModIface)
-> IfG (RecompileRequired, Maybe ModIface)
check_old_iface hsc_env mod_summary src_modified maybe_iface
= let dflags = hsc_dflags hsc_env
getIface =
......@@ -1143,19 +1161,19 @@ check_old_iface hsc_env mod_summary src_modified maybe_iface
-- avoid reading an interface; just return the one we might
-- have been supplied with.
True | not (isObjectTarget $ hscTarget dflags) ->
return (outOfDate, maybe_iface)
return (MustCompile, maybe_iface)
-- Try and read the old interface for the current module
-- from the .hi file left from the last time we compiled it
True -> do
maybe_iface' <- getIface
return (outOfDate, maybe_iface')
return (MustCompile, maybe_iface')
False -> do
maybe_iface' <- getIface
case maybe_iface' of
-- We can't retrieve the iface
Nothing -> return (outOfDate, Nothing)
Nothing -> return (MustCompile, Nothing)
-- We have got the old iface; check its versions
-- even in the SourceUnmodifiedAndStable case we
......@@ -1163,15 +1181,6 @@ check_old_iface hsc_env mod_summary src_modified maybe_iface
-- might have changed or gone away.
Just iface -> checkVersions hsc_env mod_summary iface
-- | @recompileRequired@ is called from the HscMain. It checks whether
-- a recompilation is required. It needs access to the persistent state,
-- finder, etc, because it may have to load lots of interface files to
-- check their versions.
type RecompileRequired = Bool
upToDate, outOfDate :: Bool
upToDate = False -- Recompile not required
outOfDate = True -- Recompile required
-- | Check if a module is still the same 'version'.
--
-- This function is called in the recompilation checker after we have
......@@ -1192,9 +1201,9 @@ checkVersions hsc_env mod_summary iface
ppr (mi_module iface) <> colon)
; recomp <- checkFlagHash hsc_env iface
; if recomp then return (outOfDate, Nothing) else do {
; if recompileRequired recomp then return (recomp, Nothing) else do {
; recomp <- checkDependencies hsc_env mod_summary iface
; if recomp then return (outOfDate, Just iface) else do {
; if recompileRequired recomp then return (recomp, Just iface) else do {
-- Source code unchanged and no errors yet... carry on
--
......@@ -1228,7 +1237,8 @@ checkFlagHash hsc_env iface = do
putNameLiterally
case old_hash == new_hash of
True -> up_to_date (ptext $ sLit "Module flags unchanged")
False -> out_of_date_hash (ptext $ sLit " Module flags have changed")
False -> out_of_date_hash "flags changed"
(ptext $ sLit " Module flags have changed")
old_hash new_hash
-- If the direct imports of this module are resolved to targets that
......@@ -1243,18 +1253,16 @@ checkFlagHash hsc_env iface = do
-- Returns True if recompilation is required.
checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
= orM (map dep_missing (ms_imps summary ++ ms_srcimps summary))
= checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))
where
prev_dep_mods = dep_mods (mi_deps iface)
prev_dep_pkgs = dep_pkgs (mi_deps iface)
this_pkg = thisPackage (hsc_dflags hsc_env)
orM = foldr f (return False)
where f m rest = do b <- m; if b then return True else rest
dep_missing (L _ (ImportDecl { ideclName = L _ mod, ideclPkgQual = pkg })) = do
find_res <- liftIO $ findImportedModule hsc_env mod pkg
let reason = moduleNameString mod ++ " changed"
case find_res of
Found _ mod
| pkg == this_pkg
......@@ -1262,20 +1270,20 @@ checkDependencies hsc_env summary iface
then do traceHiDiffs $
text "imported module " <> quotes (ppr mod) <>
text " not among previous dependencies"
return outOfDate
return (RecompBecause reason)
else
return upToDate
return UpToDate
| otherwise
-> if pkg `notElem` (map fst prev_dep_pkgs)
then do traceHiDiffs $
text "imported module " <> quotes (ppr mod) <>
text " is from package " <> quotes (ppr pkg) <>
text ", which is not among previous dependencies"
return outOfDate
return (RecompBecause reason)
else
return upToDate
return UpToDate
where pkg = modulePackageId mod
_otherwise -> return outOfDate
_otherwise -> return (RecompBecause reason)
needInterface :: Module -> (ModIface -> IfG RecompileRequired)
-> IfG RecompileRequired
......@@ -1289,8 +1297,10 @@ needInterface mod continue
-- Instead, get an Either back which we can test
case mb_iface of
Failed _ -> (out_of_date (sep [ptext (sLit "Couldn't load interface for module"),
ppr mod]))
Failed _ -> do
traceHiDiffs (sep [ptext (sLit "Couldn't load interface for module"),
ppr mod])
return MustCompile
-- Couldn't find or parse a module mentioned in the
-- old interface file. Don't complain: it might
-- just be that the current module doesn't need that
......@@ -1306,7 +1316,8 @@ checkModUsage _this_pkg UsagePackageModule{
usg_mod = mod,
usg_mod_hash = old_mod_hash }
= needInterface mod $ \iface -> do
checkModuleFingerprint old_mod_hash (mi_mod_hash iface)
let reason = moduleNameString (moduleName mod) ++ " changed"
checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface)
-- We only track the ABI hash of package modules, rather than
-- individual entity usages, so if the ABI hash changes we must
-- recompile. This is safe but may entail more recompilation when
......@@ -1326,19 +1337,21 @@ checkModUsage this_pkg UsageHomeModule{
new_decl_hash = mi_hash_fn iface
new_export_hash = mi_exp_hash iface
reason = moduleNameString mod_name ++ " changed"
-- CHECK MODULE
recompile <- checkModuleFingerprint old_mod_hash new_mod_hash
if not recompile then return upToDate else do
recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash
if not (recompileRequired recompile) then return UpToDate else do
-- CHECK EXPORT LIST
checkMaybeHash maybe_old_export_hash new_export_hash
checkMaybeHash reason maybe_old_export_hash new_export_hash
(ptext (sLit " Export list changed")) $ do
-- CHECK ITEMS ONE BY ONE
recompile <- checkList [ checkEntityUsage new_decl_hash u
recompile <- checkList [ checkEntityUsage reason new_decl_hash u
| u <- old_decl_hash]
if recompile
then return outOfDate -- This one failed, so just bail out now
if recompileRequired recompile
then return recompile -- This one failed, so just bail out now
else up_to_date (ptext (sLit " Great! The bits I use are up to date"))
......@@ -1347,65 +1360,72 @@ checkModUsage _this_pkg UsageFile{ usg_file_path = file,
liftIO $
handleIO handle $ do
new_mtime <- getModificationUTCTime file
return $ old_mtime /= new_mtime
if (old_mtime /= new_mtime)
then return recomp
else return UpToDate
where
recomp = RecompBecause (file ++ " changed")
handle =
#ifdef DEBUG
\e -> pprTrace "UsageFile" (text (show e)) $ return True
\e -> pprTrace "UsageFile" (text (show e)) $ return recomp
#else
\_ -> return True -- if we can't find the file, just recompile, don't fail
\_ -> return recomp -- if we can't find the file, just recompile, don't fail
#endif
------------------------
checkModuleFingerprint :: Fingerprint -> Fingerprint -> IfG RecompileRequired
checkModuleFingerprint old_mod_hash new_mod_hash
checkModuleFingerprint :: String -> Fingerprint -> Fingerprint
-> IfG RecompileRequired
checkModuleFingerprint reason old_mod_hash new_mod_hash
| new_mod_hash == old_mod_hash
= up_to_date (ptext (sLit "Module fingerprint unchanged"))
| otherwise
= out_of_date_hash (ptext (sLit " Module fingerprint has changed"))
= out_of_date_hash reason (ptext (sLit " Module fingerprint has changed"))
old_mod_hash new_mod_hash
------------------------
checkMaybeHash :: Maybe Fingerprint -> Fingerprint -> SDoc
checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc
-> IfG RecompileRequired -> IfG RecompileRequired
checkMaybeHash maybe_old_hash new_hash doc continue
checkMaybeHash reason maybe_old_hash new_hash doc continue
| Just hash <- maybe_old_hash, hash /= new_hash
= out_of_date_hash doc hash new_hash
= out_of_date_hash reason doc hash new_hash
| otherwise
= continue
------------------------
checkEntityUsage :: (OccName -> Maybe (OccName, Fingerprint))
checkEntityUsage :: String
-> (OccName -> Maybe (OccName, Fingerprint))
-> (OccName, Fingerprint)
-> IfG RecompileRequired
checkEntityUsage new_hash (name,old_hash)
checkEntityUsage reason new_hash (name,old_hash)
= case new_hash name of
Nothing -> -- We used it before, but it ain't there now
out_of_date (sep [ptext (sLit "No longer exported:"), ppr name])
out_of_date reason (sep [ptext (sLit "No longer exported:"), ppr name])
Just (_, new_hash) -- It's there, but is it up to date?
| new_hash == old_hash -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_hash))
return upToDate
| otherwise -> out_of_date_hash (ptext (sLit " Out of date:") <+> ppr name)
return UpToDate
| otherwise -> out_of_date_hash reason (ptext (sLit " Out of date:") <+> ppr name)
old_hash new_hash
up_to_date, out_of_date :: SDoc -> IfG RecompileRequired
up_to_date msg = traceHiDiffs msg >> return upToDate
out_of_date msg = traceHiDiffs msg >> return outOfDate
up_to_date :: SDoc -> IfG RecompileRequired
up_to_date msg = traceHiDiffs msg >> return UpToDate
out_of_date :: String -> SDoc -> IfG RecompileRequired
out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason)
out_of_date_hash :: SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
out_of_date_hash msg old_hash new_hash
= out_of_date (hsep [msg, ppr old_hash, ptext (sLit "->"), ppr new_hash])
out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
out_of_date_hash reason msg old_hash new_hash
= out_of_date reason (hsep [msg, ppr old_hash, ptext (sLit "->"), ppr new_hash])
----------------------
checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
-- This helper is used in two places
checkList [] = return upToDate
checkList [] = return UpToDate
checkList (check:checks) = do recompile <- check
if recompile
then return outOfDate
if recompileRequired recompile
then return recompile
else checkList checks
\end{code}
......
......@@ -550,7 +550,7 @@ data HsCompiler a = HsCompiler {
}
genericHscCompile :: HsCompiler a
-> (HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO ())
-> (HscEnv -> Maybe (Int,Int) -> RecompileRequired -> ModSummary -> IO ())
-> HscEnv -> ModSummary -> SourceModified
-> Maybe ModIface -> Maybe (Int, Int)
-> IO a
......@@ -568,7 +568,7 @@ genericHscCompile compiler hscMessage hsc_env
let mb_old_hash = fmap mi_iface_hash mb_checked_iface
let skip iface = do
hscMessage hsc_env mb_mod_index RecompNotRequired mod_summary
hscMessage hsc_env mb_mod_index UpToDate mod_summary
runHsc hsc_env $ hscNoRecomp compiler iface
compile reason = do
......@@ -591,12 +591,12 @@ genericHscCompile compiler hscMessage hsc_env
-- doing for us in one-shot mode.
case mb_checked_iface of
Just iface | not recomp_reqd ->
Just iface | not (recompileRequired recomp_reqd) ->
if mi_used_th iface && not stable
then compile RecompForcedByTH
else skip iface
_otherwise ->
compile RecompRequired
compile recomp_reqd
hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a
hscCheckRecompBackend compiler tc_result hsc_env mod_summary
......@@ -609,7 +609,7 @@ hscCheckRecompBackend compiler tc_result hsc_env mod_summary
let mb_old_hash = fmap mi_iface_hash mb_checked_iface
case mb_checked_iface of
Just iface | not recomp_reqd
Just iface | not (recompileRequired recomp_reqd)
-> runHsc hsc_env $
hscNoRecomp compiler
iface{ mi_globals = Just (tcg_rdr_env tc_result) }
......@@ -800,32 +800,33 @@ genModDetails old_iface
-- Progress displayers.
--------------------------------------------------------------
data RecompReason = RecompNotRequired | RecompRequired | RecompForcedByTH
deriving Eq
oneShotMsg :: HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO ()
oneShotMsg :: HscEnv -> Maybe (Int,Int) -> RecompileRequired -> ModSummary
-> IO ()
oneShotMsg hsc_env _mb_mod_index recomp _mod_summary =
case recomp of
RecompNotRequired ->
UpToDate ->
compilationProgressMsg (hsc_dflags hsc_env) $
"compilation IS NOT required"
_other ->
return ()
batchMsg :: HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO ()
batchMsg :: HscEnv -> Maybe (Int,Int) -> RecompileRequired -> ModSummary
-> IO ()
batchMsg hsc_env mb_mod_index recomp mod_summary =
case recomp of
RecompRequired -> showMsg "Compiling "
RecompNotRequired
| verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping "
MustCompile -> showMsg "Compiling " ""
UpToDate
| verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " ""
| otherwise -> return ()
RecompForcedByTH -> showMsg "Compiling [TH] "
RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
RecompForcedByTH -> showMsg "Compiling " " [TH]"
where
showMsg msg =
showMsg msg reason =
compilationProgressMsg (hsc_dflags hsc_env) $
(showModuleIndex mb_mod_index ++
msg ++ showModMsg (hscTarget (hsc_dflags hsc_env))
(recomp == RecompRequired) mod_summary)
(recompileRequired recomp) mod_summary)
++ reason
--------------------------------------------------------------
-- FrontEnds
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment