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

15 files changed, 119 insertions, 40 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
diff --git a/docs/users_guide/phases.rst b/docs/users_guide/phases.rst
index be3ca70bf8..3a1996bc20 100644
--- a/docs/users_guide/phases.rst
+++ b/docs/users_guide/phases.rst
@@ -625,6 +625,11 @@ Options affecting code generation
     Omit code generation (and all later phases) altogether. This is
     useful if you're only interested in type checking code.
 
+    If a module contains a Template Haskell splice then in ``--make`` mode, code
+    generation will be automatically turned on for all dependencies. By default
+    object files are generated but if ghc-flag:`-fprefer-byte-code` is enable then
+    byte-code will be generated instead.
+
 .. ghc-flag:: -fwrite-interface
     :shortdesc: Always write interface files
     :type: dynamic
diff --git a/testsuite/tests/driver/T20300/T20300.stderr b/testsuite/tests/driver/T20300/T20300.stderr
index 0698d9bf0e..0687f420dd 100644
--- a/testsuite/tests/driver/T20300/T20300.stderr
+++ b/testsuite/tests/driver/T20300/T20300.stderr
@@ -1,4 +1,4 @@
 [1 of 4] Compiling T[boot]          ( T.hs-boot, nothing )
 [2 of 4] Compiling T                ( T.hs, nothing )
-[3 of 4] Compiling S                ( S.hs, S.o, S.dyn_o )
+[3 of 4] Compiling S                ( S.hs, nothing )
 [4 of 4] Compiling Top              ( Top.hs, nothing )
diff --git a/testsuite/tests/driver/T20348/B.hs b/testsuite/tests/driver/T20348/B.hs
new file mode 100644
index 0000000000..4a022335de
--- /dev/null
+++ b/testsuite/tests/driver/T20348/B.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
+module B where
+
+import A
diff --git a/testsuite/tests/driver/T20348/Makefile b/testsuite/tests/driver/T20348/Makefile
index ba1edd021d..5b78c12bf5 100644
--- a/testsuite/tests/driver/T20348/Makefile
+++ b/testsuite/tests/driver/T20348/Makefile
@@ -15,7 +15,7 @@ clean:
 T20348: clean
 	# First run: should produce .hi, .o, .dyn_hi, .dyn_o files.
 	echo 'first run'
-	'$(TEST_HC)' $(TEST_HC_OPTS) -fno-code -fwrite-interface A.hs
+	'$(TEST_HC)' $(TEST_HC_OPTS) -fno-code -fwrite-interface B.hs
 	$(call checkExists,A.hi)
 	$(call checkExists,A.o)
 	$(call checkExists,A.dyn_hi)
diff --git a/testsuite/tests/driver/T20348/T20348.stdout b/testsuite/tests/driver/T20348/T20348.stdout
index 1763145c31..02f97c659b 100644
--- a/testsuite/tests/driver/T20348/T20348.stdout
+++ b/testsuite/tests/driver/T20348/T20348.stdout
@@ -1,3 +1,4 @@
 first run
-[1 of 1] Compiling A                ( A.hs, A.o, A.dyn_o )
+[1 of 2] Compiling A                ( A.hs, A.o, A.dyn_o )
+[2 of 2] Compiling B                ( B.hs, nothing )
 second run
diff --git a/testsuite/tests/driver/T20348/all.T b/testsuite/tests/driver/T20348/all.T
index ce8f124d8a..969c436210 100644
--- a/testsuite/tests/driver/T20348/all.T
+++ b/testsuite/tests/driver/T20348/all.T
@@ -1,6 +1,6 @@
 # N.B. this package requires a dynamically-linked ghc-bin, since it assumes
 # that TH evaluation will build dynamic objects.
-test('T20348', [extra_files(['A.hs']), unless(have_dynamic(), skip)], makefile_test, [])
+test('T20348', [extra_files(['A.hs', 'B.hs']), unless(have_dynamic(), skip)], makefile_test, [])
 test('T20348A', [extra_files(['A.hs']), unless(have_dynamic(), skip)], makefile_test, [])
 test('T20348B', [extra_files(['A.hs']), unless(have_dynamic(), skip)], makefile_test, [])
 test('T20348C', [extra_files(['A.hs']), unless(have_dynamic(), skip)], makefile_test, [])
diff --git a/testsuite/tests/driver/T20696/T20696.stderr b/testsuite/tests/driver/T20696/T20696.stderr
index de9a537caf..54d5ad5bdd 100644
--- a/testsuite/tests/driver/T20696/T20696.stderr
+++ b/testsuite/tests/driver/T20696/T20696.stderr
@@ -1,3 +1,3 @@
 [1 of 3] Compiling C                ( C.hs, C.o, C.dyn_o )
-[2 of 3] Compiling B                ( B.hs, B.o, B.dyn_o )
+[2 of 3] Compiling B                ( B.hs, B.o )
 [3 of 3] Compiling A                ( A.hs, A.o )
diff --git a/testsuite/tests/driver/fat-iface/fat008.stdout b/testsuite/tests/driver/fat-iface/fat008.stdout
index 8841ce10b2..0132be4e53 100644
--- a/testsuite/tests/driver/fat-iface/fat008.stdout
+++ b/testsuite/tests/driver/fat-iface/fat008.stdout
@@ -1,3 +1,3 @@
-[1 of 2] Compiling FatQuote         ( FatQuote.hs, FatQuote.o, FatQuote.dyn_o )
-[2 of 2] Compiling FatTH            ( FatTH.hs, FatTH.o, FatTH.dyn_o )
-[2 of 2] Compiling FatTH            ( FatTH.hs, FatTH.o, FatTH.dyn_o ) [Source file changed]
+[1 of 2] Compiling FatQuote         ( FatQuote.hs, FatQuote.o, interpreted )
+[2 of 2] Compiling FatTH            ( FatTH.hs, FatTH.o )
+[2 of 2] Compiling FatTH            ( FatTH.hs, FatTH.o ) [Source file changed]
diff --git a/testsuite/tests/driver/fat-iface/fat011.stderr b/testsuite/tests/driver/fat-iface/fat011.stderr
index 71fe78f06a..0fe4749423 100644
--- a/testsuite/tests/driver/fat-iface/fat011.stderr
+++ b/testsuite/tests/driver/fat-iface/fat011.stderr
@@ -1,4 +1,4 @@
-[1 of 4] Compiling FatQuote         ( FatQuote.hs, FatQuote.o, FatQuote.dyn_o, interpreted )
-[2 of 4] Compiling FatTH            ( FatTH.hs, FatTH.o, FatTH.dyn_o, interpreted )
+[1 of 4] Compiling FatQuote         ( FatQuote.hs, FatQuote.o, interpreted )
+[2 of 4] Compiling FatTH            ( FatTH.hs, FatTH.o, interpreted )
 [3 of 4] Compiling Main             ( FatMain.hs, FatMain.o, interpreted )
 [4 of 4] Linking FatMain
diff --git a/testsuite/tests/driver/fat-iface/fat012.stderr b/testsuite/tests/driver/fat-iface/fat012.stderr
index 95ac650ae4..57a6befc70 100644
--- a/testsuite/tests/driver/fat-iface/fat012.stderr
+++ b/testsuite/tests/driver/fat-iface/fat012.stderr
@@ -1,2 +1,2 @@
-[1 of 2] Compiling FatQuote         ( FatQuote.hs, FatQuote.o, FatQuote.dyn_o )
-[2 of 2] Compiling FatTH            ( FatTH.hs, FatTH.o, FatTH.dyn_o )
+[1 of 2] Compiling FatQuote         ( FatQuote.hs, FatQuote.o, interpreted )
+[2 of 2] Compiling FatTH            ( FatTH.hs, FatTH.o )
diff --git a/testsuite/tests/driver/fat-iface/fat013.stderr b/testsuite/tests/driver/fat-iface/fat013.stderr
index bf181cfc4a..2be5eddb9a 100644
--- a/testsuite/tests/driver/fat-iface/fat013.stderr
+++ b/testsuite/tests/driver/fat-iface/fat013.stderr
@@ -1,2 +1,2 @@
-[1 of 2] Compiling FatQuote         ( FatQuote.hs, /run/user/1000/ghc1303986_0/ghc_2.o, /run/user/1000/ghc1303986_0/ghc_2.dyn_o )
-[2 of 2] Compiling FatTH            ( FatTH.hs, /run/user/1000/ghc1303986_0/ghc_4.o, /run/user/1000/ghc1303986_0/ghc_4.dyn_o )
+[1 of 2] Compiling FatQuote         ( FatQuote.hs, interpreted )
+[2 of 2] Compiling FatTH            ( FatTH.hs, nothing )
diff --git a/testsuite/tests/driver/fat-iface/fat014.stdout b/testsuite/tests/driver/fat-iface/fat014.stdout
index 52d0811a33..7bae3b3c03 100644
--- a/testsuite/tests/driver/fat-iface/fat014.stdout
+++ b/testsuite/tests/driver/fat-iface/fat014.stdout
@@ -1,3 +1,3 @@
-[1 of 2] Compiling FatQuote         ( FatQuote.hs, /run/user/1000/ghc1304860_0/ghc_2.o )
-[2 of 2] Compiling FatTH            ( FatTH.hs, /run/user/1000/ghc1304860_0/ghc_4.o )
+[1 of 2] Compiling FatQuote         ( FatQuote.hs, interpreted )
+[2 of 2] Compiling FatTH            ( FatTH.hs, nothing )
 Ok, two modules loaded.
diff --git a/testsuite/tests/driver/fat-iface/fat015.stderr b/testsuite/tests/driver/fat-iface/fat015.stderr
index ba51cd4ab0..8fb5918730 100644
--- a/testsuite/tests/driver/fat-iface/fat015.stderr
+++ b/testsuite/tests/driver/fat-iface/fat015.stderr
@@ -1,6 +1,6 @@
-[1 of 6] Compiling FatQuote         ( FatQuote.hs, FatQuote.o, FatQuote.dyn_o )
-[2 of 6] Compiling FatQuote1        ( FatQuote1.hs, FatQuote1.o, FatQuote1.dyn_o )
+[1 of 6] Compiling FatQuote         ( FatQuote.hs, FatQuote.o, FatQuote.dyn_o, interpreted )
+[2 of 6] Compiling FatQuote1        ( FatQuote1.hs, interpreted )
 [3 of 6] Compiling FatQuote2        ( FatQuote2.hs, FatQuote2.o, FatQuote2.dyn_o )
-[4 of 6] Compiling FatTH1           ( FatTH1.hs, FatTH1.o, FatTH1.dyn_o )
-[5 of 6] Compiling FatTH2           ( FatTH2.hs, FatTH2.o, FatTH2.dyn_o )
+[4 of 6] Compiling FatTH1           ( FatTH1.hs, nothing )
+[5 of 6] Compiling FatTH2           ( FatTH2.hs, nothing )
 [6 of 6] Compiling FatTHTop         ( FatTHTop.hs, nothing )
diff --git a/testsuite/tests/driver/implicit-dyn-too/implicit-dyn-too.stdout b/testsuite/tests/driver/implicit-dyn-too/implicit-dyn-too.stdout
index af7ea64403..d7546e6203 100644
--- a/testsuite/tests/driver/implicit-dyn-too/implicit-dyn-too.stdout
+++ b/testsuite/tests/driver/implicit-dyn-too/implicit-dyn-too.stdout
@@ -1,4 +1,4 @@
 [1 of 2] Compiling QuasiExpr        ( QuasiExpr.hs, QuasiExpr.o, QuasiExpr.dyn_o )
-[2 of 2] Compiling QuasiQuote       ( QuasiQuote.hs, QuasiQuote.o, QuasiQuote.dyn_o )
+[2 of 2] Compiling QuasiQuote       ( QuasiQuote.hs, nothing )
 [1 of 2] Compiling QuasiExpr        ( QuasiExpr.hs, QuasiExpr.o, QuasiExpr.dyn_o ) [Missing dynamic object file]
-[2 of 2] Compiling QuasiQuote       ( QuasiQuote.hs, QuasiQuote.o, QuasiQuote.dyn_o ) [QuasiExpr[TH] changed]
+[2 of 2] Compiling QuasiQuote       ( QuasiQuote.hs, nothing ) [QuasiExpr[TH] changed]