Fix #481: use a safe recompilation check when Template Haskell is
authorSimon Marlow <marlowsd@gmail.com>
Wed, 20 Jul 2011 08:37:54 +0000 (09:37 +0100)
committerSimon Marlow <marlowsd@gmail.com>
Wed, 20 Jul 2011 09:48:48 +0000 (10:48 +0100)
being used.

We now track whether a module used any TH splices in the ModIface (and
at compile time in the TcGblEnv and ModGuts).  If a module used TH
splices last time it was compiled, then we ignore the results of the
normal recompilation check and recompile anyway, *unless* the module
is "stable" - that is, none of its dependencies (direct or indirect)
have changed.  The stability test is pretty important - otherwise ghc
--make would always recompile TH modules even if nothing at all had
changed, but it does require some extra plumbing to get this
information from GhcMake into HscMain.

test in driver/recomp009

13 files changed:
compiler/deSugar/Desugar.lhs
compiler/iface/BinIface.hs
compiler/iface/LoadIface.lhs
compiler/iface/MkIface.lhs
compiler/main/DriverPipeline.hs
compiler/main/GHC.hs
compiler/main/GhcMake.hs
compiler/main/HscMain.lhs
compiler/main/HscTypes.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcRnTypes.lhs
compiler/typecheck/TcSplice.lhs

index 5d045a8..93b444c 100644 (file)
@@ -61,7 +61,8 @@ deSugar hsc_env
                            tcg_imports      = imports,
                            tcg_exports      = exports,
                            tcg_keep         = keep_var,
-                           tcg_rdr_env      = rdr_env,
+                            tcg_th_splice_used = tc_splice_used,
+                            tcg_rdr_env      = rdr_env,
                            tcg_fix_env      = fix_env,
                            tcg_inst_env     = inst_env,
                            tcg_fam_inst_env = fam_inst_env,
@@ -147,13 +148,16 @@ deSugar hsc_env
         ; let used_names = mkUsedNames tcg_env
         ; deps <- mkDependencies tcg_env
 
-        ; let mod_guts = ModGuts {     
+        ; used_th <- readIORef tc_splice_used
+
+        ; let mod_guts = ModGuts {
                mg_module       = mod,
                mg_boot         = isHsBoot hsc_src,
                mg_exports      = exports,
                mg_deps         = deps,
                mg_used_names   = used_names,
-               mg_dir_imps     = imp_mods imports,
+                mg_used_th      = used_th,
+                mg_dir_imps     = imp_mods imports,
                mg_rdr_env      = rdr_env,
                mg_fix_env      = fix_env,
                mg_warns        = warns,
index 42507d9..336030c 100644 (file)
@@ -380,7 +380,8 @@ instance Binary ModIface where
                 mi_usages    = usages,
                 mi_exports   = exports,
                 mi_exp_hash  = exp_hash,
-                mi_fixities  = fixities,
+                 mi_used_th   = used_th,
+                 mi_fixities  = fixities,
                 mi_warns     = warns,
                 mi_anns      = anns,
                 mi_decls     = decls,
@@ -402,7 +403,8 @@ instance Binary ModIface where
        lazyPut bh usages
        put_ bh exports
        put_ bh exp_hash
-       put_ bh fixities
+        put_ bh used_th
+        put_ bh fixities
        lazyPut bh warns
        lazyPut bh anns
         put_ bh decls
@@ -426,7 +428,8 @@ instance Binary ModIface where
        usages    <- {-# SCC "bin_usages" #-} lazyGet bh
        exports   <- {-# SCC "bin_exports" #-} get bh
        exp_hash  <- get bh
-       fixities  <- {-# SCC "bin_fixities" #-} get bh
+        used_th   <- get bh
+        fixities  <- {-# SCC "bin_fixities" #-} get bh
        warns     <- {-# SCC "bin_warns" #-} lazyGet bh
        anns      <- {-# SCC "bin_anns" #-} lazyGet bh
         decls    <- {-# SCC "bin_tycldecls" #-} get bh
@@ -448,8 +451,9 @@ instance Binary ModIface where
                 mi_deps      = deps,
                 mi_usages    = usages,
                 mi_exports   = exports,
-                mi_exp_hash  = exp_hash,
-                mi_anns      = anns,
+                 mi_exp_hash  = exp_hash,
+                 mi_used_th   = used_th,
+                 mi_anns      = anns,
                 mi_fixities  = fixities,
                 mi_warns     = warns,
                 mi_decls     = decls,
index af94ce0..9b7a40f 100644 (file)
@@ -655,6 +655,7 @@ pprModIface iface
         , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface))
         , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface))
         , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface))
+        , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))
         , nest 2 (ptext (sLit "where"))
        , vcat (map pprExport (mi_exports iface))
        , pprDeps (mi_deps iface)
index 50406d2..d9765ce 100644 (file)
@@ -126,6 +126,7 @@ mkIface hsc_env maybe_old_fingerprint mod_details
          ModGuts{     mg_module     = this_mod,
                       mg_boot       = is_boot,
                       mg_used_names = used_names,
+                      mg_used_th    = used_th,
                       mg_deps       = deps,
                       mg_dir_imps   = dir_imp_mods,
                       mg_rdr_env    = rdr_env,
@@ -134,7 +135,7 @@ mkIface hsc_env maybe_old_fingerprint mod_details
                       mg_hpc_info   = hpc_info,
                       mg_trust_pkg  = self_trust }
         = mkIface_ hsc_env maybe_old_fingerprint
-                   this_mod is_boot used_names deps rdr_env fix_env
+                   this_mod is_boot used_names used_th deps rdr_env fix_env
                    warns hpc_info dir_imp_mods self_trust mod_details
 
 -- | make an interface from the results of typechecking only.  Useful
@@ -152,14 +153,16 @@ mkIfaceTc hsc_env maybe_old_fingerprint mod_details
                       tcg_rdr_env = rdr_env,
                       tcg_fix_env = fix_env,
                       tcg_warns = warns,
-                      tcg_hpc = other_hpc_info
+                      tcg_hpc = other_hpc_info,
+                      tcg_th_splice_used = tc_splice_used
                     }
   = do
           let used_names = mkUsedNames tc_result
           deps <- mkDependencies tc_result
           let hpc_info = emptyHpcInfo other_hpc_info
+          used_th <- readIORef tc_splice_used
           mkIface_ hsc_env maybe_old_fingerprint
-                   this_mod (isHsBoot hsc_src) used_names deps rdr_env 
+                   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
         
@@ -203,14 +206,14 @@ mkDependencies
                     -- NB. remember to use lexicographic ordering
 
 mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
-         -> NameSet -> Dependencies -> GlobalRdrEnv
+         -> NameSet -> Bool -> Dependencies -> GlobalRdrEnv
          -> NameEnv FixItem -> Warnings -> HpcInfo
          -> ImportedMods -> Bool
          -> ModDetails
          -> IO (Messages, Maybe (ModIface, Bool))
 mkIface_ hsc_env maybe_old_fingerprint 
-         this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info
-         dir_imp_mods pkg_trust_req
+         this_mod is_boot used_names used_th deps rdr_env fix_env src_warns
+         hpc_info dir_imp_mods pkg_trust_req
         ModDetails{  md_insts     = insts, 
                      md_fam_insts = fam_insts,
                      md_rules     = rules,
@@ -268,7 +271,8 @@ mkIface_ hsc_env maybe_old_fingerprint
                        mi_iface_hash = fingerprint0,
                        mi_mod_hash  = fingerprint0,
                        mi_exp_hash  = fingerprint0,
-                       mi_orphan_hash = fingerprint0,
+                        mi_used_th   = used_th,
+                        mi_orphan_hash = fingerprint0,
                        mi_orphan    = False,   -- Always set by addVersionInfo, but
                                                -- it's a strict field, so we can't omit it.
                         mi_finsts    = False,   -- Ditto
@@ -1032,21 +1036,20 @@ so we may need to split up a single Avail into multiple ones.
 \begin{code}
 checkOldIface :: HscEnv
              -> ModSummary
-             -> Bool                   -- Source unchanged
+              -> SourceModified
              -> Maybe ModIface         -- Old interface from compilation manager, if any
              -> IO (RecompileRequired, Maybe ModIface)
 
-checkOldIface hsc_env mod_summary source_unchanged maybe_iface
+checkOldIface hsc_env mod_summary source_modified maybe_iface
   = do  showPass (hsc_dflags hsc_env) $
             "Checking old interface for " ++ (showSDoc $ ppr $ ms_mod mod_summary)
         initIfaceCheck hsc_env $
-            check_old_iface hsc_env mod_summary source_unchanged maybe_iface
+            check_old_iface hsc_env mod_summary source_modified maybe_iface
 
-check_old_iface :: HscEnv -> ModSummary -> Bool -> Maybe ModIface
+check_old_iface :: HscEnv -> ModSummary -> SourceModified -> Maybe ModIface
                 -> IfG (Bool, Maybe ModIface)
-check_old_iface hsc_env mod_summary src_unchanged maybe_iface
-  = let src_changed = not src_unchanged
-        dflags = hsc_dflags hsc_env
+check_old_iface hsc_env mod_summary src_modified maybe_iface
+  = let dflags = hsc_dflags hsc_env
         getIface =
              case maybe_iface of
                  Just _  -> do
@@ -1064,23 +1067,34 @@ check_old_iface hsc_env mod_summary src_unchanged maybe_iface
                              return $ Just iface
 
     in do
-        when src_changed
+         let src_changed
+              | dopt Opt_ForceRecomp (hsc_dflags hsc_env) = True
+              | SourceModified <- src_modified = True
+              | otherwise = False
+
+         when src_changed
              (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
 
-         -- If the source has changed and we're in interactive mode, avoid reading
-         -- an interface; just return the one we might have been supplied with.
-        if not (isObjectTarget $ hscTarget dflags) && src_changed
+         -- If the source has changed and we're in interactive mode,
+         -- avoid reading an interface; just return the one we might
+         -- have been supplied with.
+         if not (isObjectTarget $ hscTarget dflags) && src_changed
             then return (outOfDate, maybe_iface)
             else do
                 -- Try and read the old interface for the current module
                 -- from the .hi file left from the last time we compiled it
                 maybe_iface' <- getIface
+                if src_changed
+                   then return (outOfDate, maybe_iface')
+                   else do
                 case maybe_iface' of
                     Nothing -> return (outOfDate, maybe_iface')
-                    Just iface -> do
-                        -- We have got the old iface; check its versions
-                        recomp <- checkVersions hsc_env src_unchanged mod_summary iface
-                        return recomp
+                    Just iface ->
+                      -- We have got the old iface; check its versions
+                      -- even in the SourceUnmodifiedAndStable case we
+                      -- should check versions because some packages
+                      -- might have changed or gone away.
+                      checkVersions hsc_env mod_summary iface
 \end{code}
 
 @recompileRequired@ is called from the HscMain.   It checks whether
@@ -1101,16 +1115,10 @@ safeHsChanged hsc_env iface
   = (getSafeMode $ mi_trust iface) /= (safeHaskell $ hsc_dflags hsc_env)
 
 checkVersions :: HscEnv
-             -> Bool           -- True <=> source unchanged
               -> ModSummary
              -> ModIface       -- Old interface
              -> IfG (RecompileRequired, Maybe ModIface)
-checkVersions hsc_env source_unchanged mod_summary iface
-  | not source_unchanged
-  = let iface' = if safeHsChanged hsc_env iface then Nothing else Just iface
-    in return (outOfDate, iface')
-
-  | otherwise
+checkVersions hsc_env mod_summary iface
   = do { traceHiDiffs (text "Considering whether compilation is required for" <+>
                         ppr (mi_module iface) <> colon)
 
index 746ea88..b328c3f 100644 (file)
@@ -101,6 +101,7 @@ compile :: HscEnv
         -> Int             -- ^ ... of M
         -> Maybe ModIface  -- ^ old interface, if we have one
         -> Maybe Linkable  -- ^ old linkable, if we have one
+        -> SourceModified
         -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful
 
 compile = compile' (hscCompileNothing, hscCompileInteractive, hscCompileBatch)
@@ -115,10 +116,12 @@ compile' ::
         -> Int             -- ^ ... of M
         -> Maybe ModIface  -- ^ old interface, if we have one
         -> Maybe Linkable  -- ^ old linkable, if we have one
+        -> SourceModified
         -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful
 
 compile' (nothingCompiler, interactiveCompiler, batchCompiler)
         hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
+        source_modified0
  = do
    let dflags0     = ms_hspp_opts summary
        this_mod    = ms_mod summary
@@ -156,7 +159,9 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler)
 
    -- -fforce-recomp should also work with --make
    let force_recomp = dopt Opt_ForceRecomp dflags
-       source_unchanged = isJust maybe_old_linkable && not force_recomp
+       source_modified
+         | force_recomp || isNothing maybe_old_linkable = SourceModified
+         | otherwise = source_modified0
        object_filename = ml_obj_file location
 
    let handleBatch HscNoRecomp
@@ -223,7 +228,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler)
        --            -> m HomeModInfo
        runCompiler compiler handle
            = do (result, iface, details)
-                    <- compiler hsc_env' summary source_unchanged mb_old_iface
+                    <- compiler hsc_env' summary source_modified mb_old_iface
                                 (Just (mod_index, nmods))
                 linkable <- handle result
                 return (HomeModInfo{ hm_details  = details,
@@ -893,22 +898,21 @@ runPhase (Hsc src_flavour) input_fn dflags0
   -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
         src_timestamp <- io $ getModificationTime (basename <.> suff)
 
-        let force_recomp = dopt Opt_ForceRecomp dflags
-            hsc_lang = hscTarget dflags
+        let hsc_lang = hscTarget dflags
         source_unchanged <- io $
-          if force_recomp || not (isStopLn stop)
-                -- Set source_unchanged to False unconditionally if
+          if not (isStopLn stop)
+                -- SourceModified unconditionally if
                 --      (a) recompilation checker is off, or
                 --      (b) we aren't going all the way to .o file (e.g. ghc -S)
-             then return False
+             then return SourceModified
                 -- Otherwise look at file modification dates
              else do o_file_exists <- doesFileExist o_file
                      if not o_file_exists
-                        then return False       -- Need to recompile
+                        then return SourceModified       -- Need to recompile
                         else do t2 <- getModificationTime o_file
                                 if t2 > src_timestamp
-                                  then return True
-                                  else return False
+                                  then return SourceUnmodified
+                                  else return SourceModified
 
   -- get the DynFlags
         let next_phase = hscNextPhase dflags src_flavour hsc_lang
index c0c5a96..3ebfd52 100644 (file)
@@ -737,12 +737,17 @@ loadModule tcm = do
                          return (Just l)
                      _otherwise -> return Nothing
                                                 
+   let source_modified | isNothing mb_linkable = SourceModified
+                       | otherwise             = SourceUnmodified
+                       -- we can't determine stability here
+
    -- compile doesn't change the session
    hsc_env <- getSession
    mod_info <- liftIO $ compile' (hscNothingBackendOnly     tcg,
                                   hscInteractiveBackendOnly tcg,
                                   hscBatchBackendOnly       tcg)
                                   hsc_env ms 1 1 Nothing mb_linkable
+                                  source_modified
 
    modifySession $ \e -> e{ hsc_HPT = addToUFM (hsc_HPT e) mod mod_info }
    return tcm
index 5dcea1b..afa8a1c 100644 (file)
@@ -735,15 +735,16 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
                                   where 
                                     iface = hm_iface hm_info
 
-           compile_it :: Maybe Linkable -> IO HomeModInfo
-           compile_it  mb_linkable = 
+            compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo
+            compile_it  mb_linkable src_modified =
                   compile hsc_env summary' mod_index nmods 
-                          mb_old_iface mb_linkable
+                          mb_old_iface mb_linkable src_modified
 
-            compile_it_discard_iface :: Maybe Linkable -> IO HomeModInfo
-            compile_it_discard_iface mb_linkable =
+            compile_it_discard_iface :: Maybe Linkable -> SourceModified
+                                     -> IO HomeModInfo
+            compile_it_discard_iface mb_linkable  src_modified =
                   compile hsc_env summary' mod_index nmods
-                          Nothing mb_linkable
+                          Nothing mb_linkable src_modified
 
             -- With the HscNothing target we create empty linkables to avoid
             -- recompilation.  We have to detect these to recompile anyway if
@@ -776,7 +777,7 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
                            (text "compiling stable on-disk mod:" <+> ppr this_mod_name)
                 linkable <- liftIO $ findObjectLinkable this_mod obj_fn
                               (expectJust "upsweep1" mb_obj_date)
-                compile_it (Just linkable)
+                compile_it (Just linkable) SourceUnmodifiedAndStable
                 -- object is stable, but we need to load the interface
                 -- off disk to make a HMI.
 
@@ -797,7 +798,7 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
             linkableTime l >= ms_hs_date summary -> do
                 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
                            (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)
-                compile_it (Just l)
+                compile_it (Just l) SourceUnmodified
                 -- we have an old BCO that is up to date with respect
                 -- to the source: do a recompilation check as normal.
 
@@ -819,17 +820,17 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
                       isObjectLinkable l && linkableTime l == obj_date -> do
                           liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
                                      (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)
-                          compile_it (Just l)
+                          compile_it (Just l) SourceUnmodified
                   _otherwise -> do
                           liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
                                      (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)
                           linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
-                          compile_it_discard_iface (Just linkable)
+                          compile_it_discard_iface (Just linkable) SourceUnmodified
 
          _otherwise -> do
                 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
                            (text "compiling mod:" <+> ppr this_mod_name)
-                compile_it Nothing
+                compile_it Nothing SourceModified
 
 
 
index 266395d..0ae32f8 100644 (file)
@@ -484,7 +484,7 @@ type InteractiveResult = (InteractiveStatus, ModIface, ModDetails)
 --        'interactive' mode. They should be removed from 'oneshot' mode.
 type Compiler result =  HscEnv
                      -> ModSummary
-                     -> Bool                -- True <=> source unchanged
+                     -> SourceModified
                      -> Maybe ModIface      -- Old interface, if available
                      -> Maybe (Int,Int)     -- Just (i,n) <=> module i of n (for msgs)
                      -> IO result
@@ -512,38 +512,64 @@ data HsCompiler a
   }
 
 genericHscCompile :: HsCompiler a
-                  -> (HscEnv -> Maybe (Int,Int) -> Bool -> ModSummary -> IO ())
-                  -> HscEnv -> ModSummary -> Bool
+                  -> (HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO ())
+                  -> HscEnv -> ModSummary -> SourceModified
                   -> Maybe ModIface -> Maybe (Int, Int)
                   -> IO a
 genericHscCompile compiler hscMessage hsc_env
-                  mod_summary source_unchanged
+                  mod_summary source_modified
                   mb_old_iface0 mb_mod_index
  = do
      (recomp_reqd, mb_checked_iface)
          <- {-# SCC "checkOldIface" #-}
             checkOldIface hsc_env mod_summary 
-                          source_unchanged mb_old_iface0
+                          source_modified mb_old_iface0
      -- save the interface that comes back from checkOldIface.
      -- In one-shot mode we don't have the old iface until this
      -- point, when checkOldIface reads it from the disk.
      let mb_old_hash = fmap mi_iface_hash mb_checked_iface
+
+     let
+       skip iface = do
+         hscMessage hsc_env mb_mod_index RecompNotRequired mod_summary
+         runHsc hsc_env $ hscNoRecomp compiler iface
+
+       compile reason = do
+         hscMessage hsc_env mb_mod_index reason mod_summary
+         runHsc hsc_env $ hscRecompile compiler mod_summary mb_old_hash
+
+       stable = case source_modified of
+                  SourceUnmodifiedAndStable -> True
+                  _ -> False
+
+        -- If the module used TH splices when it was last compiled,
+        -- then the recompilation check is not accurate enough (#481)
+        -- and we must ignore it.  However, if the module is stable
+        -- (none of the modules it depends on, directly or indirectly,
+        -- changed), then we *can* skip recompilation.  This is why
+        -- the SourceModified type contains SourceUnmodifiedAndStable,
+        -- and it's pretty important: otherwise ghc --make would
+        -- always recompile TH modules, even if nothing at all has
+        -- changed.  Stability is just the same check that make is
+        -- doing for us in one-shot mode.
+
      case mb_checked_iface of
-       Just iface | not recomp_reqd
-           -> do hscMessage hsc_env mb_mod_index False mod_summary
-                 runHsc hsc_env $ hscNoRecomp compiler iface
-       _otherwise
-           -> do hscMessage hsc_env mb_mod_index True mod_summary
-                 runHsc hsc_env $ hscRecompile compiler mod_summary mb_old_hash
+       Just iface | not recomp_reqd ->
+           if mi_used_th iface && not stable
+               then compile RecompForcedByTH
+               else skip iface
+       _otherwise ->
+           compile RecompRequired
+
 
 hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a
 hscCheckRecompBackend compiler tc_result 
-                   hsc_env mod_summary source_unchanged mb_old_iface _m_of_n
+                   hsc_env mod_summary source_modified mb_old_iface _m_of_n
   = do
      (recomp_reqd, mb_checked_iface)
          <- {-# SCC "checkOldIface" #-}
             checkOldIface hsc_env mod_summary
-                          source_unchanged mb_old_iface
+                          source_modified mb_old_iface
 
      let mb_old_hash = fmap mi_iface_hash mb_checked_iface
      case mb_checked_iface of
@@ -746,24 +772,31 @@ genModDetails old_iface
 -- Progress displayers.
 --------------------------------------------------------------
 
-oneShotMsg :: HscEnv -> Maybe (Int,Int) -> Bool -> ModSummary -> IO ()
-oneShotMsg hsc_env _mb_mod_index recomp _mod_summary =
-         if recomp
-            then return ()
-            else compilationProgressMsg (hsc_dflags hsc_env) $
-                     "compilation IS NOT required"
+data RecompReason = RecompNotRequired | RecompRequired | RecompForcedByTH
+  deriving Eq
 
-batchMsg :: HscEnv -> Maybe (Int,Int) -> Bool -> ModSummary -> IO ()
+oneShotMsg :: HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO ()
+oneShotMsg hsc_env _mb_mod_index recomp _mod_summary =
+  case recomp of
+    RecompNotRequired ->
+            compilationProgressMsg (hsc_dflags hsc_env) $
+                   "compilation IS NOT required"
+    _other ->
+            return ()
+
+batchMsg :: HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO ()
 batchMsg hsc_env mb_mod_index recomp mod_summary
-  = do
-         let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $
-                           (showModuleIndex mb_mod_index ++
-                            msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) recomp mod_summary)
-         if recomp
-            then showMsg "Compiling "
-            else if verbosity (hsc_dflags hsc_env) >= 2
-                    then showMsg "Skipping  "
-                    else return ()
+ = case recomp of
+     RecompRequired -> showMsg "Compiling "
+     RecompNotRequired
+       | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping  "
+       | otherwise -> return ()
+     RecompForcedByTH -> showMsg "Compiling [TH] "
+   where
+     showMsg msg =
+        compilationProgressMsg (hsc_dflags hsc_env) $
+         (showModuleIndex mb_mod_index ++
+         msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) (recomp == RecompRequired) mod_summary)
 
 --------------------------------------------------------------
 -- FrontEnds
@@ -1410,6 +1443,7 @@ mkModGuts mod binds = ModGuts {
   mg_deps = noDependencies,
   mg_dir_imps = emptyModuleEnv,
   mg_used_names = emptyNameSet,
+  mg_used_th = False,
   mg_rdr_env = emptyGlobalRdrEnv,
   mg_fix_env = emptyFixityEnv,
   mg_types = emptyTypeEnv,
index f6494be..d43105b 100644 (file)
@@ -19,6 +19,7 @@ module HscTypes (
 
        ModSummary(..), ms_imps, ms_mod_name, showModMsg, isBootSummary,
        msHsFilePath, msHiFilePath, msObjFilePath,
+        SourceModified(..),
 
         -- * Information about the module being compiled
        HscSource(..), isHsBoot, hscSourceString,       -- Re-exported from DriverPhases
@@ -615,6 +616,8 @@ data ModIface
         
         mi_exp_hash :: !Fingerprint,   -- ^ Hash of export list
 
+        mi_used_th :: !Bool,  -- ^ Module required TH splices when it was compiled.  This disables recompilation avoidance (see #481).
+
         mi_fixities :: [(OccName,Fixity)],
                 -- ^ Fixities
         
@@ -734,7 +737,8 @@ data ModGuts
                                         -- generate initialisation code
        mg_used_names:: !NameSet,        -- ^ What the module needed (used in 'MkIface.mkIface')
 
-        mg_rdr_env   :: !GlobalRdrEnv,  -- ^ Top-level lexical environment
+        mg_used_th   :: !Bool,           -- ^ Did we run a TH splice?
+        mg_rdr_env   :: !GlobalRdrEnv,   -- ^ Top-level lexical environment
 
        -- These fields all describe the things **declared in this module**
        mg_fix_env   :: !FixityEnv,      -- ^ Fixities declared in this module
@@ -846,7 +850,8 @@ emptyModIface mod
               mi_usages   = [],
               mi_exports  = [],
               mi_exp_hash = fingerprint0,
-              mi_fixities = [],
+               mi_used_th  = False,
+               mi_fixities = [],
               mi_warns    = NoWarnings,
               mi_anns     = [],
               mi_insts     = [],
@@ -1722,6 +1727,30 @@ showModMsg target recomp mod_summary
     mod_str = showSDoc (ppr mod) ++ hscSourceString (ms_hsc_src mod_summary)
 \end{code}
 
+%************************************************************************
+%*                                                                     *
+\subsection{Recmpilation}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+-- | Indicates whether a given module's source has been modified since it
+-- was last compiled.
+data SourceModified
+  = SourceModified
+       -- ^ the source has been modified
+  | SourceUnmodified
+       -- ^ the source has not been modified.  Compilation may or may
+       -- not be necessary, depending on whether any dependencies have
+       -- changed since we last compiled.
+  | SourceUnmodifiedAndStable
+       -- ^ the source has not been modified, and furthermore all of
+       -- its (transitive) dependencies are up to date; it definitely
+       -- does not need to be recompiled.  This is important for two
+       -- reasons: (a) we can omit the version check in checkOldIface,
+       -- and (b) if the module used TH splices we don't need to force
+       -- recompilation.
+\end{code}
 
 %************************************************************************
 %*                                                                     *
index 1c289f1..4a4d556 100644 (file)
@@ -323,10 +323,11 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
        final_type_env = 
              extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
 
-       mod_guts = ModGuts {    mg_module    = this_mod,
+        mod_guts = ModGuts {    mg_module    = this_mod,
                                mg_boot      = False,
                                mg_used_names = emptyNameSet, -- ToDo: compute usage
-                               mg_dir_imps  = emptyModuleEnv, -- ??
+                                mg_used_th   = False,
+                                mg_dir_imps  = emptyModuleEnv, -- ??
                                mg_deps      = noDependencies,  -- ??
                                mg_exports   = my_exports,
                                mg_types     = final_type_env,
index 2b78ab3..6fb09c5 100644 (file)
@@ -74,7 +74,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
        tvs_var      <- newIORef emptyVarSet ;
         keep_var     <- newIORef emptyNameSet ;
         used_rdr_var <- newIORef Set.empty ;
-       th_var       <- newIORef False ;
+        th_var       <- newIORef False ;
+        th_splice_var<- newIORef False ;
         lie_var      <- newIORef emptyWC ;
        dfun_n_var   <- newIORef emptyOccSet ;
        type_env_var <- case hsc_type_env_var hsc_env of {
@@ -98,7 +99,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                tcg_inst_env  = emptyInstEnv,
                tcg_fam_inst_env  = emptyFamInstEnv,
                 tcg_th_used   = th_var,
-               tcg_exports  = [],
+                tcg_th_splice_used   = th_splice_var,
+                tcg_exports  = [],
                tcg_imports  = emptyImportAvails,
                 tcg_used_rdrnames = used_rdr_var,
                tcg_dus      = emptyDUs,
@@ -1048,6 +1050,9 @@ traceTcConstraints msg
 recordThUse :: TcM ()
 recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
 
+recordThSpliceUse :: TcM ()
+recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }
+
 keepAliveTc :: Id -> TcM ()    -- Record the name in the keep-alive set
 keepAliveTc id 
   | isLocalId id = do { env <- getGblEnv; 
index 0e2f661..c618da0 100644 (file)
@@ -236,6 +236,11 @@ data TcGblEnv
           -- is implicit rather than explicit, so we have to zap a
           -- mutable variable.
 
+        tcg_th_splice_used :: TcRef Bool,
+          -- ^ @True@ <=> A Template Haskell splice was used.
+          --
+          -- Splices disable recompilation avoidance (see #481)
+
        tcg_dfun_n  :: TcRef OccSet,
           -- ^ Allows us to choose unique DFun names.
 
index 97ad485..3e9623c 100644 (file)
@@ -810,6 +810,8 @@ runMeta :: (Outputable hs_syn)
        -> TcM hs_syn           -- Of type t
 runMeta show_code run_and_convert expr
   = do { traceTc "About to run" (ppr expr)
+        ; recordThSpliceUse -- seems to be the best place to do this,
+                            -- we catch all kinds of splices and annotations.
 
        -- Desugar
        ; ds_expr <- initDsTc (dsLExpr expr)