diff options
| -rw-r--r-- | compiler/GHC.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Make.hs | 128 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Pipeline.hs | 27 | ||||
| -rw-r--r-- | compiler/GHC/Unit/Module/Graph.hs | 21 | ||||
| -rw-r--r-- | testsuite/tests/driver/T20696/A.hs | 3 | ||||
| -rw-r--r-- | testsuite/tests/driver/T20696/B.hs | 4 | ||||
| -rw-r--r-- | testsuite/tests/driver/T20696/C.hs | 3 | ||||
| -rw-r--r-- | testsuite/tests/driver/T20696/Makefile | 4 | ||||
| -rw-r--r-- | testsuite/tests/driver/T20696/T20696-static.stderr | 4 | ||||
| -rw-r--r-- | testsuite/tests/driver/T20696/T20696.stderr | 3 | ||||
| -rw-r--r-- | testsuite/tests/driver/T20696/all.T | 4 |
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 fe1af07f93..2c0e074216 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 6a5ebc74d9..415bb5e38f 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', '']) |