Teach -fno-code about -fprefer-byte-codewip/ghc-fat-interface

This patch teachs the code generation logic of -fno-code about
-fprefer-byte-code, so that if we need to generate code for a module
which prefers byte code, then we generate byte code rather than object
code.

We keep track separately which modules need object code and which byte
code and then enable the relevant code generation for each. Typically
the option will be enabled globally so one of these sets should be empty
and we will just turn on byte code or object code generation.

We also fix the bug where we would generate code for a module which
enables Template Haskell despite the fact it was unecessary.

Fixes #22016

1 files changed, 87 insertions, 18 deletions

diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 93681eba11..8f8f644cdb 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -1328,10 +1328,12 @@ during the downsweep we patch the DynFlags in the ModSummary of any home module
 that is imported by a module that uses template haskell, to generate object
 code.
 
-The flavour of generated object code is chosen by defaultObjectTarget for the
-target platform. It would likely be faster to generate bytecode, but this is not
-supported on all platforms(?Please Confirm?), and does not support the entirety
-of GHC haskell. See #1257.
+The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled
+or not in the module which needs the code generation. If the module requires byte-code then
+dependencies will generate byte-code, otherwise they will generate object files.
+In the case where some modules require byte-code and some object files, both are
+generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these
+configurations.
 
 The object files (and interface files if -fwrite-interface is disabled) produced
 for template haskell are written to temporary files.
@@ -1756,6 +1758,12 @@ enableCodeGenForTH
 enableCodeGenForTH logger tmpfs unit_env =
   enableCodeGenWhen logger tmpfs TFL_CurrentModule TFL_GhcSession unit_env
 
+
+data CodeGenEnable = EnableByteCode | EnableObject | EnableByteCodeAndObject deriving (Eq, Show, Ord)
+
+instance Outputable CodeGenEnable where
+  ppr = text . show
+
 -- | Helper used to implement 'enableCodeGenForTH'.
 -- In particular, this enables
 -- unoptimized code generation for all modules that meet some
@@ -1781,7 +1789,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
         , ms_hsc_src = HsSrcFile
         , ms_hspp_opts = dflags
         } <- ms
-      , mkNodeKey n `Set.member` needs_codegen_set =
+      , Just enable_spec <- mkNodeKey n `Map.lookup` needs_codegen_map =
       if | nocode_enable ms -> do
                let new_temp_file suf dynsuf = do
                      tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf
@@ -1800,17 +1808,31 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
                                , (ml_obj_file ms_location, ml_dyn_obj_file ms_location))
                    else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))
                             <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))
+               let new_dflags = case enable_spec of
+                                  EnableByteCode -> dflags { backend = interpreterBackend }
+                                  EnableObject   -> dflags { backend = defaultBackendOf ms }
+                                  EnableByteCodeAndObject -> (gopt_set dflags Opt_ByteCodeAndObjectCode) { backend = defaultBackendOf ms}
                let ms' = ms
                      { ms_location =
                          ms_location { ml_hi_file = hi_file
                                      , 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 $ new_dflags
                      }
                -- Recursive call to catch the other cases
                enable_code_gen (ModuleNode deps ms')
-         | dynamic_too_enable ms -> do
+
+         -- If -fprefer-byte-code then satisfy dependency by enabling bytecode (if normal object not enough)
+         -- we only get to this case if the default backend is already generating object files, but we need dynamic
+         -- objects
+         | bytecode_and_enable enable_spec ms -> do
+               let ms' = ms
+                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ByteCodeAndObjectCode
+                     }
+               -- Recursive call to catch the other cases
+               enable_code_gen (ModuleNode deps ms')
+         | dynamic_too_enable enable_spec ms -> do
                let ms' = ms
                      { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_BuildDynamicToo
                      }
@@ -1833,18 +1855,40 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
       -- can't compile anything anyway! See #16219.
       isHomeUnitDefinite (ue_unitHomeUnit (ms_unitid ms) unit_env)
 
+    bytecode_and_enable enable_spec ms =
+      -- In the situation where we **would** need to enable dynamic-too
+      -- IF we had decided we needed objects
+      dynamic_too_enable EnableObject ms
+        -- but we prefer to use bytecode rather than objects
+        && prefer_bytecode
+        -- and we haven't already turned it on
+        && not generate_both
+      where
+        lcl_dflags   = ms_hspp_opts ms
+        prefer_bytecode = case enable_spec of
+                            EnableByteCodeAndObject -> True
+                            EnableByteCode -> True
+                            EnableObject -> False
+
+        generate_both   = gopt Opt_ByteCodeAndObjectCode lcl_dflags
+
     -- #8180 - when using TemplateHaskell, switch on -dynamic-too so
     -- the linker can correctly load the object files.  This isn't necessary
     -- when using -fexternal-interpreter.
-    dynamic_too_enable ms
+    dynamic_too_enable enable_spec ms
       = hostIsDynamic && internalInterpreter &&
             not isDynWay && not isProfWay &&  not dyn_too_enabled
+              && enable_object
       where
        lcl_dflags   = ms_hspp_opts ms
        internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)
-       dyn_too_enabled =  (gopt Opt_BuildDynamicToo lcl_dflags)
+       dyn_too_enabled = gopt Opt_BuildDynamicToo lcl_dflags
        isDynWay    = hasWay (ways lcl_dflags) WayDyn
        isProfWay   = hasWay (ways lcl_dflags) WayProf
+       enable_object = case enable_spec of
+                            EnableByteCode -> False
+                            EnableByteCodeAndObject -> True
+                            EnableObject -> True
 
     -- #16331 - when no "internal interpreter" is available but we
     -- need to process some TemplateHaskell or QuasiQuotes, we automatically
@@ -1854,18 +1898,43 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
        lcl_dflags   = ms_hspp_opts ms
        internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)
 
-
-
-
     (mg, lookup_node) = moduleGraphNodes False mod_graph
-    needs_codegen_set = Set.fromList $ map (mkNodeKey . node_payload) $ reachablesG mg (map (expectJust "needs_th" . lookup_node) has_th_set)
 
+    mk_needed_set roots = Set.fromList $ map (mkNodeKey . node_payload) $ reachablesG mg (map (expectJust "needs_th" . lookup_node) roots)
+
+    needs_obj_set, needs_bc_set :: Set.Set NodeKey
+    needs_obj_set = mk_needed_set need_obj_set
+
+    needs_bc_set = mk_needed_set need_bc_set
+
+    -- A map which tells us how to enable code generation for a NodeKey
+    needs_codegen_map :: Map.Map NodeKey CodeGenEnable
+    needs_codegen_map =
+      -- Another option here would be to just produce object code, rather than both object and
+      -- byte code
+      Map.unionWith (\_ _ -> EnableByteCodeAndObject)
+        (Map.fromList $ [(m, EnableObject) | m <- Set.toList needs_obj_set])
+        (Map.fromList $ [(m, EnableByteCode) | m <- Set.toList needs_bc_set])
+
+    -- The direct dependencies of modules which require object code
+    need_obj_set =
+      concat
+        -- Note we don't need object code for a module if it uses TemplateHaskell itself. Only
+        -- it's dependencies.
+        [ deps
+        | (ModuleNode deps ms) <- mod_graph
+        , isTemplateHaskellOrQQNonBoot ms
+        , not (gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms))
+        ]
 
-    has_th_set =
-      [ mkNodeKey mn
-      | mn@(ModuleNode _ ms) <- mod_graph
-      , isTemplateHaskellOrQQNonBoot ms
-      ]
+    -- The direct dependencies of modules which require byte code
+    need_bc_set =
+      concat
+        [ deps
+        | (ModuleNode deps ms) <- mod_graph
+        , isTemplateHaskellOrQQNonBoot ms
+        , gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms)
+        ]
 
 -- | Populate the Downsweep cache with the root modules.
 mkRootMap