Small refactoring: Move the end-of-pipeline move into pipeLoop

1 files changed, 31 insertions, 27 deletions

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index d6c46ee959..68957ca15f 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -530,6 +530,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
 
              env = PipeEnv{ pe_isHaskellishFile = isHaskellishFile,
                             stop_phase,
+                            src_filename = input_fn,
                             src_basename = basename,
                             src_suffix = suffix',
                             output_spec = output }
@@ -585,27 +586,7 @@ runPipeline' start_phase hsc_env env input_fn
   -- Execute the pipeline...
   let state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o }
 
-  (state', (dflags, output_fn)) <- unP (pipeLoop start_phase input_fn) env state
-
-  let PipeState{ maybe_loc } = state'
-
-  -- Sometimes, a compilation phase doesn't actually generate any output
-  -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this
-  -- stage, but we wanted to keep the output, then we have to explicitly
-  -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
-  -- further compilation stages can tell what the original filename was.
-  case output_spec env of
-    Temporary ->
-        return (dflags, output_fn)
-    output ->
-        do let stopPhase = stop_phase env
-           final_fn <- getOutputFilename stopPhase output (src_basename env)
-                                         dflags stopPhase maybe_loc
-           when (final_fn /= output_fn) $ do
-              let msg = ("Copying `" ++ output_fn ++"' to `" ++ final_fn ++ "'")
-                  line_prag = Just ("{-# LINE 1 \"" ++ input_fn ++ "\" #-}\n")
-              copyWithHeader dflags msg line_prag output_fn final_fn
-           return (dflags, final_fn)
+  evalP (pipeLoop start_phase input_fn) env state
 
 -- -----------------------------------------------------------------------------
 -- The pipeline uses a monad to carry around various bits of information
@@ -614,6 +595,7 @@ runPipeline' start_phase hsc_env env input_fn
 data PipeEnv = PipeEnv {
        pe_isHaskellishFile :: Bool,
        stop_phase   :: Phase,       -- ^ Stop just before this phase
+       src_filename :: String,      -- ^ basename of original input source
        src_basename :: String,      -- ^ basename of original input source
        src_suffix   :: String,      -- ^ its extension
        output_spec  :: PipelineOutput -- ^ says where to put the pipeline output
@@ -657,6 +639,9 @@ setStubO stub_o = P $ \_env state ->
 
 newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) }
 
+evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO a
+evalP f env st = liftM snd $ unP f env st
+
 instance Monad CompPipeline where
   return a = P $ \_env state -> return (state, a)
   P m >>= k = P $ \env state -> do (state',a) <- m env state
@@ -679,20 +664,39 @@ phaseOutputFilename next_phase = do
 -- | pipeLoop runs phases until we reach the stop phase
 pipeLoop :: Phase -> FilePath -> CompPipeline (DynFlags, FilePath)
 pipeLoop phase input_fn = do
-  PipeEnv{stop_phase} <- getPipeEnv
+  env <- getPipeEnv
   dflags <- getDynFlags
   let happensBefore' = happensBefore dflags
+      stopPhase = stop_phase env
   case () of
-   _ | phase `eqPhase` stop_phase            -- All done
-     -> return (dflags, input_fn)
-
-     | not (phase `happensBefore'` stop_phase)
+   _ | phase `eqPhase` stopPhase            -- All done
+     -> -- Sometimes, a compilation phase doesn't actually generate any output
+        -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this
+        -- stage, but we wanted to keep the output, then we have to explicitly
+        -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
+        -- further compilation stages can tell what the original filename was.
+        case output_spec env of
+        Temporary ->
+            return (dflags, input_fn)
+        output ->
+            do pst <- getPipeState
+               final_fn <- liftIO $ getOutputFilename
+                                        stopPhase output (src_basename env)
+                                        dflags stopPhase (maybe_loc pst)
+               when (final_fn /= input_fn) $ do
+                  let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'")
+                      line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n")
+                  liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn
+               return (dflags, final_fn)
+
+
+     | not (phase `happensBefore'` stopPhase)
         -- Something has gone wrong.  We'll try to cover all the cases when
         -- this could happen, so if we reach here it is a panic.
         -- eg. it might happen if the -C flag is used on a source file that
         -- has {-# OPTIONS -fasm #-}.
      -> panic ("pipeLoop: at phase " ++ show phase ++
-           " but I wanted to stop at phase " ++ show stop_phase)
+           " but I wanted to stop at phase " ++ show stopPhase)
 
      | otherwise
      -> do liftIO $ debugTraceMsg dflags 4