Commit 3f34e091 authored by Simon Marlow's avatar Simon Marlow

Track #included files for recompilation checking (#4900, #3589)

This was pretty straightforward: collect the filenames in the lexer,
and add them in to the tcg_dependent_files list that the typechecker
collects.

Note that we still don't get #included files in the ghc -M output.
Since we don't normally lex the whole file in ghc -M, this same
mechanism can't be used directly.
parent 3b3fd568
......@@ -590,7 +590,8 @@ class TypecheckedMod m => DesugaredMod m where
-- | The result of successful parsing.
data ParsedModule =
ParsedModule { pm_mod_summary :: ModSummary
, pm_parsed_source :: ParsedSource }
, pm_parsed_source :: ParsedSource
, pm_extra_src_files :: [FilePath] }
instance ParsedMod ParsedModule where
modSummary m = pm_mod_summary m
......@@ -676,8 +677,8 @@ parseModule :: GhcMonad m => ModSummary -> m ParsedModule
parseModule ms = do
hsc_env <- getSession
let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
rdr_module <- liftIO $ hscParse hsc_env_tmp ms
return (ParsedModule ms rdr_module)
hpm <- liftIO $ hscParse hsc_env_tmp ms
return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm))
-- | Typecheck and rename a parsed module.
--
......@@ -688,7 +689,9 @@ typecheckModule pmod = do
hsc_env <- getSession
let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
(tc_gbl_env, rn_info)
<- liftIO $ hscTypecheckRename hsc_env_tmp ms (parsedSource pmod)
<- liftIO $ hscTypecheckRename hsc_env_tmp ms $
HsParsedModule { hpm_module = parsedSource pmod,
hpm_src_files = pm_extra_src_files pmod }
details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env
return $
TypecheckedModule {
......
......@@ -83,7 +83,6 @@ import DsMeta ( templateHaskellNames )
import VarSet
import VarEnv ( emptyTidyEnv )
import Panic
import Data.List
#endif
import Id
......@@ -145,9 +144,11 @@ import UniqSupply ( initUs_ )
import Bag
import Exception
import Data.List
import Control.Monad
import Data.Maybe
import Data.IORef
import System.FilePath as FilePath
#include "HsVersions.h"
......@@ -309,11 +310,11 @@ hscRnImportDecls hsc_env import_decls =
-- -----------------------------------------------------------------------------
-- | parse a file, returning the abstract syntax
hscParse :: HscEnv -> ModSummary -> IO (Located (HsModule RdrName))
hscParse :: HscEnv -> ModSummary -> IO HsParsedModule
hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
-- internal version, that doesn't fail due to -Werror
hscParse' :: ModSummary -> Hsc (Located (HsModule RdrName))
hscParse' :: ModSummary -> Hsc HsParsedModule
hscParse' mod_summary = do
dflags <- getDynFlags
let src_filename = ms_hspp_file mod_summary
......@@ -342,8 +343,32 @@ hscParse' mod_summary = do
ppr rdr_module
liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
ppSourceStats False rdr_module
return rdr_module
-- ToDo: free the string buffer later.
-- To get the list of extra source files, we take the list
-- that the parser gave us,
-- - eliminate files beginning with '<'. gcc likes to use
-- pseudo-filenames like "<built-in>" and "<command-line>"
-- - normalise them (elimiante differences between ./f and f)
-- - filter out the preprocessed source file
-- - filter out anything beginning with tmpdir
-- - remove duplicates
-- - filter out the .hs/.lhs source filename if we have one
--
let n_hspp = FilePath.normalise src_filename
srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`))
$ filter (not . (== n_hspp))
$ map FilePath.normalise
$ filter (not . (== '<') . head)
$ map unpackFS
$ srcfiles pst
srcs1 = case ml_hs_file (ms_location mod_summary) of
Just f -> filter (/= FilePath.normalise f) srcs0
Nothing -> srcs0
return HsParsedModule {
hpm_module = rdr_module,
hpm_src_files = srcs1
}
-- XXX: should this really be a Maybe X? Check under which circumstances this
-- can become a Nothing and decide whether this should instead throw an
......@@ -353,7 +378,7 @@ type RenamedStuff =
Maybe LHsDocString))
-- | Rename and typecheck a module, additionally returning the renamed syntax
hscTypecheckRename :: HscEnv -> ModSummary -> Located (HsModule RdrName)
hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
-> IO (TcGblEnv, RenamedStuff)
hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
tc_result <- {-# SCC "Typecheck-Rename" #-}
......@@ -784,13 +809,13 @@ batchMsg hsc_env mb_mod_index recomp mod_summary =
hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
hscFileFrontEnd mod_summary = do
rdr_module <- hscParse' mod_summary
hpm <- hscParse' mod_summary
hsc_env <- getHscEnv
dflags <- getDynFlags
tcg_env <-
{-# SCC "Typecheck-Rename" #-}
ioMsgMaybe $
tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
tcRnModule hsc_env (ms_hsc_src mod_summary) False hpm
tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_env)
-- end of the Safe Haskell line, how to respond to user?
......
......@@ -99,6 +99,9 @@ module HscTypes (
IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo,
trustInfoToNum, numToTrustInfo, IsSafeImport,
-- * result of the parser
HsParsedModule(..),
-- * Compilation errors and warnings
SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
throwOneError, handleSourceError,
......@@ -2041,6 +2044,24 @@ instance Outputable IfaceTrustInfo where
ppr (TrustInfo Sf_SafeInfered) = ptext $ sLit "safe-infered"
\end{code}
%************************************************************************
%* *
\subsection{Parser result}
%* *
%************************************************************************
\begin{code}
data HsParsedModule = HsParsedModule {
hpm_module :: Located (HsModule RdrName),
hpm_src_files :: [FilePath]
-- ^ extra source files (e.g. from #includes). The lexer collects
-- these from '# <file> <line>' pragmas, which the C preprocessor
-- leaves behind. These files and their timestamps are stored in
-- the .hi file, so that we can force recompilation if any of
-- them change (#3589)
}
\end{code}
%************************************************************************
%* *
\subsection{Linkable stuff}
......
......@@ -1129,6 +1129,7 @@ setFile code span buf len = do
let file = lexemeToFastString (stepOn buf) (len-2)
setAlrLastLoc $ alrInitialLoc file
setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
addSrcFile file
_ <- popLexState
pushLexState code
lexToken
......@@ -1482,6 +1483,7 @@ data PState = PState {
-- extensions
context :: [LayoutContext],
lex_state :: [Int],
srcfiles :: [FastString],
-- Used in the alternative layout rule:
-- These tokens are the next ones to be sent out. They are
-- just blindly emitted, without the rule looking at them again:
......@@ -1569,6 +1571,9 @@ setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
getSrcLoc :: P RealSrcLoc
getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
addSrcFile :: FastString -> P ()
addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } ()
setLastToken :: RealSrcSpan -> Int -> P ()
setLastToken loc len = P $ \s -> POk s {
last_loc=loc,
......@@ -1851,6 +1856,7 @@ mkPState flags buf loc =
extsBitmap = fromIntegral bitmap,
context = [],
lex_state = [bol, 0],
srcfiles = [],
alr_pending_implicit_tokens = [],
alr_next_token = Nothing,
alr_last_loc = alrInitialLoc (fsLit "<no file>"),
......
......@@ -121,13 +121,18 @@ import Control.Monad
tcRnModule :: HscEnv
-> HscSource
-> Bool -- True <=> save renamed syntax
-> Located (HsModule RdrName)
-> HsParsedModule
-> IO (Messages, Maybe TcGblEnv)
tcRnModule hsc_env hsc_src save_rn_syntax
(L loc (HsModule maybe_mod export_ies
HsParsedModule {
hpm_module =
(L loc (HsModule maybe_mod export_ies
import_decls local_decls mod_deprec
maybe_doc_hdr))
maybe_doc_hdr)),
hpm_src_files =
src_files
}
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
......@@ -207,7 +212,10 @@ tcRnModule hsc_env hsc_src save_rn_syntax
-- Report unused names
reportUnusedNames export_ies tcg_env ;
-- Dump output and return
-- add extra source files to tcg_dependent_files
addDependentFiles src_files ;
-- Dump output and return
tcDump tcg_env ;
return tcg_env
}}}}
......
......@@ -513,6 +513,12 @@ getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
getDeclaredDefaultTys :: TcRn (Maybe [Type])
getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
addDependentFiles :: [FilePath] -> TcRn ()
addDependentFiles fs = do
ref <- fmap tcg_dependent_files getGblEnv
dep_files <- readTcRef ref
writeTcRef ref (fs ++ dep_files)
\end{code}
%************************************************************************
......
......@@ -294,7 +294,7 @@ data TcGblEnv
-- ^ Renamed decls, maybe. @Nothing@ <=> Don't retain renamed
-- decls.
tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile
tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile
tcg_ev_binds :: Bag EvBind, -- Top-level evidence bindings
tcg_binds :: LHsBinds Id, -- Value bindings in this module
......
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