driver: Remove needsTemplateHaskellOrQQ from ModuleGraphwip/driver-things

The idea of the needsTemplateHaskellOrQQ query is to check if any of the
modules in a module graph need Template Haskell then enable -dynamic-too
if necessary. This is quite imprecise though as it will enable
-dynamic-too for all modules in the module graph even if only one module
uses template haskell, with multiple home units, this is obviously even
worse.

With -fno-code we already have similar logic to enable code generation
just for the modules which are dependeded on my TemplateHaskell modules
so we use the same code path to decide whether to enable -dynamic-too
rather than using this big hammer.

This is part of the larger overall goal of moving as much statically
known configuration into the downsweep as possible in order to have
fully decided the build plan and all the options before starting to
build anything.

I also included a fix to #21095, a long standing bug with with the logic
which is supposed to enable the external interpreter if we don't have
the internal interpreter.

Fixes #20696 #21095

11 files changed, 114 insertions, 88 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 59790e3b68..2d2de4550b 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -25,7 +25,6 @@ module GHC (
         runGhc, runGhcT, initGhcMonad,
         printException,
         handleSourceError,
-        needsTemplateHaskellOrQQ,
 
         -- * Flags and settings
         DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt,
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 6023d3a914..45c94e1c5d 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -18,6 +18,7 @@
 {-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE CPP #-}
 
 -- -----------------------------------------------------------------------------
 --
@@ -64,6 +65,7 @@ import qualified GHC.Linker.Loader as Linker
 import GHC.Linker.Types
 
 import GHC.Runtime.Context
+import GHC.Platform.Ways
 
 import GHC.Driver.Config.Finder (initFinderOpts)
 import GHC.Driver.Config.Parser (initParserOpts)
@@ -1445,9 +1447,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
        -- for dependencies of modules that have -XTemplateHaskell,
        -- otherwise those modules will fail to compile.
        -- See Note [-fno-code mode] #8025
-       th_enabled_nodes <- case backend dflags of
-                              NoBackend -> enableCodeGenForTH logger tmpfs unit_env all_nodes
-                              _ -> return all_nodes
+       th_enabled_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes
        if null all_root_errs
          then return (all_errs, th_enabled_nodes)
          else pure $ (all_root_errs, [])
@@ -1461,7 +1461,6 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
 
         calcDeps ms = [(ms_unitid ms, b, c) | (b, c) <- msDeps ms ]
 
-        dflags = hsc_dflags hsc_env
         logger = hsc_logger hsc_env
         roots  = hsc_targets hsc_env
 
@@ -1648,14 +1647,8 @@ enableCodeGenForTH
   -> [ModuleGraphNode]
   -> IO [ModuleGraphNode]
 enableCodeGenForTH logger tmpfs unit_env =
-  enableCodeGenWhen logger tmpfs condition should_modify TFL_CurrentModule TFL_GhcSession unit_env
+  enableCodeGenWhen logger tmpfs TFL_CurrentModule TFL_GhcSession unit_env
   where
-    condition = isTemplateHaskellOrQQNonBoot
-    should_modify ms@(ModSummary { ms_hspp_opts = dflags }) =
-      backend dflags == NoBackend &&
-      -- Don't enable codegen for TH on indefinite packages; we
-      -- can't compile anything anyway! See #16219.
-      isHomeUnitDefinite (ue_unitHomeUnit (ms_unitid ms) unit_env)
 
 -- | Helper used to implement 'enableCodeGenForTH'.
 -- In particular, this enables
@@ -1666,14 +1659,12 @@ enableCodeGenForTH logger tmpfs unit_env =
 enableCodeGenWhen
   :: Logger
   -> TmpFs
-  -> (ModSummary -> Bool)
-  -> (ModSummary -> Bool)
   -> TempFileLifetime
   -> TempFileLifetime
   -> UnitEnv
   -> [ModuleGraphNode]
   -> IO [ModuleGraphNode]
-enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife unit_env mod_graph =
+enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
   mapM enable_code_gen mod_graph
   where
     defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env)
@@ -1684,37 +1675,86 @@ enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife unit_e
         , ms_hsc_src = HsSrcFile
         , ms_hspp_opts = dflags
         } <- ms
-      , should_modify ms
-      , mkNodeKey n `Set.member` needs_codegen_set
-      = do
-        let new_temp_file suf dynsuf = do
-              tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf
-              let dyn_tn = tn -<.> dynsuf
-              addFilesToClean tmpfs dynLife [dyn_tn]
-              return (tn, dyn_tn)
-          -- We don't want to create .o or .hi files unless we have been asked
-          -- to by the user. But we need them, so we patch their locations in
-          -- the ModSummary with temporary files.
-          --
-        ((hi_file, dyn_hi_file), (o_file, dyn_o_file)) <-
-          -- If ``-fwrite-interface` is specified, then the .o and .hi files
-          -- are written into `-odir` and `-hidir` respectively.  #16670
-          if gopt Opt_WriteInterface dflags
-            then return ((ml_hi_file ms_location, ml_dyn_hi_file ms_location)
-                        , (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 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}
-              }
-        pure (ModuleNode deps ms')
+      , mkNodeKey n `Set.member` needs_codegen_set =
+      if | nocode_enable ms -> do
+               let new_temp_file suf dynsuf = do
+                     tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf
+                     let dyn_tn = tn -<.> dynsuf
+                     addFilesToClean tmpfs dynLife [dyn_tn]
+                     return (tn, dyn_tn)
+                 -- We don't want to create .o or .hi files unless we have been asked
+                 -- to by the user. But we need them, so we patch their locations in
+                 -- the ModSummary with temporary files.
+                 --
+               ((hi_file, dyn_hi_file), (o_file, dyn_o_file)) <-
+                 -- If ``-fwrite-interface` is specified, then the .o and .hi files
+                 -- are written into `-odir` and `-hidir` respectively.  #16670
+                 if gopt Opt_WriteInterface dflags
+                   then return ((ml_hi_file ms_location, ml_dyn_hi_file ms_location)
+                               , (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 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}
+                     }
+               -- Recursive call to catch the other cases
+               enable_code_gen (ModuleNode deps ms')
+         | dynamic_too_enable ms -> do
+               let ms' = ms
+                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_BuildDynamicToo
+                     }
+               -- Recursive call to catch the other cases
+               enable_code_gen (ModuleNode deps ms')
+         | ext_interp_enable ms -> do
+               let ms' = ms
+                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ExternalInterpreter
+                     }
+               -- Recursive call to catch the other cases
+               enable_code_gen (ModuleNode deps ms')
+
+         | otherwise -> return n
+
     enable_code_gen ms = return ms
 
+    nocode_enable ms@(ModSummary { ms_hspp_opts = dflags }) =
+      backend dflags == NoBackend &&
+      -- Don't enable codegen for TH on indefinite packages; we
+      -- can't compile anything anyway! See #16219.
+      isHomeUnitDefinite (ue_unitHomeUnit (ms_unitid ms) unit_env)
+
+    -- #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
+      = hostIsDynamic && internalInterpreter &&
+            not isDynWay && not isProfWay &&  not dyn_too_enabled
+      where
+       lcl_dflags   = ms_hspp_opts ms
+       internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)
+       dyn_too_enabled =  (gopt Opt_BuildDynamicToo lcl_dflags)
+       isDynWay    = hasWay (ways lcl_dflags) WayDyn
+       isProfWay   = hasWay (ways lcl_dflags) WayProf
+
+    -- #16331 - when no "internal interpreter" is available but we
+    -- need to process some TemplateHaskell or QuasiQuotes, we automatically
+    -- turn on -fexternal-interpreter.
+    ext_interp_enable ms = not host_internalInterpreter && internalInterpreter
+      where
+       lcl_dflags   = ms_hspp_opts ms
+#if defined(HAVE_INTERNAL_INTERPRETER)
+       host_internalInterpreter = True
+#else
+       host_internalInterpreter = False
+#endif
+       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)
@@ -1723,7 +1763,7 @@ enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife unit_e
     has_th_set =
       [ mkNodeKey mn
       | mn@(ModuleNode _ ms) <- mod_graph
-      , condition ms
+      , isTemplateHaskellOrQQNonBoot ms
       ]
 
 -- | Populate the Downsweep cache with the root modules.
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index ab1fb9f76f..d66a6074c9 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -108,7 +108,6 @@ import GHC.Unit.Env
 --import GHC.Unit.State
 import GHC.Unit.Module.ModSummary
 import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.Graph (needsTemplateHaskellOrQQ)
 import GHC.Unit.Module.Deps
 import GHC.Unit.Home.ModInfo
 
@@ -252,11 +251,6 @@ compileOne' mHscMessage
        location    = ms_location summary
        input_fn    = expectJust "compile:hs" (ml_hs_file location)
        input_fnpp  = ms_hspp_file summary
-       mod_graph   = hsc_mod_graph hsc_env0
-       needsLinker = needsTemplateHaskellOrQQ mod_graph
-       isDynWay    = hasWay (ways lcl_dflags) WayDyn
-       isProfWay   = hasWay (ways lcl_dflags) WayProf
-       internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)
 
        pipelineOutput = case bcknd of
          Interpreter -> NoOutputFile
@@ -266,28 +260,13 @@ compileOne' mHscMessage
        logger = hsc_logger hsc_env0
        tmpfs  = hsc_tmpfs hsc_env0
 
-       -- #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.
-       dflags1 = if hostIsDynamic && internalInterpreter &&
-                    not isDynWay && not isProfWay && needsLinker
-                  then gopt_set lcl_dflags Opt_BuildDynamicToo
-                  else lcl_dflags
-
-       -- #16331 - when no "internal interpreter" is available but we
-       -- need to process some TemplateHaskell or QuasiQuotes, we automatically
-       -- turn on -fexternal-interpreter.
-       dflags2 = if not internalInterpreter && needsLinker
-                 then gopt_set dflags1 Opt_ExternalInterpreter
-                 else dflags1
-
        basename = dropExtension input_fn
 
        -- We add the directory in which the .hs files resides) to the import
        -- path.  This is needed when we try to compile the .hc file later, if it
        -- imports a _stub.h file that we created here.
        current_dir = takeDirectory basename
-       old_paths   = includePaths dflags2
+       old_paths   = includePaths lcl_dflags
        loadAsByteCode
          | Just Target { targetAllowObjCode = obj } <- findTarget summary (hsc_targets hsc_env0)
          , not obj
@@ -300,9 +279,9 @@ compileOne' mHscMessage
          -- 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)
+         = (Interpreter, gopt_set (lcl_dflags { backend = Interpreter }) Opt_ForceRecomp)
          | otherwise
-         = (backend dflags, dflags2)
+         = (backend dflags, lcl_dflags)
        -- See Note [Filepaths and Multiple Home Units]
        dflags  = dflags3 { includePaths = offsetIncludePaths dflags3 $ addImplicitQuoteInclude old_paths [current_dir] }
        upd_summary = summary { ms_hspp_opts = dflags }
diff --git a/compiler/GHC/Unit/Module/Graph.hs b/compiler/GHC/Unit/Module/Graph.hs
index 913c51ef10..2a791b42b5 100644
--- a/compiler/GHC/Unit/Module/Graph.hs
+++ b/compiler/GHC/Unit/Module/Graph.hs
@@ -12,14 +12,13 @@ module GHC.Unit.Module.Graph
    , extendMG
    , extendMGInst
    , extendMG'
+   , isTemplateHaskellOrQQNonBoot
    , filterToposortToModules
    , mapMG
    , mgModSummaries
    , mgModSummaries'
    , mgLookupModule
    , mgTransDeps
-   , needsTemplateHaskellOrQQ
-   , isTemplateHaskellOrQQNonBoot
    , showModMsg
    , moduleGraphNodeModule
    , moduleGraphNodeModSum
@@ -135,20 +134,8 @@ data ModuleGraph = ModuleGraph
     -- repeated whenever the transitive dependencies need to be calculated (for example, hptInstances)
   , mg_non_boot :: ModuleEnv ModSummary
     -- a map of all non-boot ModSummaries keyed by Modules
-  , mg_needs_th_or_qq :: !Bool
-    -- does any of the modules in mg_mss require TemplateHaskell or
-    -- QuasiQuotes?
   }
 
--- | Determines whether a set of modules requires Template Haskell or
--- Quasi Quotes
---
--- Note that if the session's 'DynFlags' enabled Template Haskell when
--- 'depanal' was called, then each module in the returned module graph will
--- have Template Haskell enabled whether it is actually needed or not.
-needsTemplateHaskellOrQQ :: ModuleGraph -> Bool
-needsTemplateHaskellOrQQ mg = mg_needs_th_or_qq mg
-
 -- | Map a function 'f' over all the 'ModSummaries'.
 -- To preserve invariants 'f' can't change the isBoot status.
 mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph
@@ -169,15 +156,12 @@ mgModSummaries mg = [ m | ModuleNode _ m <- mgModSummaries' mg ]
 mgModSummaries' :: ModuleGraph -> [ModuleGraphNode]
 mgModSummaries' = mg_mss
 
-mgElemModule :: ModuleGraph -> Module -> Bool
-mgElemModule ModuleGraph{..} m = elemModuleEnv m mg_non_boot
-
 -- | Look up a ModSummary in the ModuleGraph
 mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary
 mgLookupModule ModuleGraph{..} m = lookupModuleEnv mg_non_boot m
 
 emptyMG :: ModuleGraph
-emptyMG = ModuleGraph [] Map.empty emptyModuleEnv False
+emptyMG = ModuleGraph [] Map.empty emptyModuleEnv
 
 isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool
 isTemplateHaskellOrQQNonBoot ms =
@@ -194,7 +178,6 @@ extendMG ModuleGraph{..} deps ms = ModuleGraph
   , mg_non_boot = case isBootSummary ms of
       IsBoot -> mg_non_boot
       NotBoot -> extendModuleEnv mg_non_boot (ms_mod ms) ms
-  , mg_needs_th_or_qq = mg_needs_th_or_qq || isTemplateHaskellOrQQNonBoot ms
   }
   where
     (gg, _lookup_node) = moduleGraphNodes False (ModuleNode deps ms : mg_mss)
diff --git a/testsuite/tests/driver/T20696/A.hs b/testsuite/tests/driver/T20696/A.hs
new file mode 100644
index 0000000000..41644a1c54
--- /dev/null
+++ b/testsuite/tests/driver/T20696/A.hs
@@ -0,0 +1,3 @@
+module A where
+
+import B
diff --git a/testsuite/tests/driver/T20696/B.hs b/testsuite/tests/driver/T20696/B.hs
new file mode 100644
index 0000000000..246372a6b4
--- /dev/null
+++ b/testsuite/tests/driver/T20696/B.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
+module B where
+
+import C
diff --git a/testsuite/tests/driver/T20696/C.hs b/testsuite/tests/driver/T20696/C.hs
new file mode 100644
index 0000000000..b752ace32d
--- /dev/null
+++ b/testsuite/tests/driver/T20696/C.hs
@@ -0,0 +1,3 @@
+module C where
+
+
diff --git a/testsuite/tests/driver/T20696/Makefile b/testsuite/tests/driver/T20696/Makefile
new file mode 100644
index 0000000000..4a268530f1
--- /dev/null
+++ b/testsuite/tests/driver/T20696/Makefile
@@ -0,0 +1,4 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
diff --git a/testsuite/tests/driver/T20696/T20696-static.stderr b/testsuite/tests/driver/T20696/T20696-static.stderr
new file mode 100644
index 0000000000..c54adf404a
--- /dev/null
+++ b/testsuite/tests/driver/T20696/T20696-static.stderr
@@ -0,0 +1,4 @@
+
+[1 of 3] Compiling C                ( C.hs, C.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/T20696/T20696.stderr b/testsuite/tests/driver/T20696/T20696.stderr
new file mode 100644
index 0000000000..de9a537caf
--- /dev/null
+++ b/testsuite/tests/driver/T20696/T20696.stderr
@@ -0,0 +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 )
+[3 of 3] Compiling A                ( A.hs, A.o )
diff --git a/testsuite/tests/driver/T20696/all.T b/testsuite/tests/driver/T20696/all.T
new file mode 100644
index 0000000000..6fc2ae7545
--- /dev/null
+++ b/testsuite/tests/driver/T20696/all.T
@@ -0,0 +1,4 @@
+test('T20696', [extra_files(['A.hs', 'B.hs', 'C.hs'])
+               , unless(ghc_dynamic(), skip)], multimod_compile, ['A', ''])
+test('T20696-static', [extra_files(['A.hs', 'B.hs', 'C.hs'])
+               , when(ghc_dynamic(), skip)], multimod_compile, ['A', ''])