Fix #481: use a safe recompilation check when Template Haskell is
[ghc.git] / compiler / main / HscMain.lhs
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,