driver: Fix implementation of -S

We were failing to stop before running the assembler so the object file
was also created.

Fixes #21869

(cherry picked from commit e8c07aa91f0f05816b455457e3781c247b7399ca)

4 files changed, 27 insertions, 14 deletions

diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 02ca6a4b57..ee62c240ac 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -580,7 +580,7 @@ compileForeign hsc_env lang stub_c = do
               LangCxx    -> viaCPipeline Ccxx
               LangObjc   -> viaCPipeline Cobjc
               LangObjcxx -> viaCPipeline Cobjcxx
-              LangAsm    -> \pe hsc_env ml fp -> Just <$> asPipeline True pe hsc_env ml fp
+              LangAsm    -> \pe hsc_env ml fp -> asPipeline True pe hsc_env ml fp
 #if __GLASGOW_HASKELL__ < 811
               RawObject  -> panic "compileForeign: should be unreachable"
 #endif
@@ -588,6 +588,7 @@ compileForeign hsc_env lang stub_c = do
         res <- runPipeline (hsc_hooks hsc_env) (pipeline pipe_env hsc_env Nothing stub_c)
         case res of
           -- This should never happen as viaCPipeline should only return `Nothing` when the stop phase is `StopC`.
+          -- and the same should never happen for asPipeline
           -- Future refactoring to not check StopC for this case
           Nothing -> pprPanic "compileForeign" (ppr stub_c)
           Just fp -> return fp
@@ -766,28 +767,30 @@ hscGenBackendPipeline pipe_env hsc_env mod_sum result = do
         return (Just linkable)
   return (miface, final_linkable)
 
-asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m ObjFile
-asPipeline use_cpp pipe_env hsc_env location input_fn = do
-  use (T_As use_cpp pipe_env hsc_env location input_fn)
+asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe ObjFile)
+asPipeline use_cpp pipe_env hsc_env location input_fn =
+  case stop_phase pipe_env of
+    StopAs -> return Nothing
+    _ -> Just <$> use (T_As use_cpp pipe_env hsc_env location input_fn)
 
 viaCPipeline :: P m => Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
 viaCPipeline c_phase pipe_env hsc_env location input_fn = do
   out_fn <- use (T_Cc c_phase pipe_env hsc_env input_fn)
   case stop_phase pipe_env of
     StopC -> return Nothing
-    _ -> Just <$> asPipeline False pipe_env hsc_env location out_fn
+    _ -> asPipeline False pipe_env hsc_env location out_fn
 
-llvmPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
+llvmPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
 llvmPipeline pipe_env hsc_env location fp = do
   opt_fn <- use (T_LlvmOpt pipe_env hsc_env fp)
   llvmLlcPipeline pipe_env hsc_env location opt_fn
 
-llvmLlcPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
+llvmLlcPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
 llvmLlcPipeline pipe_env hsc_env location opt_fn = do
   llc_fn <- use (T_LlvmLlc pipe_env hsc_env opt_fn)
   llvmManglePipeline pipe_env hsc_env location llc_fn
 
-llvmManglePipeline :: P m  => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
+llvmManglePipeline :: P m  => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
 llvmManglePipeline pipe_env hsc_env location llc_fn = do
   mangled_fn <-
     if gopt Opt_NoLlvmMangler (hsc_dflags hsc_env)
@@ -814,8 +817,8 @@ hscPostBackendPipeline _ _ HsigFile _ _ _     = return Nothing
 hscPostBackendPipeline pipe_env hsc_env _ bcknd ml input_fn =
   case bcknd of
         ViaC        -> viaCPipeline HCc pipe_env hsc_env ml input_fn
-        NCG         -> Just <$> asPipeline False pipe_env hsc_env ml input_fn
-        LLVM        -> Just <$> llvmPipeline pipe_env hsc_env ml input_fn
+        NCG         -> asPipeline False pipe_env hsc_env ml input_fn
+        LLVM        -> llvmPipeline pipe_env hsc_env ml input_fn
         NoBackend   -> return Nothing
         Interpreter -> return Nothing
 
@@ -848,7 +851,7 @@ pipelineStart pipe_env hsc_env input_fn =
    c :: P m => Phase -> m (Maybe FilePath)
    c phase = viaCPipeline phase pipe_env hsc_env Nothing input_fn
    as :: P m => Bool -> m (Maybe FilePath)
-   as use_cpp = Just <$> asPipeline use_cpp pipe_env hsc_env Nothing input_fn
+   as use_cpp = asPipeline use_cpp pipe_env hsc_env Nothing input_fn
 
    objFromLinkable (_, Just (LM _ _ [DotO lnk])) = Just lnk
    objFromLinkable _ = Nothing
@@ -874,9 +877,9 @@ pipelineStart pipe_env hsc_env input_fn =
    fromSuffix "cxx"      = c Ccxx
    fromSuffix "s"        = as False
    fromSuffix "S"        = as True
-   fromSuffix "ll"       = Just <$> llvmPipeline pipe_env hsc_env Nothing input_fn
-   fromSuffix "bc"       = Just <$> llvmLlcPipeline pipe_env hsc_env Nothing input_fn
-   fromSuffix "lm_s"     = Just <$> llvmManglePipeline pipe_env hsc_env Nothing input_fn
+   fromSuffix "ll"       = llvmPipeline pipe_env hsc_env Nothing input_fn
+   fromSuffix "bc"       = llvmLlcPipeline pipe_env hsc_env Nothing input_fn
+   fromSuffix "lm_s"     = llvmManglePipeline pipe_env hsc_env Nothing input_fn
    fromSuffix "o"        = return (Just input_fn)
    fromSuffix "cmm"      = Just <$> cmmCppPipeline pipe_env hsc_env input_fn
    fromSuffix "cmmcpp"   = Just <$> cmmPipeline pipe_env hsc_env input_fn
diff --git a/testsuite/tests/driver/Makefile b/testsuite/tests/driver/Makefile
index 8d47dba2d5..4491b28bd7 100644
--- a/testsuite/tests/driver/Makefile
+++ b/testsuite/tests/driver/Makefile
@@ -744,3 +744,9 @@ T20316:
 T20569:
 	"$(TEST_HC)" $(TEST_HC_OPTS) -c T20569/A.hs -i -iT20569 -hidir=interface
 	"$(TEST_HC)" $(TEST_HC_OPTS) -c T20569/B.hs -i -iT20569 -hidir=interface
+
+.PHONY: T21869
+T21869:
+	"$(TEST_HC)" $(TEST_HC_OPTS) -v0 T21869.hs -S
+	[ -f T21869.s ] || (echo "assembly file does not exist" && exit 2)
+	[ ! -f T21869.o ] || (echo "object file exists" && exit 2)
diff --git a/testsuite/tests/driver/T21869.hs b/testsuite/tests/driver/T21869.hs
new file mode 100644
index 0000000000..918e213f57
--- /dev/null
+++ b/testsuite/tests/driver/T21869.hs
@@ -0,0 +1,3 @@
+module Main where
+
+main = print ()
diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T
index b7e7dbf59b..e8ba6eb4d7 100644
--- a/testsuite/tests/driver/all.T
+++ b/testsuite/tests/driver/all.T
@@ -306,3 +306,4 @@ test('T20316', normal, makefile_test, [])
 test('MultiRootsErr', normal, multimod_compile_fail, ['MultiRootsErr', 'MultiRootsErr'])
 test('patch-level2', normal, compile, ['-Wcpp-undef'])
 test('T20569', extra_files(["T20569/"]), makefile_test, [])
+test('T21869', normal, makefile_test, [])