Split `Backend` into multiple sum typeswip/maybe-backend

(What's the additive version of "factor"? :))

Preliminary step towards #20927 and #21034

I have wanted to do this for a while, and @nrnrnr's work convinced me I
should hurry up :) and do so.

I think enumerating "No backend" with actual backends is not good. We are very
far from having any nice notion of an "identity backend", and absent
that I cannot think of any other justification for the status quo.

`NoBackend` is kept as a pattern synonym so the code doesn't regress in
readability when there are no type annotation nearby.

Note this is a bare minimum refactor; I didn't make much of an
attempt to "prove" this was the right direction. But a few low-hanging
fruits nevertheless did arise:

 - `platformDefaultBackend` is guaranteed to return an actual backend.

 - In `GHC.Tc.Gen.Foreign`, `checkCOrAsmOrLlvmOrInterp` is dead code,
   because `checkCg` allows any foreign declaration with `NoBackend`.
   This makes sense to me: without a choice of the next pipeline stage
   committed to committed to, who's to say some constructor is outside
   its domain?

   `checkCg` now takes a `ActualBackend -> Validity` callback,
   demonstrating that `NoBackend` is handled separately.

This is enough to make me feel good I am not barking down the wrong
tree.

@nrnrnr's !7442 will end up touching many/most of the same lines that
this touches, but I think that is OK.

I am all for, downstream of `DynFlags`, trying to get rid of anything
looking at the `Backend` datatype, because we should support arbitrary
backends where are free to very those knobs however they like, fully
independently.

However, I don't thinking folding in `NoBackend` to our more "semantic"
representation of a backend (the new record) will make sense.
Conversely, I think the more we try to better structure what a backend
is/does, the more `NoBackend` would stick out like a sore thumb, ruining
our abstractions.

If we do this before `!7442`, we have the opportunity to use `Maybe
SemanticBackend` downstream to side-step those issues, but even that I
think will be somewhat temporary. As we continue to purge `DynFlags`
from the code base, I think we will increasingly separate code that
needs an actual backend from code that is agnostic. And the code that
agnostic I don't think should get a `Maybe SemanticBackend`, but rather
expose the knobs it would infer from the backend directly.

Why? This is the same argument as `checkCg`: if you haven't chosen a
backend yet, who is to say some choices are invalid? Not the
non-existent backend!  Conversely if we a backend requires a certain
choice made "upstream" in order for it to work, that that code should go
with the backend, not the upstream component. This preserves the
separation of concerns, and allows arbitrary backends to have arbitrary
policies.

9 files changed, 89 insertions, 67 deletions

diff --git a/compiler/GHC/Driver/Backend.hs b/compiler/GHC/Driver/Backend.hs
index 2642a2a9af..9f37f6c62a 100644
--- a/compiler/GHC/Driver/Backend.hs
+++ b/compiler/GHC/Driver/Backend.hs
@@ -1,8 +1,11 @@
 {-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE PatternSynonyms #-}
 
 -- | Code generation backends
 module GHC.Driver.Backend
-   ( Backend (..)
+   ( Backend
+   , pattern NoBackend
+   , ActualBackend (..)
    , platformDefaultBackend
    , platformNcgSupported
    , backendProducesObject
@@ -19,7 +22,7 @@ import GHC.Platform
 -- (producing machine code, producing ByteCode for the interpreter) and
 -- supporting different platforms.
 --
-data Backend
+data ActualBackend
    = NCG           -- ^ Native code generator backend.
                    --
                    -- Compiles Cmm code into textual assembler, then relies on
@@ -72,19 +75,30 @@ data Backend
                    --
                    -- See "GHC.StgToByteCode"
 
+   deriving (Eq,Ord,Show,Read)
 
-   | NoBackend     -- ^ No code generated.
-                   --
-                   -- Use this to disable code generation. It is particularly
-                   -- useful when GHC is used as a library for other purpose
-                   -- than generating code (e.g. to generate documentation with
-                   -- Haddock) or when the user requested it (via -fno-code) for
-                   -- some reason.
+-- | Sometimes we have a backend, and sometimes we do not.
+--
+-- Not inlining 'Nothing' into 'ActualBackend' will help lead towards things
+-- like e.g.
+--
+-- - Building for multiple backends at once, where we would switch from
+--   'Maybe ActualBackend' to 'Set ActualBackend', not 'Set (Maybe
+--   ActualBackend)'.
+--
+-- - Ensuring all backends can write to files. That would mean byte code can be
+--   written to a file (#21034), which makes 'ActualBackend' much more uniform.
+--   Conversely it's hard to imagine it would ever make sense for 'NoBackend' to
+--   write to a file!
+type Backend = Maybe ActualBackend
 
-   deriving (Eq,Ord,Show,Read)
+{-# COMPLETE NoBackend, Just #-}
+
+pattern NoBackend :: Backend
+pattern NoBackend = Nothing
 
 -- | Default backend to use for the given platform.
-platformDefaultBackend :: Platform -> Backend
+platformDefaultBackend :: Platform -> ActualBackend
 platformDefaultBackend platform = if
       | platformUnregisterised platform -> ViaC
       | platformNcgSupported platform   -> NCG
@@ -108,11 +122,11 @@ platformNcgSupported platform = if
 
 -- | Will this backend produce an object file on the disk?
 backendProducesObject :: Backend -> Bool
-backendProducesObject ViaC        = True
-backendProducesObject NCG         = True
-backendProducesObject LLVM        = True
-backendProducesObject Interpreter = False
-backendProducesObject NoBackend   = False
+backendProducesObject (Just ViaC)        = True
+backendProducesObject (Just NCG)         = True
+backendProducesObject (Just LLVM)        = True
+backendProducesObject (Just Interpreter) = False
+backendProducesObject NoBackend          = False
 
 -- | Does this backend retain *all* top-level bindings for a module,
 -- rather than just the exported bindings, in the TypeEnv and compiled
@@ -124,8 +138,8 @@ backendProducesObject NoBackend   = False
 -- When no backend is used we also do it, so that Haddock can get access to the
 -- GlobalRdrEnv for a module after typechecking it.
 backendRetainsAllBindings :: Backend -> Bool
-backendRetainsAllBindings Interpreter = True
-backendRetainsAllBindings NoBackend   = True
-backendRetainsAllBindings ViaC        = False
-backendRetainsAllBindings NCG         = False
-backendRetainsAllBindings LLVM        = False
+backendRetainsAllBindings NoBackend          = True
+backendRetainsAllBindings (Just Interpreter) = True
+backendRetainsAllBindings (Just ViaC)        = False
+backendRetainsAllBindings (Just NCG)         = False
+backendRetainsAllBindings (Just LLVM)        = False
diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs
index 80a8277283..f4b8b95aab 100644
--- a/compiler/GHC/Driver/CodeOutput.hs
+++ b/compiler/GHC/Driver/CodeOutput.hs
@@ -111,12 +111,13 @@ codeOutput logger tmpfs dflags unit_state this_mod filenm location genForeignStu
                 }
 
         ; a <- case backend dflags of
+            NoBackend -> panic "codeOutput: NoBackend"
+            Just b -> case b of
                  NCG         -> outputAsm logger dflags this_mod location filenm
                                           linted_cmm_stream
                  ViaC        -> outputC logger dflags filenm linted_cmm_stream pkg_deps
                  LLVM        -> outputLlvm logger dflags filenm linted_cmm_stream
                  Interpreter -> panic "codeOutput: Interpreter"
-                 NoBackend   -> panic "codeOutput: NoBackend"
         ; let stubs = genForeignStubs a
         ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs
         ; return (filenm, stubs_exist, foreign_fps, a)
diff --git a/compiler/GHC/Driver/Config/Cmm.hs b/compiler/GHC/Driver/Config/Cmm.hs
index 38bab62048..d7280b0e60 100644
--- a/compiler/GHC/Driver/Config/Cmm.hs
+++ b/compiler/GHC/Driver/Config/Cmm.hs
@@ -22,7 +22,7 @@ initCmmConfig dflags = CmmConfig
   , cmmGenStackUnwindInstr = debugLevel dflags > 0
   , cmmExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
   , cmmDoCmmSwitchPlans    = not . backendSupportsSwitch . backend $ dflags
-  , cmmSplitProcPoints     = (backend dflags /= NCG)
+  , cmmSplitProcPoints     = (backend dflags /= Just NCG)
                              || not (platformTablesNextToCode platform)
                              || usingInconsistentPicReg
   }
diff --git a/compiler/GHC/Driver/Config/StgToCmm.hs b/compiler/GHC/Driver/Config/StgToCmm.hs
index ae59e41fdf..0476c0e684 100644
--- a/compiler/GHC/Driver/Config/StgToCmm.hs
+++ b/compiler/GHC/Driver/Config/StgToCmm.hs
@@ -58,8 +58,8 @@ initStgToCmmConfig dflags mod = StgToCmmConfig
   } where profile  = targetProfile dflags
           platform = profilePlatform profile
           bk_end  = backend dflags
-          ncg     = bk_end == NCG
-          llvm    = bk_end == LLVM
+          ncg     = bk_end == Just NCG
+          llvm    = bk_end == Just LLVM
           x86ish  = case platformArch platform of
                       ArchX86    -> True
                       ArchX86_64 -> True
@@ -70,5 +70,5 @@ initStgToCmmConfig dflags mod = StgToCmmConfig
                       _            -> False
           aarch64 = platformArch platform == ArchAArch64
           vec_err = case backend dflags of
-                      LLVM -> Nothing
-                      _    -> Just (unlines ["SIMD vector instructions require the LLVM back-end.", "Please use -fllvm."])
+                      Just LLVM -> Nothing
+                      _         -> Just (unlines ["SIMD vector instructions require the LLVM back-end.", "Please use -fllvm."])
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 3e48771ace..bdbc65670f 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -1001,9 +1001,9 @@ hscMaybeWriteIface :: Logger -> DynFlags -> Bool -> ModIface -> Maybe Fingerprin
 hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do
     let force_write_interface = gopt Opt_WriteInterface dflags
         write_interface = case backend dflags of
-                            NoBackend    -> False
-                            Interpreter  -> False
-                            _            -> True
+                            NoBackend         -> False
+                            Just Interpreter  -> False
+                            Just _            -> True
 
         write_iface dflags' iface =
           let !iface_name = if dynamicNow dflags' then ml_dyn_hi_file mod_location else ml_hi_file mod_location
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 4ec6d13348..a8c087bbc3 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -1711,7 +1711,7 @@ enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife unit_e
                               , ml_obj_file = o_file
                               , ml_dyn_hi_file = dyn_hi_file
                               , ml_dyn_obj_file = dyn_o_file }
-              , ms_hspp_opts = updOptLevel 0 $ dflags {backend = defaultBackendOf ms}
+              , ms_hspp_opts = updOptLevel 0 $ dflags { backend = Just $ defaultBackendOf ms }
               }
         pure (ModuleNode deps ms')
     enable_code_gen ms = return ms
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 56e188395e..d96ee2daf0 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -259,9 +259,9 @@ compileOne' mHscMessage
        internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)
 
        pipelineOutput = case bcknd of
-         Interpreter -> NoOutputFile
          NoBackend -> NoOutputFile
-         _ -> Persistent
+         Just Interpreter -> NoOutputFile
+         Just _ -> Persistent
 
        logger = hsc_logger hsc_env0
        tmpfs  = hsc_tmpfs hsc_env0
@@ -294,15 +294,16 @@ compileOne' mHscMessage
          = True
          | otherwise = False
        -- Figure out which backend we're using
-       (bcknd, dflags3)
+       dflags3
          -- #8042: When module was loaded with `*` prefix in ghci, but DynFlags
          -- suggest to generate object code (which may happen in case -fobject-code
          -- was set), force it to generate byte-code. This is NOT transitive and
          -- only applies to direct targets.
          | loadAsByteCode
-         = (Interpreter, gopt_set (dflags2 { backend = Interpreter }) Opt_ForceRecomp)
+         = gopt_set (dflags2 { backend = Just Interpreter }) Opt_ForceRecomp
          | otherwise
-         = (backend dflags, dflags2)
+         = dflags2
+       bcknd = backend dflags3
        -- See Note [Filepaths and Multiple Home Units]
        dflags  = dflags3 { includePaths = offsetIncludePaths dflags3 $ addImplicitQuoteInclude old_paths [current_dir] }
        upd_summary = summary { ms_hspp_opts = dflags }
@@ -835,11 +836,11 @@ hscPostBackendPipeline _ _ HsBootFile _ _ _   = return Nothing
 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
-        NoBackend   -> return Nothing
-        Interpreter -> return Nothing
+        NoBackend        -> return Nothing
+        Just Interpreter -> return Nothing
+        Just ViaC        -> viaCPipeline HCc pipe_env hsc_env ml input_fn
+        Just NCG         -> Just <$> asPipeline False pipe_env hsc_env ml input_fn
+        Just LLVM        -> Just <$> llvmPipeline pipe_env hsc_env ml input_fn
 
 -- Pipeline from a given suffix
 pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs
index 6bc9df7c6f..6250837996 100644
--- a/compiler/GHC/Driver/Pipeline/Execute.hs
+++ b/compiler/GHC/Driver/Pipeline/Execute.hs
@@ -284,7 +284,7 @@ runAsPhase with_cpp pipe_env hsc_env location input_fn = do
 
         -- LLVM from version 3.0 onwards doesn't support the OS X system
         -- assembler, so we use clang as the assembler instead. (#5636)
-        let (as_prog, get_asm_info) | backend dflags == LLVM
+        let (as_prog, get_asm_info) | backend dflags == Just LLVM
                     , platformOS platform == OSDarwin
                     = (GHC.SysTools.runClang, pure Clang)
                     | otherwise
@@ -500,7 +500,7 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do
                 }
         -> case backend dflags of
           NoBackend -> panic "HscRecomp not relevant for NoBackend"
-          Interpreter -> do
+          Just Interpreter -> do
               -- In interpreted mode the regular codeGen backend is not run so we
               -- generate a interface without codeGen info.
               final_iface <- mkFullIface hsc_env partial_iface Nothing
@@ -519,7 +519,7 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do
               let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name)
                              (hs_unlinked ++ stub_o)
               return ([], final_iface, Just linkable, panic "interpreter")
-          _ -> do
+          Just _ -> do
               output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location)
               (outputFilename, mStub, foreign_files, cg_infos) <-
                 hscGenHardCode hsc_env cgguts mod_location output_fn
@@ -1040,7 +1040,7 @@ doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do
                        ])
 
 getBackendDefs :: Logger -> DynFlags -> IO [String]
-getBackendDefs logger dflags | backend dflags == LLVM = do
+getBackendDefs logger dflags | backend dflags == Just LLVM = do
     llvmVer <- figureLlvmVersion logger dflags
     return $ case fmap llvmVersionList llvmVer of
                Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]
@@ -1060,11 +1060,11 @@ hscPostBackendPhase HsBootFile _    =  StopLn
 hscPostBackendPhase HsigFile _      =  StopLn
 hscPostBackendPhase _ bcknd =
   case bcknd of
-        ViaC        -> HCc
-        NCG         -> As False
-        LLVM        -> LlvmOpt
-        NoBackend   -> StopLn
-        Interpreter -> StopLn
+        NoBackend        -> StopLn
+        Just Interpreter -> StopLn
+        Just ViaC        -> HCc
+        Just NCG         -> As False
+        Just LLVM        -> LlvmOpt
 
 
 compileStub :: HscEnv -> FilePath -> IO FilePath
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 838f0bf3b7..51440d187c 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -1117,7 +1117,7 @@ defaultDynFlags mySettings llvmConfig =
      DynFlags {
         ghcMode                 = CompManager,
         ghcLink                 = LinkBinary,
-        backend                 = platformDefaultBackend (sTargetPlatform mySettings),
+        backend                 = Just $ platformDefaultBackend $ sTargetPlatform mySettings,
         verbosity               = 0,
         debugLevel              = 0,
         simplPhases             = 2,
@@ -2268,9 +2268,13 @@ dynamic_flags_deps = [
   , make_ord_flag defGhcFlag "keep-s-files"
         (NoArg (setGeneralFlag Opt_KeepSFiles))
   , make_ord_flag defGhcFlag "keep-llvm-file"
-        (NoArg $ setObjBackend LLVM >> setGeneralFlag Opt_KeepLlvmFiles)
+        $ NoArg $ do
+          setObjBackend $ Just LLVM
+          setGeneralFlag Opt_KeepLlvmFiles
   , make_ord_flag defGhcFlag "keep-llvm-files"
-        (NoArg $ setObjBackend LLVM >> setGeneralFlag Opt_KeepLlvmFiles)
+        $ NoArg $ do
+          setObjBackend $ Just LLVM
+          setGeneralFlag Opt_KeepLlvmFiles
      -- This only makes sense as plural
   , make_ord_flag defGhcFlag "keep-tmp-files"
         (NoArg (setGeneralFlag Opt_KeepTmpFiles))
@@ -2442,7 +2446,9 @@ dynamic_flags_deps = [
   , make_ord_flag defGhcFlag "ddump-asm-stats"
         (setDumpFlag Opt_D_dump_asm_stats)
   , make_ord_flag defGhcFlag "ddump-llvm"
-        (NoArg $ setObjBackend LLVM >> setDumpFlag' Opt_D_dump_llvm)
+        $ NoArg $ do
+          setObjBackend $ Just LLVM
+          setDumpFlag' Opt_D_dump_llvm
   , make_ord_flag defGhcFlag "ddump-c-backend"
         (NoArg $ setDumpFlag' Opt_D_dump_c_backend)
   , make_ord_flag defGhcFlag "ddump-deriv"
@@ -2862,24 +2868,24 @@ dynamic_flags_deps = [
       (NoArg (setGeneralFlag Opt_InfoTableMap))
         ------ Compiler flags -----------------------------------------------
 
-  , make_ord_flag defGhcFlag "fasm"             (NoArg (setObjBackend NCG))
+  , make_ord_flag defGhcFlag "fasm"             (NoArg $ setObjBackend $ Just NCG)
   , make_ord_flag defGhcFlag "fvia-c"           (NoArg
          (deprecate $ "The -fvia-c flag does nothing; " ++
                       "it will be removed in a future GHC release"))
   , make_ord_flag defGhcFlag "fvia-C"           (NoArg
          (deprecate $ "The -fvia-C flag does nothing; " ++
                       "it will be removed in a future GHC release"))
-  , make_ord_flag defGhcFlag "fllvm"            (NoArg (setObjBackend LLVM))
+  , make_ord_flag defGhcFlag "fllvm"            (NoArg $ setObjBackend $ Just LLVM)
 
   , make_ord_flag defFlag "fno-code"         (NoArg ((upd $ \d ->
                   d { ghcLink=NoLink }) >> setBackend NoBackend))
   , make_ord_flag defFlag "fbyte-code"
       (noArgM $ \dflags -> do
-        setBackend Interpreter
+        setBackend $ Just Interpreter
         pure $ gopt_set dflags Opt_ByteCode)
   , make_ord_flag defFlag "fobject-code"     $ NoArg $ do
       dflags <- liftEwM getCmdLineState
-      setBackend $ platformDefaultBackend (targetPlatform dflags)
+      setBackend $ Just $ platformDefaultBackend $ targetPlatform dflags
 
   , make_dep_flag defFlag "fglasgow-exts"
       (NoArg enableGlasgowExts) "Use individual extensions instead"
@@ -4720,30 +4726,30 @@ makeDynFlagsConsistent dflags
 
    -- Via-C backend only supports unregisterised ABI. Switch to a backend
    -- supporting it if possible.
- | backend dflags == ViaC &&
+ | backend dflags == Just ViaC &&
    not (platformUnregisterised (targetPlatform dflags))
     = case platformDefaultBackend (targetPlatform dflags) of
-         NCG ->  let dflags' = dflags { backend = NCG }
+         NCG ->  let dflags' = dflags { backend = Just NCG }
                      warn = "Target platform doesn't use unregisterised ABI, so using native code generator rather than compiling via C"
                  in loop dflags' warn
-         LLVM -> let dflags' = dflags { backend = LLVM }
+         LLVM -> let dflags' = dflags { backend = Just LLVM }
                      warn = "Target platform doesn't use unregisterised ABI, so using LLVM rather than compiling via C"
                  in loop dflags' warn
          _    -> pgmError "Compiling via C only supports unregisterised ABI but target platform doesn't use it."
 
- | gopt Opt_Hpc dflags && backend dflags == Interpreter
+ | gopt Opt_Hpc dflags && backend dflags == Just Interpreter
     = let dflags' = gopt_unset dflags Opt_Hpc
           warn = "Hpc can't be used with byte-code interpreter. Ignoring -fhpc."
       in loop dflags' warn
 
- | backend dflags `elem` [NCG, LLVM] &&
+ | backend dflags `elem` (fmap Just [NCG, LLVM]) &&
    platformUnregisterised (targetPlatform dflags)
-    = loop (dflags { backend = ViaC })
+    = loop (dflags { backend = Just ViaC })
            "Target platform uses unregisterised ABI, so compiling via C"
 
- | backend dflags == NCG &&
+ | backend dflags == Just NCG &&
    not (platformNcgSupported $ targetPlatform dflags)
-      = let dflags' = dflags { backend = LLVM }
+      = let dflags' = dflags { backend = Just LLVM }
             warn = "Native code generator doesn't support target platform, so using LLVM"
         in loop dflags' warn
 
@@ -4756,7 +4762,7 @@ makeDynFlagsConsistent dflags
     = loop (gopt_set dflags Opt_PIC)
            "Enabling -fPIC as it is always on for this platform"
 
- | backend dflags == Interpreter
+ | backend dflags == Just Interpreter
  , let (dflags', changed) = updOptLevelChanged 0 dflags
  , changed
     = loop dflags' "Optimization flags conflict with --interactive; optimization flags ignored."