Refactor the pipeline/hsc interaction
authorIan Lynagh <ian@well-typed.com>
Thu, 7 Mar 2013 16:19:24 +0000 (16:19 +0000)
committerIan Lynagh <ian@well-typed.com>
Thu, 7 Mar 2013 17:06:08 +0000 (17:06 +0000)
It would probably still benefit from some tidying up, but it's now
much more opaque, with the control flow easier to understand.

compiler/main/DriverPipeline.hs
compiler/main/GHC.hs
compiler/main/GhcMake.hs
compiler/main/HscMain.hs

index 240cbf4..0782845 100644 (file)
@@ -20,7 +20,7 @@ module DriverPipeline (
 
         -- Interfaces for the compilation manager (interpreted/batch-mode)
    preprocess,
-   compile, compile',
+   compileOne, compileOne',
    link,
 
   ) where
@@ -51,6 +51,7 @@ import FastString
 import LlvmCodeGen      ( llvmFixupAsm )
 import MonadUtils
 import Platform
+import TcRnTypes
 
 import Exception
 import Data.IORef       ( readIORef )
@@ -94,33 +95,31 @@ preprocess hsc_env (filename, mb_phase) =
 --
 -- NB.  No old interface can also mean that the source has changed.
 
-compile :: HscEnv
-        -> ModSummary      -- ^ summary for module being compiled
-        -> Int             -- ^ module N ...
-        -> 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)
-
-compile' :: 
-           (Compiler (HscStatus, ModIface, ModDetails),
-            Compiler (InteractiveStatus, ModIface, ModDetails),
-            Compiler (FileOutputStatus, ModIface, ModDetails))
-        -> HscEnv
-        -> ModSummary      -- ^ summary for module being compiled
-        -> Int             -- ^ module N ...
-        -> 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
+compileOne :: HscEnv
+           -> ModSummary      -- ^ summary for module being compiled
+           -> Int             -- ^ module N ...
+           -> 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
+
+compileOne = compileOne' Nothing (Just batchMsg)
+
+compileOne' :: Maybe TcGblEnv
+            -> Maybe Messager
+            -> HscEnv
+            -> ModSummary      -- ^ summary for module being compiled
+            -> Int             -- ^ module N ...
+            -> 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
+
+compileOne' m_tc_result mHscMessage
+            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
@@ -160,80 +159,101 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler)
          | otherwise = source_modified0
        object_filename = ml_obj_file location
 
-   let handleBatch HscNoRecomp
-           = ASSERT (isJust maybe_old_linkable)
-             return maybe_old_linkable
-
-       handleBatch (HscRecomp hasStub _)
-           | isHsBoot src_flavour
-               = do when (isObjectTarget hsc_lang) $ -- interpreted reaches here too
-                       liftIO $ touchObjectFile dflags' object_filename
-                    return maybe_old_linkable
-
-           | otherwise
-               = do (hs_unlinked, unlinked_time) <-
-                        case hsc_lang of
-                          HscNothing ->
-                            return ([], ms_hs_date summary)
-                          -- We're in --make mode: finish the compilation pipeline.
-                          _other -> do
-                            maybe_stub_o <- case hasStub of
-                               Nothing -> return Nothing
-                               Just stub_c -> do
-                                 stub_o <- compileStub hsc_env' stub_c
-                                 return (Just stub_o)
-                            _ <- runPipeline StopLn hsc_env' (output_fn,Nothing)
-                                              (Just basename)
-                                              Persistent
-                                              (Just location)
-                                              maybe_stub_o
-                                  -- The object filename comes from the ModLocation
-                            o_time <- getModificationUTCTime object_filename
-                            return ([DotO object_filename], o_time)
-                    
-                    let linkable = LM unlinked_time this_mod hs_unlinked
-                    return (Just linkable)
-
-       handleInterpreted HscNoRecomp
-           = ASSERT (isJust maybe_old_linkable)
-             return maybe_old_linkable
-       handleInterpreted (HscRecomp _hasStub Nothing)
-           = ASSERT (isHsBoot src_flavour)
-             return maybe_old_linkable
-       handleInterpreted (HscRecomp hasStub (Just (comp_bc, modBreaks)))
-           = do stub_o <- case hasStub of
-                            Nothing -> return []
-                            Just stub_c -> do
-                              stub_o <- compileStub hsc_env' stub_c
-                              return [DotO stub_o]
-
-                let hs_unlinked = [BCOs comp_bc modBreaks]
-                    unlinked_time = ms_hs_date summary
-                  -- Why do we use the timestamp of the source file here,
-                  -- rather than the current time?  This works better in
-                  -- the case where the local clock is out of sync
-                  -- with the filesystem's clock.  It's just as accurate:
-                  -- if the source is modified, then the linkable will
-                  -- be out of date.
-                let linkable = LM unlinked_time this_mod
-                               (hs_unlinked ++ stub_o)
-                return (Just linkable)
-
-   let -- runCompiler :: Compiler result -> (result -> Maybe Linkable)
-       --            -> m HomeModInfo
-       runCompiler compiler handle
-           = do (result, iface, details)
-                    <- compiler hsc_env' summary source_modified mb_old_iface
-                                (Just (mod_index, nmods))
-                linkable <- handle result
-                return (HomeModInfo{ hm_details  = details,
-                                     hm_iface    = iface,
-                                     hm_linkable = linkable })
-   -- run the compiler
-   case hsc_lang of
-      HscInterpreted -> runCompiler interactiveCompiler handleInterpreted
-      HscNothing     -> runCompiler nothingCompiler     handleBatch
-      _other         -> runCompiler batchCompiler       handleBatch
+   let always_do_basic_recompilation_check = case hsc_lang of
+                                             HscInterpreted -> True
+                                             _ -> False
+
+   e <- genericHscCompileGetFrontendResult
+            always_do_basic_recompilation_check
+            m_tc_result mHscMessage
+            hsc_env' summary source_modified mb_old_iface (mod_index, nmods)
+
+   case e of
+       Left iface ->
+           do details <- genModDetails hsc_env iface
+              MASSERT (isJust maybe_old_linkable)
+              return (HomeModInfo{ hm_details  = details,
+                                   hm_iface    = iface,
+                                   hm_linkable = maybe_old_linkable })
+
+       Right (tc_result, mb_old_hash) ->
+           -- run the compiler
+           case hsc_lang of
+               HscInterpreted ->
+                   case ms_hsc_src summary of
+                   HsBootFile ->
+                       do (iface, _changed, details) <- hscSimpleIface hsc_env' tc_result mb_old_hash
+                          return (HomeModInfo{ hm_details  = details,
+                                               hm_iface    = iface,
+                                               hm_linkable = maybe_old_linkable })
+                   _ -> do guts0 <- hscDesugar hsc_env' summary tc_result
+                           guts <- hscSimplify hsc_env' guts0
+                           (iface, _changed, details, cgguts) <- hscNormalIface hsc_env' guts mb_old_hash
+                           HscRecomp hasStub (comp_bc, modBreaks) <- hscInteractive hsc_env' cgguts summary
+
+                           stub_o <- case hasStub of
+                                     Nothing -> return []
+                                     Just stub_c -> do
+                                         stub_o <- compileStub hsc_env' stub_c
+                                         return [DotO stub_o]
+
+                           let hs_unlinked = [BCOs comp_bc modBreaks]
+                               unlinked_time = ms_hs_date summary
+                             -- Why do we use the timestamp of the source file here,
+                             -- rather than the current time?  This works better in
+                             -- the case where the local clock is out of sync
+                             -- with the filesystem's clock.  It's just as accurate:
+                             -- if the source is modified, then the linkable will
+                             -- be out of date.
+                           let linkable = LM unlinked_time this_mod
+                                          (hs_unlinked ++ stub_o)
+
+                           return (HomeModInfo{ hm_details  = details,
+                                                hm_iface    = iface,
+                                                hm_linkable = Just linkable })
+               HscNothing ->
+                   do (iface, _changed, details) <- hscSimpleIface hsc_env' tc_result mb_old_hash
+                      let linkable = if isHsBoot src_flavour
+                                     then maybe_old_linkable
+                                     else Just (LM (ms_hs_date summary) this_mod [])
+                      return (HomeModInfo{ hm_details  = details,
+                                           hm_iface    = iface,
+                                           hm_linkable = linkable })
+
+               _ ->
+                   case ms_hsc_src summary of
+                   HsBootFile ->
+                       do (iface, changed, details) <- hscSimpleIface hsc_env' tc_result mb_old_hash
+                          hscWriteIface dflags' iface changed summary
+                          touchObjectFile dflags' object_filename
+                          return (HomeModInfo{ hm_details  = details,
+                                               hm_iface    = iface,
+                                               hm_linkable = maybe_old_linkable })
+
+                   _ -> do guts0 <- hscDesugar hsc_env' summary tc_result
+                           guts <- hscSimplify hsc_env' guts0
+                           (iface, changed, details, cgguts) <- hscNormalIface hsc_env' guts mb_old_hash
+                           hscWriteIface dflags' iface changed summary
+                           (_outputFilename, hasStub) <- hscGenHardCode hsc_env' cgguts summary
+
+                           -- We're in --make mode: finish the compilation pipeline.
+                           maybe_stub_o <- case hasStub of
+                                      Nothing -> return Nothing
+                                      Just stub_c -> do
+                                          stub_o <- compileStub hsc_env' stub_c
+                                          return (Just stub_o)
+                           _ <- runPipeline StopLn hsc_env' (output_fn,Nothing)
+                                             (Just basename)
+                                             Persistent
+                                             (Just location)
+                                             maybe_stub_o
+                                 -- The object filename comes from the ModLocation
+                           o_time <- getModificationUTCTime object_filename
+                           let linkable = LM o_time this_mod [DotO object_filename]
+
+                           return (HomeModInfo{ hm_details  = details,
+                                                hm_iface    = iface,
+                                                hm_linkable = Just linkable })
 
 -----------------------------------------------------------------------------
 -- stub .h and .c files (for foreign export support)
@@ -1005,17 +1025,15 @@ runPhase (Hsc src_flavour) input_fn dflags0
   -- run the compiler!
         result <- liftIO $ hscCompileOneShot hsc_env'
                                mod_summary source_unchanged
-                               Nothing -- No iface
-                               Nothing -- No "module i of n" progress info
 
         case result of
-          HscNoRecomp
+          Nothing
               -> do liftIO $ touchObjectFile dflags' o_file
                     -- The .o file must have a later modification date
-                    -- than the source file (else we wouldn't be in HscNoRecomp)
+                    -- than the source file (else we wouldn't get Nothing)
                     -- but we touch it anyway, to keep 'make' happy (we think).
                     return (StopLn, o_file)
-          (HscRecomp hasStub mOutputFilename)
+          (Just (HscRecomp hasStub mOutputFilename))
               -> do case hasStub of
                       Nothing -> return ()
                       Just stub_c ->
index 483da4b..4aa0495 100644 (file)
@@ -260,7 +260,7 @@ import InteractiveEval
 
 import HscMain
 import GhcMake
-import DriverPipeline   ( compile' )
+import DriverPipeline   ( compileOne' )
 import GhcMonad
 import TcRnMonad        ( finalSafeMode )
 import TcRnTypes
@@ -838,11 +838,9 @@ loadModule tcm = do
 
    -- 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
+   mod_info <- liftIO $ compileOne' (Just tcg) Nothing
+                                    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 81f338e..4970b67 100644 (file)
@@ -742,14 +742,14 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
 
             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 src_modified
+                  compileOne hsc_env summary' mod_index nmods
+                             mb_old_iface mb_linkable src_modified
 
             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 src_modified
+                  compileOne hsc_env summary' mod_index nmods
+                             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
index b7a37c3..83be1c0 100644 (file)
@@ -32,17 +32,21 @@ module HscMain
       newHscEnv
 
     -- * Compiling complete source files
-    , Compiler
-    , HscStatus' (..)
-    , FileOutputStatus
-    , InteractiveStatus, HscStatus
+    , Messager, batchMsg
+    , HscStatus (..)
     , hscCompileOneShot
-    , hscCompileBatch
-    , hscCompileNothing
-    , hscCompileInteractive
     , hscCompileCmmFile
     , hscCompileCore
 
+    , genericHscCompileGetFrontendResult
+
+    , genModDetails
+    , hscSimpleIface
+    , hscWriteIface
+    , hscNormalIface
+    , hscGenHardCode
+    , hscInteractive
+
     -- * Running passes separately
     , hscParse
     , hscTypecheckRename
@@ -51,12 +55,6 @@ module HscMain
     , makeSimpleDetails
     , hscSimplify -- ToDo, shouldn't really export this
 
-    -- ** Backends
-    , hscOneShotBackendOnly
-    , hscBatchBackendOnly
-    , hscNothingBackendOnly
-    , hscInteractiveBackendOnly
-
     -- * Support for interactive evaluation
     , hscParseIdentifier
     , hscTcRcLookupName
@@ -526,189 +524,104 @@ This is the only thing that isn't caught by the type-system.
 -}
 
 
--- | Status of a compilation to hard-code or nothing.
-data HscStatus' a
-    = HscNoRecomp
-    | HscRecomp
+-- | Status of a compilation to hard-code
+data HscStatus a
+    = HscRecomp
           (Maybe FilePath) -- Has stub files. This is a hack. We can't compile
                            -- C files here since it's done in DriverPipeline.
                            -- For now we just return True if we want the caller
                            -- to compile them for us.
           a
 
--- This is a bit ugly. Since we use a typeclass below and would like to avoid
--- functional dependencies, we have to parameterise the typeclass over the
--- result type. Therefore we need to artificially distinguish some types. We do
--- this by adding type tags which will simply be ignored by the caller.
-type HscStatus         = HscStatus' ()
-type FileOutputStatus  = HscStatus' (Maybe FilePath)
-type InteractiveStatus = HscStatus' (Maybe (CompiledByteCode, ModBreaks))
-    -- INVARIANT: result is @Nothing@ <=> input was a boot file
-
-type OneShotResult     = FileOutputStatus
-type BatchResult       = (FileOutputStatus, ModIface, ModDetails)
-type NothingResult     = (HscStatus, ModIface, ModDetails)
-type InteractiveResult = (InteractiveStatus, ModIface, ModDetails)
-
--- ToDo: The old interface and module index are only using in 'batch' and
---       'interactive' mode. They should be removed from 'oneshot' mode.
-type Compiler result =  HscEnv
-                     -> ModSummary
-                     -> SourceModified
-                     -> Maybe ModIface  -- Old interface, if available
-                     -> Maybe (Int,Int) -- Just (i,n) <=> module i of n (for msgs)
-                     -> IO result
-
-data HsCompiler a = HsCompiler {
-    -- | Called when no recompilation is necessary.
-    hscNoRecomp :: ModIface
-                -> Hsc a,
-
-    -- | Called to recompile the module.
-    hscRecompile :: ModSummary -> Maybe Fingerprint
-                 -> Hsc a,
-
-    hscBackend :: TcGblEnv -> ModSummary -> Maybe Fingerprint
-               -> Hsc a,
-
-    -- | Code generation for Boot modules.
-    hscGenBootOutput :: TcGblEnv -> ModSummary -> Maybe Fingerprint
-                     -> Hsc a,
-
-    -- | Code generation for normal modules.
-    hscGenOutput :: ModGuts -> ModSummary -> Maybe Fingerprint
-                 -> Hsc a
-  }
-
-genericHscCompile :: HsCompiler a
-                  -> (HscEnv -> Maybe (Int,Int) -> RecompileRequired -> ModSummary -> IO ())
-                  -> HscEnv -> ModSummary -> SourceModified
-                  -> Maybe ModIface -> Maybe (Int, Int)
-                  -> IO a
-genericHscCompile compiler hscMessage hsc_env
-                  mod_summary source_modified
-                  mb_old_iface0 mb_mod_index
-  = do
-    (recomp_reqd, mb_checked_iface)
-        <- {-# SCC "checkOldIface" #-}
-           checkOldIface hsc_env mod_summary
-                         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
+type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO ()
+
+genericHscCompileGetFrontendResult ::
+                     Bool -- always do basic recompilation check?
+                  -> Maybe TcGblEnv
+                  -> Maybe Messager
+                  -> HscEnv
+                  -> ModSummary
+                  -> SourceModified
+                  -> Maybe ModIface  -- Old interface, if available
+                  -> (Int,Int)       -- (i,n) = module i of n (for msgs)
+                  -> IO (Either ModIface (TcGblEnv, Maybe Fingerprint))
+
+genericHscCompileGetFrontendResult always_do_basic_recompilation_check m_tc_result
+                                   mHscMessage hsc_env mod_summary source_modified mb_old_iface mod_index
+    = do
+
+    let msg what = case mHscMessage of
+                   Just hscMessage -> hscMessage hsc_env mod_index what mod_summary
+                   Nothing -> return ()
 
-    let skip iface = do
-            hscMessage hsc_env mb_mod_index UpToDate mod_summary
-            runHsc hsc_env $ hscNoRecomp compiler iface
+        skip iface = do
+            msg UpToDate
+            return $ Left iface
 
-        compile reason = do
-            hscMessage hsc_env mb_mod_index reason mod_summary
-            runHsc hsc_env $ hscRecompile compiler mod_summary mb_old_hash
+        compile mb_old_hash reason = do
+            msg reason
+            tc_result <- runHsc hsc_env $ genericHscFrontend mod_summary
+            return $ Right (tc_result, 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 (recompileRequired recomp_reqd) ->
-            if mi_used_th iface && not stable
-                then compile (RecompBecause "TH")
-                else skip iface
-        _otherwise ->
-            compile recomp_reqd
-
-hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a
-hscCheckRecompBackend compiler tc_result 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_modified mb_old_iface
-
-    let mb_old_hash = fmap mi_iface_hash mb_checked_iface
-    case mb_checked_iface of
-        Just iface | not (recompileRequired recomp_reqd)
-            -> runHsc hsc_env $
-                   hscNoRecomp compiler
-                       iface{ mi_globals = Just (tcg_rdr_env tc_result) }
-        _otherwise
-            -> runHsc hsc_env $
-                   hscBackend compiler tc_result mod_summary mb_old_hash
-
-genericHscRecompile :: HsCompiler a
-                    -> ModSummary -> Maybe Fingerprint
-                    -> Hsc a
-genericHscRecompile compiler mod_summary mb_old_hash
+    case m_tc_result of
+         Just tc_result
+          | not always_do_basic_recompilation_check ->
+             return $ Right (tc_result, Nothing)
+         _ -> do
+            (recomp_reqd, mb_checked_iface)
+                <- {-# SCC "checkOldIface" #-}
+                   checkOldIface hsc_env mod_summary
+                                source_modified mb_old_iface
+            -- 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
+
+            case mb_checked_iface of
+                Just iface | not (recompileRequired recomp_reqd) ->
+                    -- 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 m_tc_result of
+                    Nothing
+                     | mi_used_th iface && not stable ->
+                        compile mb_old_hash (RecompBecause "TH")
+                    _ ->
+                        skip iface
+                _ ->
+                    case m_tc_result of
+                    Nothing -> compile mb_old_hash recomp_reqd
+                    Just tc_result ->
+                        return $ Right (tc_result, mb_old_hash)
+
+genericHscFrontend :: ModSummary -> Hsc TcGblEnv
+genericHscFrontend mod_summary
     | ExtCoreFile <- ms_hsc_src mod_summary =
         panic "GHC does not currently support reading External Core files"
     | otherwise = do
-        tc_result <- hscFileFrontEnd mod_summary
-        hscBackend compiler tc_result mod_summary mb_old_hash
-
-genericHscBackend :: HsCompiler a
-                  -> TcGblEnv -> ModSummary -> Maybe Fingerprint
-                  -> Hsc a
-genericHscBackend compiler tc_result mod_summary mb_old_hash
-    | HsBootFile <- ms_hsc_src mod_summary =
-        hscGenBootOutput compiler tc_result mod_summary mb_old_hash
-    | otherwise = do
-        guts <- hscDesugar' (ms_location mod_summary) tc_result
-        hscGenOutput compiler guts mod_summary mb_old_hash
-
-compilerBackend :: HsCompiler a -> TcGblEnv -> Compiler a
-compilerBackend comp tcg hsc_env ms' _ _mb_old_iface _ =
-    runHsc hsc_env $ hscBackend comp tcg ms' Nothing
+        hscFileFrontEnd mod_summary
 
 --------------------------------------------------------------
 -- Compilers
 --------------------------------------------------------------
 
-hscOneShotCompiler :: HsCompiler OneShotResult
-hscOneShotCompiler = HsCompiler {
-
-    hscNoRecomp = \_old_iface -> do
-        hsc_env <- getHscEnv
-        liftIO $ dumpIfaceStats hsc_env
-        return HscNoRecomp
-
-  , hscRecompile = genericHscRecompile hscOneShotCompiler
-
-  , hscBackend = \tc_result mod_summary mb_old_hash -> do
-        dflags <- getDynFlags
-        case hscTarget dflags of
-            HscNothing -> return (HscRecomp Nothing Nothing)
-            _otherw    -> genericHscBackend hscOneShotCompiler
-                              tc_result mod_summary mb_old_hash
-
-  , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
-        (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface
-        hscWriteIface iface changed mod_summary
-        return (HscRecomp Nothing Nothing)
-
-  , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
-        guts <- hscSimplify' guts0
-        (iface, changed, _details, cgguts) <- hscNormalIface guts mb_old_iface
-        hscWriteIface iface changed mod_summary
-        (outputFilename, hasStub) <- hscGenHardCode cgguts mod_summary
-        return (HscRecomp hasStub (Just outputFilename))
-  }
-
 -- Compile Haskell, boot and extCore in OneShot mode.
-hscCompileOneShot :: Compiler OneShotResult
-hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n
+hscCompileOneShot :: HscEnv
+                  -> ModSummary
+                  -> SourceModified
+                  -> IO (Maybe (HscStatus (Maybe FilePath)))
+hscCompileOneShot hsc_env mod_summary src_changed
   = do
     -- One-shot mode needs a knot-tying mutable variable for interface
     -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var.
@@ -716,134 +629,89 @@ hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n
     let mod = ms_mod mod_summary
         hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
 
-    genericHscCompile hscOneShotCompiler
-                      oneShotMsg hsc_env' mod_summary src_changed
-                      mb_old_iface mb_i_of_n
-
-hscOneShotBackendOnly :: TcGblEnv -> Compiler OneShotResult
-hscOneShotBackendOnly = compilerBackend hscOneShotCompiler
-
---------------------------------------------------------------
-
-hscBatchCompiler :: HsCompiler BatchResult
-hscBatchCompiler = HsCompiler {
-
-    hscNoRecomp = \iface -> do
-        details <- genModDetails iface
-        return (HscNoRecomp, iface, details)
-
-  , hscRecompile = genericHscRecompile hscBatchCompiler
-
-  , hscBackend = genericHscBackend hscBatchCompiler
-
-  , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
-        (iface, changed, details) <- hscSimpleIface tc_result mb_old_iface
-        hscWriteIface iface changed mod_summary
-        return (HscRecomp Nothing Nothing, iface, details)
-
-  , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
-        guts <- hscSimplify' guts0
-        (iface, changed, details, cgguts) <- hscNormalIface guts mb_old_iface
-        hscWriteIface iface changed mod_summary
-        (outputFilename, hasStub) <- hscGenHardCode cgguts mod_summary
-        return (HscRecomp hasStub (Just outputFilename), iface, details)
-  }
-
--- | Compile Haskell, boot and extCore in batch mode.
-hscCompileBatch :: Compiler (FileOutputStatus, ModIface, ModDetails)
-hscCompileBatch = genericHscCompile hscBatchCompiler batchMsg
-
-hscBatchBackendOnly :: TcGblEnv -> Compiler BatchResult
-hscBatchBackendOnly = hscCheckRecompBackend hscBatchCompiler
-
---------------------------------------------------------------
-
-hscInteractiveCompiler :: HsCompiler InteractiveResult
-hscInteractiveCompiler = HsCompiler {
-    hscNoRecomp = \iface -> do
-        details <- genModDetails iface
-        return (HscNoRecomp, iface, details)
-
-  , hscRecompile = genericHscRecompile hscInteractiveCompiler
-
-  , hscBackend = genericHscBackend hscInteractiveCompiler
-
-  , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do
-        (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
-        return (HscRecomp Nothing Nothing, iface, details)
-
-  , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
-        guts <- hscSimplify' guts0
-        (iface, _changed, details, cgguts) <- hscNormalIface guts mb_old_iface
-        hscInteractive (iface, details, cgguts) mod_summary
-  }
-
--- Compile Haskell, extCore to bytecode.
-hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
-hscCompileInteractive = genericHscCompile hscInteractiveCompiler batchMsg
-
-hscInteractiveBackendOnly :: TcGblEnv -> Compiler InteractiveResult
-hscInteractiveBackendOnly = compilerBackend hscInteractiveCompiler
-
---------------------------------------------------------------
-
-hscNothingCompiler :: HsCompiler NothingResult
-hscNothingCompiler = HsCompiler {
-    hscNoRecomp = \iface -> do
-        details <- genModDetails iface
-        return (HscNoRecomp, iface, details)
-
-  , hscRecompile = genericHscRecompile hscNothingCompiler
-
-  , hscBackend = \tc_result _mod_summary mb_old_iface -> do
-        handleWarnings
-        (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
-        return (HscRecomp Nothing (), iface, details)
-
-  , hscGenBootOutput = \_ _ _ ->
-        panic "hscCompileNothing: hscGenBootOutput should not be called"
-
-  , hscGenOutput = \_ _ _ ->
-        panic "hscCompileNothing: hscGenOutput should not be called"
-  }
+        msg what = oneShotMsg hsc_env' what
+
+        skip = do msg UpToDate
+                  dumpIfaceStats hsc_env'
+                  return Nothing
+
+        compile mb_old_hash reason = runHsc hsc_env' $ do
+            liftIO $ msg reason
+            tc_result <- genericHscFrontend mod_summary
+            dflags <- getDynFlags
+            case hscTarget dflags of
+                HscNothing -> return (Just (HscRecomp Nothing Nothing))
+                _ ->
+                    case ms_hsc_src mod_summary of
+                    HsBootFile ->
+                        do (iface, changed, _) <- hscSimpleIface' tc_result mb_old_hash
+                           liftIO $ hscWriteIface dflags iface changed mod_summary
+                           return (Just (HscRecomp Nothing Nothing))
+                    _ ->
+                        do guts0 <- hscDesugar' (ms_location mod_summary) tc_result
+                           guts <- hscSimplify' guts0
+                           (iface, changed, _details, cgguts) <- hscNormalIface' guts mb_old_hash
+                           liftIO $ hscWriteIface dflags iface changed mod_summary
+                           (outputFilename, hasStub) <- liftIO $ hscGenHardCode hsc_env' cgguts mod_summary
+                           return (Just (HscRecomp hasStub (Just outputFilename)))
+
+        stable = case src_changed of
+                     SourceUnmodifiedAndStable -> True
+                     _                         -> False
 
--- Type-check Haskell and .hs-boot only (no external core)
-hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails)
-hscCompileNothing = genericHscCompile hscNothingCompiler batchMsg
+    (recomp_reqd, mb_checked_iface)
+        <- {-# SCC "checkOldIface" #-}
+           checkOldIface hsc_env' mod_summary src_changed Nothing
+    -- 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
 
-hscNothingBackendOnly :: TcGblEnv -> Compiler NothingResult
-hscNothingBackendOnly = compilerBackend hscNothingCompiler
+    case mb_checked_iface of
+        Just iface | not (recompileRequired recomp_reqd) ->
+            -- 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.
+            if mi_used_th iface && not stable
+            then compile mb_old_hash (RecompBecause "TH")
+            else skip
+        _ ->
+            compile mb_old_hash recomp_reqd
 
 --------------------------------------------------------------
 -- NoRecomp handlers
 --------------------------------------------------------------
 
-genModDetails :: ModIface -> Hsc ModDetails
-genModDetails old_iface
+genModDetails :: HscEnv -> ModIface -> IO ModDetails
+genModDetails hsc_env old_iface
   = do
-    hsc_env <- getHscEnv
     new_details <- {-# SCC "tcRnIface" #-}
-                   liftIO $ initIfaceCheck hsc_env (typecheckIface old_iface)
-    liftIO $ dumpIfaceStats hsc_env
+                   initIfaceCheck hsc_env (typecheckIface old_iface)
+    dumpIfaceStats hsc_env
     return new_details
 
 --------------------------------------------------------------
 -- Progress displayers.
 --------------------------------------------------------------
 
-oneShotMsg :: HscEnv -> Maybe (Int,Int) -> RecompileRequired -> ModSummary
-            -> IO ()
-oneShotMsg hsc_env _mb_mod_index recomp _mod_summary =
+oneShotMsg :: HscEnv -> RecompileRequired -> IO ()
+oneShotMsg hsc_env recomp =
     case recomp of
         UpToDate ->
             compilationProgressMsg (hsc_dflags hsc_env) $
                    "compilation IS NOT required"
-        _other ->
+        _ ->
             return ()
 
-batchMsg :: HscEnv -> Maybe (Int,Int) -> RecompileRequired -> ModSummary
-         -> IO ()
-batchMsg hsc_env mb_mod_index recomp mod_summary =
+batchMsg :: Messager
+batchMsg hsc_env mod_index recomp mod_summary =
     case recomp of
         MustCompile -> showMsg "Compiling " ""
         UpToDate
@@ -854,7 +722,7 @@ batchMsg hsc_env mb_mod_index recomp mod_summary =
         dflags = hsc_dflags hsc_env
         showMsg msg reason =
             compilationProgressMsg dflags $
-            (showModuleIndex mb_mod_index ++
+            (showModuleIndex mod_index ++
             msg ++ showModMsg dflags (hscTarget dflags)
                               (recompileRequired recomp) mod_summary)
                 ++ reason
@@ -1194,10 +1062,17 @@ hscSimplify' ds_result = do
 -- Interface generators
 --------------------------------------------------------------
 
-hscSimpleIface :: TcGblEnv
+hscSimpleIface :: HscEnv
+               -> TcGblEnv
                -> Maybe Fingerprint
-               -> Hsc (ModIface, Bool, ModDetails)
-hscSimpleIface tc_result mb_old_iface = do
+               -> IO (ModIface, Bool, ModDetails)
+hscSimpleIface hsc_env tc_result mb_old_iface
+    = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface
+
+hscSimpleIface' :: TcGblEnv
+                -> Maybe Fingerprint
+                -> Hsc (ModIface, Bool, ModDetails)
+hscSimpleIface' tc_result mb_old_iface = do
     hsc_env   <- getHscEnv
     details   <- liftIO $ mkBootModDetailsTc hsc_env tc_result
     safe_mode <- hscGetSafeMode tc_result
@@ -1209,10 +1084,17 @@ hscSimpleIface tc_result mb_old_iface = do
     liftIO $ dumpIfaceStats hsc_env
     return (new_iface, no_change, details)
 
-hscNormalIface :: ModGuts
+hscNormalIface :: HscEnv
+               -> ModGuts
                -> Maybe Fingerprint
-               -> Hsc (ModIface, Bool, ModDetails, CgGuts)
-hscNormalIface simpl_result mb_old_iface = do
+               -> IO (ModIface, Bool, ModDetails, CgGuts)
+hscNormalIface hsc_env simpl_result mb_old_iface =
+    runHsc hsc_env $ hscNormalIface' simpl_result mb_old_iface
+
+hscNormalIface' :: ModGuts
+                -> Maybe Fingerprint
+                -> Hsc (ModIface, Bool, ModDetails, CgGuts)
+hscNormalIface' simpl_result mb_old_iface = do
     hsc_env <- getHscEnv
     (cg_guts, details) <- {-# SCC "CoreTidy" #-}
                           liftIO $ tidyProgram hsc_env simpl_result
@@ -1241,14 +1123,13 @@ hscNormalIface simpl_result mb_old_iface = do
 -- BackEnd combinators
 --------------------------------------------------------------
 
-hscWriteIface :: ModIface -> Bool -> ModSummary -> Hsc ()
-hscWriteIface iface no_change mod_summary = do
-    dflags <- getDynFlags
+hscWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
+hscWriteIface dflags iface no_change mod_summary = do
     let ifaceFile = ml_hi_file (ms_location mod_summary)
     unless no_change $
         {-# SCC "writeIface" #-}
-        liftIO $ writeIfaceFile dflags ifaceFile iface
-    whenGeneratingDynamicToo dflags $ liftIO $ do
+        writeIfaceFile dflags ifaceFile iface
+    whenGeneratingDynamicToo dflags $ do
         -- TODO: We should do a no_change check for the dynamic
         --       interface file too
         let dynIfaceFile = replaceExtension ifaceFile (dynHiSuf dflags)
@@ -1257,11 +1138,9 @@ hscWriteIface iface no_change mod_summary = do
         writeIfaceFile dynDflags dynIfaceFile' iface
 
 -- | Compile to hard-code.
-hscGenHardCode :: CgGuts -> ModSummary
-               -> Hsc (FilePath, Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f
-hscGenHardCode cgguts mod_summary = do
-    hsc_env <- getHscEnv
-    liftIO $ do
+hscGenHardCode :: HscEnv -> CgGuts -> ModSummary
+               -> IO (FilePath, Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f
+hscGenHardCode hsc_env cgguts mod_summary = do
         let CgGuts{ -- This is the last use of the ModGuts in a compilation.
                     -- From now on, we just use the bits we need.
                     cg_module   = this_mod,
@@ -1312,12 +1191,13 @@ hscGenHardCode cgguts mod_summary = do
         return (output_filename, stub_c_exists)
 
 
-hscInteractive :: (ModIface, ModDetails, CgGuts)
+hscInteractive :: HscEnv
+               -> CgGuts
                -> ModSummary
-               -> Hsc (InteractiveStatus, ModIface, ModDetails)
+               -> IO (HscStatus (CompiledByteCode, ModBreaks))
 #ifdef GHCI
-hscInteractive (iface, details, cgguts) mod_summary = do
-    dflags <- getDynFlags
+hscInteractive hsc_env cgguts mod_summary = do
+    let dflags = hsc_dflags hsc_env
     let CgGuts{ -- This is the last use of the ModGuts in a compilation.
                 -- From now on, we just use the bits we need.
                cg_module   = this_mod,
@@ -1334,18 +1214,14 @@ hscInteractive (iface, details, cgguts) mod_summary = do
     -------------------
     -- PREPARE FOR CODE GENERATION
     -- Do saturation and convert to A-normal form
-    hsc_env <- getHscEnv
     prepd_binds <- {-# SCC "CorePrep" #-}
-                   liftIO $ corePrepPgm dflags hsc_env core_binds data_tycons
+                   corePrepPgm dflags hsc_env core_binds data_tycons
     -----------------  Generate byte code ------------------
-    comp_bc <- liftIO $ byteCodeGen dflags this_mod prepd_binds
-                                    data_tycons mod_breaks
+    comp_bc <- byteCodeGen dflags this_mod prepd_binds data_tycons mod_breaks
     ------------------ Create f-x-dynamic C-side stuff ---
     (_istub_h_exists, istub_c_exists)
-        <- liftIO $ outputForeignStubs dflags this_mod
-                                        location foreign_stubs
-    return (HscRecomp istub_c_exists (Just (comp_bc, mod_breaks))
-           , iface, details)
+        <- outputForeignStubs dflags this_mod location foreign_stubs
+    return (HscRecomp istub_c_exists (comp_bc, mod_breaks))
 #else
 hscInteractive _ _ = panic "GHC not compiled with interpreter"
 #endif
@@ -1686,9 +1562,9 @@ hscCompileCore :: HscEnv -> Bool -> SafeHaskellMode -> ModSummary
 hscCompileCore hsc_env simplify safe_mode mod_summary binds
   = runHsc hsc_env $ do
         guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) safe_mode binds)
-        (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing
-        hscWriteIface iface changed mod_summary
-        _ <- hscGenHardCode cgguts mod_summary
+        (iface, changed, _details, cgguts) <- hscNormalIface' guts Nothing
+        liftIO $ hscWriteIface (hsc_dflags hsc_env) iface changed mod_summary
+        _ <- liftIO $ hscGenHardCode hsc_env cgguts mod_summary
         return ()
 
   where
@@ -1799,9 +1675,8 @@ dumpIfaceStats hsc_env = do
 %*                                                                      *
 %********************************************************************* -}
 
-showModuleIndex :: Maybe (Int, Int) -> String
-showModuleIndex Nothing = ""
-showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
+showModuleIndex :: (Int, Int) -> String
+showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] "
   where
     n_str = show n
     i_str = show i