driver: Fix implementation of -S

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

Fixes #21869

4 files changed, 27 insertions, 14 deletions

diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index e988979df2..0149bf644f 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -579,7 +579,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
@@ -587,6 +587,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
@@ -765,28 +766,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)
@@ -818,10 +821,10 @@ applyPostHscPipeline
     => DefunctionalizedPostHscPipeline
     -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
 applyPostHscPipeline NcgPostHscPipeline =
-    \pe he ml fp -> Just <$> asPipeline False pe he ml fp
+    \pe he ml fp -> asPipeline False pe he ml fp
 applyPostHscPipeline ViaCPostHscPipeline = viaCPipeline HCc
 applyPostHscPipeline LlvmPostHscPipeline =
-    \pe he ml fp -> Just <$> llvmPipeline pe he ml fp
+    \pe he ml fp -> llvmPipeline pe he ml fp
 applyPostHscPipeline NoPostHscPipeline = \_ _ _ _ -> return Nothing
 
 
@@ -854,7 +857,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
@@ -880,9 +883,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 30ca61b8e5..085ca668a4 100644
--- a/testsuite/tests/driver/Makefile
+++ b/testsuite/tests/driver/Makefile
@@ -773,3 +773,9 @@ T21349:
 	"$(TEST_HC)" $(TEST_HC_OPTS) -v0 Main -working-dir T21349
 	[ ! -f T21349/B.o ] || (echo "object file exists" && exit 2)
 	[ ! -f T21349/B.hi ] || (echo "interface file exists" && exit 2)
+
+.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 624c8305dc..f38cb070db 100644
--- a/testsuite/tests/driver/all.T
+++ b/testsuite/tests/driver/all.T
@@ -309,3 +309,4 @@ test('T16476a', normal, makefile_test, [])
 test('T16476b', normal, makefile_test, [])
 test('T20569', extra_files(["T20569/"]), makefile_test, [])
 test('T21349', extra_files(['T21349']), makefile_test, [])
+test('T21869', normal, makefile_test, [])