addDependentFile #4900

Let GHC know about an external dependency that Template Haskell uses
so that GHC can recompile when the dependency changes.
No support for ghc -M

There is a corresponding addition to the template-haskell library

compiler/deSugar/Desugar.lhs

@@ -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)
 	}}}

compiler/iface/BinIface.hs

@@ -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

compiler/iface/LoadIface.lhs

@@ -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'

compiler/iface/MkIface.lhs

@@ -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

compiler/main/HscMain.hs

@@ -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 = []
     }
 
 

compiler/main/HscTypes.lhs

@@ -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:
@@ -1592,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

compiler/typecheck/TcRnDriver.lhs

@@ -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 ;

compiler/typecheck/TcRnMonad.lhs

@@ -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,

compiler/typecheck/TcRnTypes.lhs

@@ -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

compiler/typecheck/TcSplice.lhs

@@ -946,6 +946,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}