Commit 017897cf authored by Ian Lynagh's avatar Ian Lynagh

Merge branch 'dependent7' of https://github.com/gregwebs/ghc

parents e37c0541 b994313a
......@@ -80,6 +80,7 @@ deSugar hsc_env
tcg_anns = anns,
tcg_binds = binds,
tcg_imp_specs = imp_specs,
tcg_dependent_files = dependent_files,
tcg_ev_binds = ev_binds,
tcg_fords = fords,
tcg_rules = rules,
......@@ -168,6 +169,7 @@ deSugar hsc_env
; deps <- mkDependencies tcg_env
; used_th <- readIORef tc_splice_used
; dep_files <- readIORef dependent_files
; let mod_guts = ModGuts {
mg_module = mod,
......@@ -194,7 +196,8 @@ deSugar hsc_env
mg_modBreaks = modBreaks,
mg_vect_decls = ds_vects,
mg_vect_info = noVectInfo,
mg_trust_pkg = imp_trust_own_pkg imports
mg_trust_pkg = imp_trust_own_pkg imports,
mg_dependent_files = dep_files
}
; return (msgs, Just mod_guts)
}}}
......
......@@ -60,6 +60,7 @@ import Data.Word
import Data.Array
import Data.IORef
import Control.Monad
import System.Time ( ClockTime(..) )
data CheckHiWay = CheckHiWay | IgnoreHiWay
deriving Eq
......@@ -621,19 +622,35 @@ instance Binary AvailInfo where
ac <- get bh
return (AvailTC ab ac)
-- where should this be located?
instance Binary ClockTime where
put_ bh (TOD x y) = put_ bh x >> put_ bh y
get bh = do
x <- get bh
y <- get bh
return $ TOD x y
instance Binary Usage where
put_ bh usg@UsagePackageModule{} = do
putByte bh 0
put_ bh (usg_mod usg)
put_ bh (usg_mod_hash usg)
put_ bh (usg_safe usg)
put_ bh (usg_mod usg)
put_ bh (usg_mod_hash usg)
put_ bh (usg_safe usg)
put_ bh usg@UsageHomeModule{} = do
putByte bh 1
put_ bh (usg_mod_name usg)
put_ bh (usg_mod_hash usg)
put_ bh (usg_exports usg)
put_ bh (usg_entities usg)
put_ bh (usg_safe usg)
put_ bh (usg_mod_name usg)
put_ bh (usg_mod_hash usg)
put_ bh (usg_exports usg)
put_ bh (usg_entities usg)
put_ bh (usg_safe usg)
put_ bh usg@UsageFile{} = do
putByte bh 2
put_ bh (usg_file_path usg)
put_ bh (usg_mtime usg)
get bh = do
h <- getByte bh
......@@ -643,7 +660,7 @@ instance Binary Usage where
mod <- get bh
safe <- get bh
return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe }
_ -> do
1 -> do
nm <- get bh
mod <- get bh
exps <- get bh
......@@ -651,6 +668,11 @@ instance Binary Usage where
safe <- get bh
return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
usg_exports = exps, usg_entities = ents, usg_safe = safe }
2 -> do
fp <- get bh
mtime <- get bh
return UsageFile { usg_file_path = fp, usg_mtime = mtime }
i -> error ("Binary.get(Usage): " ++ show i)
instance Binary Warnings where
put_ bh NoWarnings = putByte bh 0
......
......@@ -707,6 +707,8 @@ pprUsage usage@UsageHomeModule{}
maybe empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$
vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]
)
pprUsage usage@UsageFile{}
= hsep [ptext (sLit "addDependentFile"), ppr (usg_file_path usage)]
pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc
pprUsageImport usage usg_mod'
......
......@@ -50,6 +50,8 @@ Basic idea:
of the external reference when computing the fingerprint of A.f. So
if anything that A.f depends on changes, then A.f's fingerprint will
change.
Also record any dependent files added with addDependentFile.
In the future record any #include usages.
* In checkOldIface we compare the mi_usages for the module with
the actual fingerprint for all each thing recorded in mi_usages
......@@ -109,6 +111,7 @@ import Data.Map (Map)
import qualified Data.Map as Map
import Data.IORef
import System.FilePath
import System.Directory (getModificationTime)
\end{code}
......@@ -141,10 +144,12 @@ mkIface hsc_env maybe_old_fingerprint mod_details
mg_fix_env = fix_env,
mg_warns = warns,
mg_hpc_info = hpc_info,
mg_trust_pkg = self_trust }
mg_trust_pkg = self_trust,
mg_dependent_files = dependent_files
}
= mkIface_ hsc_env maybe_old_fingerprint
this_mod is_boot used_names used_th deps rdr_env fix_env
warns hpc_info dir_imp_mods self_trust mod_details
warns hpc_info dir_imp_mods self_trust dependent_files mod_details
-- | make an interface from the results of typechecking only. Useful
-- for non-optimising compilation, or where we aren't generating any
......@@ -162,17 +167,19 @@ mkIfaceTc hsc_env maybe_old_fingerprint mod_details
tcg_fix_env = fix_env,
tcg_warns = warns,
tcg_hpc = other_hpc_info,
tcg_th_splice_used = tc_splice_used
tcg_th_splice_used = tc_splice_used,
tcg_dependent_files = dependent_files
}
= do
let used_names = mkUsedNames tc_result
deps <- mkDependencies tc_result
let hpc_info = emptyHpcInfo other_hpc_info
used_th <- readIORef tc_splice_used
dep_files <- (readIORef dependent_files)
mkIface_ hsc_env maybe_old_fingerprint
this_mod (isHsBoot hsc_src) used_names used_th deps rdr_env
fix_env warns hpc_info (imp_mods imports)
(imp_trust_own_pkg imports) mod_details
(imp_trust_own_pkg imports) dep_files mod_details
mkUsedNames :: TcGblEnv -> NameSet
......@@ -217,11 +224,12 @@ mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
-> NameSet -> Bool -> Dependencies -> GlobalRdrEnv
-> NameEnv FixItem -> Warnings -> HpcInfo
-> ImportedMods -> Bool
-> [FilePath]
-> ModDetails
-> IO (Messages, Maybe (ModIface, Bool))
mkIface_ hsc_env maybe_old_fingerprint
this_mod is_boot used_names used_th deps rdr_env fix_env src_warns
hpc_info dir_imp_mods pkg_trust_req
hpc_info dir_imp_mods pkg_trust_req dependent_files
ModDetails{ md_insts = insts,
md_fam_insts = fam_insts,
md_rules = rules,
......@@ -234,7 +242,7 @@ mkIface_ hsc_env maybe_old_fingerprint
-- put exactly the info into the TypeEnv that we want
-- to expose in the interface
= do { usages <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names
= do { usages <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files
; safeInf <- hscGetSafeInf hsc_env
; let { entities = typeEnvElts type_env ;
......@@ -846,23 +854,27 @@ mkOrphMap get_key decls
%************************************************************************
\begin{code}
mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> IO [Usage]
mkUsageInfo hsc_env this_mod dir_imp_mods used_names
mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> IO [Usage]
mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files
= do { eps <- hscEPS hsc_env
; let usages = mk_usage_info (eps_PIT eps) hsc_env this_mod
; mtimes <- mapM getModificationTime dependent_files
; let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod
dir_imp_mods used_names
; let usages = mod_usages ++ map to_file_usage (zip dependent_files mtimes)
; usages `seqList` return usages }
-- seq the list of Usages returned: occasionally these
-- don't get evaluated for a while and we can end up hanging on to
-- the entire collection of Ifaces.
where
to_file_usage (f, mtime) = UsageFile { usg_file_path = f, usg_mtime = mtime }
mk_usage_info :: PackageIfaceTable
mk_mod_usage_info :: PackageIfaceTable
-> HscEnv
-> Module
-> ImportedMods
-> NameSet
-> [Usage]
mk_usage_info pit hsc_env this_mod direct_imports used_names
mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
= mapCatMaybes mkUsage usage_mods
where
hpt = hsc_HPT hsc_env
......@@ -1266,6 +1278,13 @@ checkModUsage this_pkg UsageHomeModule{
if recompile
then return outOfDate -- This one failed, so just bail out now
else up_to_date (ptext (sLit " Great! The bits I use are up to date"))
checkModUsage _this_pkg UsageFile{ usg_file_path = file, usg_mtime = old_mtime } = do
new_mtime <- liftIO $ getModificationTime file
return $ old_mtime /= new_mtime
------------------------
checkModuleFingerprint :: Fingerprint -> Fingerprint -> IfG Bool
......
......@@ -1517,7 +1517,8 @@ mkModGuts mod binds =
mg_vect_info = noVectInfo,
mg_inst_env = emptyInstEnv,
mg_fam_inst_env = emptyFamInstEnv,
mg_trust_pkg = False
mg_trust_pkg = False,
mg_dependent_files = []
}
......
......@@ -792,9 +792,10 @@ data ModGuts
mg_fam_inst_env :: FamInstEnv,
-- ^ Type-family instance enviroment for /home-package/ modules
-- (including this one); c.f. 'tcg_fam_inst_env'
mg_trust_pkg :: Bool
mg_trust_pkg :: Bool,
-- ^ Do we need to trust our own package for Safe Haskell?
-- See Note [RnNames . Trust Own Package]
mg_dependent_files :: [FilePath] -- ^ dependencies from addDependentFile
}
-- The ModGuts takes on several slightly different forms:
......@@ -803,12 +804,6 @@ data ModGuts
-- mg_rules Orphan rules only (local ones now attached to binds)
-- mg_binds With rules attached
-- The ModGuts takes on several slightly different forms:
--
-- After simplification, the following fields change slightly:
-- mg_rules Orphan rules only (local ones now attached to binds)
-- mg_binds With rules attached
---------------------------------------------------------
-- The Tidy pass forks the information about this module:
......@@ -1598,7 +1593,12 @@ data Usage
-- if we depend on the export list
usg_safe :: IsSafeImport
-- ^ Was this module imported as a safe import
}
} -- ^ Module from the current package
| UsageFile {
usg_file_path :: FilePath,
usg_mtime :: ClockTime
-- ^ External file dependency. From a CPP #include or TH addDependentFile. Should be absolute.
}
deriving( Eq )
-- The export list field is (Just v) if we depend on the export list:
-- i.e. we imported the module directly, whether or not we
......
......@@ -85,6 +85,7 @@ import Class
import TcType ( orphNamesOfDFunHead )
import Inst ( tcGetInstEnvs )
import Data.List ( sortBy )
import Data.IORef ( readIORef )
#ifdef GHCI
import TcType ( isUnitTy, isTauTy )
......@@ -333,6 +334,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
-- Just discard the auxiliary bindings; they are generated
-- only for Haskell source code, and should already be in Core
(tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ;
dep_files <- liftIO $ readIORef (tcg_dependent_files tcg_env) ;
setGblEnv tcg_env $ do {
-- Make the new type env available to stuff slurped from interface files
......@@ -340,6 +342,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
-- Now the core bindings
core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
-- Wrap up
let {
bndrs = bindersOfBinds core_binds ;
......@@ -372,7 +375,8 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
mg_hpc_info = emptyHpcInfo False,
mg_modBreaks = emptyModBreaks,
mg_vect_info = noVectInfo,
mg_trust_pkg = False
mg_trust_pkg = False,
mg_dependent_files = dep_files
} } ;
tcCoreDump mod_guts ;
......
......@@ -87,6 +87,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
type_env_var <- case hsc_type_env_var hsc_env of {
Just (_mod, te_var) -> return te_var ;
Nothing -> newIORef emptyNameEnv } ;
dependent_files_var <- newIORef [] ;
let {
maybe_rn_syntax :: forall a. a -> Maybe a ;
maybe_rn_syntax empty_val
......@@ -133,7 +135,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
tcg_doc_hdr = Nothing,
tcg_hpc = False,
tcg_main = Nothing,
tcg_safeInfer = infer_var
tcg_safeInfer = infer_var,
tcg_dependent_files = dependent_files_var
} ;
lcl_env = TcLclEnv {
tcl_errs = errs_var,
......
......@@ -288,6 +288,8 @@ data TcGblEnv
-- ^ Renamed decls, maybe. @Nothing@ <=> Don't retain renamed
-- decls.
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
tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature
......
......@@ -929,6 +929,11 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
}
qRunIO io = liftIO io
qAddDependentFile fp = do
ref <- fmap tcg_dependent_files getGblEnv
dep_files <- readTcRef ref
writeTcRef ref (fp:dep_files)
\end{code}
......
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