summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Data/EnumSet.hs4
-rw-r--r--compiler/GHC/Driver/Backpack.hs7
-rw-r--r--compiler/GHC/Driver/Main.hs161
-rw-r--r--compiler/GHC/Driver/Make.hs8
-rw-r--r--compiler/GHC/Driver/MakeFile.hs10
-rw-r--r--compiler/GHC/Driver/Pipeline.hs113
-rw-r--r--compiler/GHC/Driver/Session.hs258
-rw-r--r--compiler/GHC/HsToCore/Usage.hs2
-rw-r--r--compiler/GHC/Iface/Load.hs49
-rw-r--r--compiler/GHC/Iface/Recomp.hs7
-rw-r--r--compiler/GHC/Linker/Dynamic.hs2
-rw-r--r--compiler/GHC/Linker/Loader.hs4
-rw-r--r--compiler/GHC/Platform/Ways.hs5
-rw-r--r--compiler/GHC/Tc/Utils/Monad.hs13
-rw-r--r--compiler/GHC/Unit/Module/Status.hs7
-rw-r--r--ghc/Main.hs2
-rw-r--r--testsuite/tests/plugins/static-plugins.hs2
17 files changed, 416 insertions, 238 deletions
diff --git a/compiler/GHC/Data/EnumSet.hs b/compiler/GHC/Data/EnumSet.hs
index 61d6bf002b..a7949c7e71 100644
--- a/compiler/GHC/Data/EnumSet.hs
+++ b/compiler/GHC/Data/EnumSet.hs
@@ -8,6 +8,7 @@ module GHC.Data.EnumSet
, toList
, fromList
, empty
+ , difference
) where
import GHC.Prelude
@@ -33,3 +34,6 @@ fromList = EnumSet . IntSet.fromList . map fromEnum
empty :: EnumSet a
empty = EnumSet IntSet.empty
+
+difference :: EnumSet a -> EnumSet a -> EnumSet a
+difference (EnumSet a) (EnumSet b) = EnumSet (IntSet.difference a b)
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index d35e32cc27..d38ba98622 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -204,8 +204,11 @@ withBkpSession cid insts deps session_type do_this = do
hiDir = Just (outdir hiDir),
stubDir = Just (outdir stubDir),
-- Unset output-file for non exe builds
- outputFile = if session_type == ExeSession
- then outputFile dflags
+ outputFile_ = if session_type == ExeSession
+ then outputFile_ dflags
+ else Nothing,
+ dynOutputFile_ = if session_type == ExeSession
+ then dynOutputFile_ dflags
else Nothing,
-- Clear the import path so we don't accidentally grab anything
importPaths = [],
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index c8905210ab..e924826b0c 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -fprof-auto-top #-}
-------------------------------------------------------------------------------
@@ -866,8 +867,8 @@ finish summary tc_result mb_old_hash = do
hscs_mod_location = ms_location summary,
hscs_mod_details = details,
hscs_partial_iface = partial_iface,
- hscs_old_iface_hash = mb_old_hash,
- hscs_iface_dflags = dflags }
+ hscs_old_iface_hash = mb_old_hash
+ }
-- We are not generating code, so we can skip simplification
-- and generate a simple interface.
@@ -875,7 +876,7 @@ finish summary tc_result mb_old_hash = do
(iface, mb_old_iface_hash, details) <- liftIO $
hscSimpleIface hsc_env tc_result mb_old_hash
- liftIO $ hscMaybeWriteIface dflags iface mb_old_iface_hash (ms_location summary)
+ liftIO $ hscMaybeWriteIface dflags True iface mb_old_iface_hash (ms_location summary)
return $ case bcknd of
NoBackend -> HscNotGeneratingCode iface details
@@ -888,27 +889,110 @@ finish summary tc_result mb_old_hash = do
Note [Writing interface files]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We write interface files in GHC.Driver.Main and GHC.Driver.Pipeline using
-hscMaybeWriteIface, but only once per compilation (twice with dynamic-too).
+We write one interface file per module and per compilation, except with
+-dynamic-too where we write two interface files (non-dynamic and dynamic).
+
+We can write two kinds of interfaces (see Note [Interface file stages] in
+"GHC.Driver.Types"):
+
+ * simple interface: interface generated after the core pipeline
+
+ * full interface: simple interface completed with information from the
+ backend
+
+Depending on the situation, we write one or the other (using
+`hscMaybeWriteIface`). We must be careful with `-dynamic-too` because only the
+backend is run twice, so if we write a simple interface we need to write both
+the non-dynamic and the dynamic interfaces at the same time (with the same
+contents).
+
+Cases for which we generate simple interfaces:
+
+ * GHC.Driver.Main.finish: when a compilation does NOT require (re)compilation
+ of the hard code
+
+ * GHC.Driver.Pipeline.compileOne': when we run in One Shot mode and target
+ bytecode (if interface writing is forced).
+
+ * GHC.Driver.Backpack uses simple interfaces for indefinite units
+ (units with module holes). It writes them indirectly by forcing the
+ -fwrite-interface flag while setting backend to NoBackend.
+
+Cases for which we generate full interfaces:
+
+ * GHC.Driver.Pipeline.runPhase: when we must be compiling to regular hard
+ code and/or require recompilation.
+
+By default interface file names are derived from module file names by adding
+suffixes. The interface file name can be overloaded with "-ohi", except when
+`-dynamic-too` is used.
-* If a compilation does NOT require (re)compilation of the hard code we call
- hscMaybeWriteIface inside GHC.Driver.Main:finish.
-* If we run in One Shot mode and target bytecode we write it in compileOne'
-* Otherwise we must be compiling to regular hard code and require recompilation.
- In this case we create the interface file inside RunPhase using the interface
- generator contained inside the HscRecomp status.
-}
-hscMaybeWriteIface :: DynFlags -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()
-hscMaybeWriteIface dflags iface old_iface location = do
+
+-- | Write interface files
+hscMaybeWriteIface :: DynFlags -> Bool -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()
+hscMaybeWriteIface 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
- no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface))
- when (write_interface || force_write_interface) $
- hscWriteIface dflags iface no_change location
+ -- mod_location only contains the base name, so we rebuild the
+ -- correct file extension from the dynflags.
+ baseName = ml_hi_file mod_location
+ buildIfName suffix
+ | Just name <- outputHi dflags
+ = name
+ | otherwise
+ = let with_hi = replaceExtension baseName suffix
+ in addBootSuffix_maybe (mi_boot iface) with_hi
+
+ write_iface dflags' iface =
+ {-# SCC "writeIface" #-}
+ writeIface dflags' (buildIfName (hiSuf dflags')) iface
+
+ when (write_interface || force_write_interface) $ do
+
+ -- FIXME: with -dynamic-too, "no_change" is only meaningful for the
+ -- non-dynamic interface, not for the dynamic one. We should have another
+ -- flag for the dynamic interface. In the meantime:
+ --
+ -- * when we write a single full interface, we check if we are
+ -- currently writing the dynamic interface due to -dynamic-too, in
+ -- which case we ignore "no_change".
+ --
+ -- * when we write two simple interfaces at once because of
+ -- dynamic-too, we use "no_change" both for the non-dynamic and the
+ -- dynamic interfaces. Hopefully both the dynamic and the non-dynamic
+ -- interfaces stay in sync...
+ --
+ let no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface))
+
+ dt <- dynamicTooState dflags
+
+ when (dopt Opt_D_dump_if_trace dflags) $ putMsg dflags $
+ hang (text "Writing interface(s):") 2 $ vcat
+ [ text "Kind:" <+> if is_simple then text "simple" else text "full"
+ , text "Hash change:" <+> ppr (not no_change)
+ , text "DynamicToo state:" <+> text (show dt)
+ ]
+
+ if is_simple
+ then unless no_change $ do -- FIXME: see no_change' comment above
+ write_iface dflags iface
+ case dt of
+ DT_Dont -> return ()
+ DT_Failed -> return ()
+ DT_Dyn -> panic "Unexpected DT_Dyn state when writing simple interface"
+ DT_OK -> write_iface (setDynamicNow dflags) iface
+ else case dt of
+ DT_Dont | not no_change -> write_iface dflags iface
+ DT_OK | not no_change -> write_iface dflags iface
+ -- FIXME: see no_change' comment above
+ DT_Dyn -> write_iface dflags iface
+ DT_Failed | not (dynamicNow dflags) -> write_iface dflags iface
+ _ -> return ()
--------------------------------------------------------------
-- NoRecomp handlers
@@ -1384,51 +1468,6 @@ hscSimpleIface' tc_result mb_old_iface = do
--------------------------------------------------------------
-- BackEnd combinators
--------------------------------------------------------------
-{-
-Note [Interface filename extensions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-ModLocation only contains the base names, however when generating dynamic files
-the actual extension might differ from the default.
-
-So we only load the base name from ModLocation and replace the actual extension
-according to the information in DynFlags.
-
-If we generate a interface file right after running the core pipeline we will
-have set -dynamic-too and potentially generate both interface files at the same
-time.
-
-If we generate a interface file after running the backend then dynamic-too won't
-be set, however then the extension will be contained in the dynflags instead so
-things still work out fine.
--}
-
-hscWriteIface :: DynFlags -> ModIface -> Bool -> ModLocation -> IO ()
-hscWriteIface dflags iface no_change mod_location = do
- -- mod_location only contains the base name, so we rebuild the
- -- correct file extension from the dynflags.
- let ifaceBaseFile = ml_hi_file mod_location
- unless no_change $
- let ifaceFile = buildIfName ifaceBaseFile (hiSuf dflags)
- in {-# SCC "writeIface" #-}
- writeIface dflags ifaceFile iface
- whenGeneratingDynamicToo dflags $ do
- -- TODO: We should do a no_change check for the dynamic
- -- interface file too
- -- When we generate iface files after core
- let dynDflags = dynamicTooMkDynamicDynFlags dflags
- -- dynDflags will have set hiSuf correctly.
- dynIfaceFile = buildIfName ifaceBaseFile (hiSuf dynDflags)
-
- writeIface dynDflags dynIfaceFile iface
- where
- buildIfName :: String -> String -> String
- buildIfName baseName suffix
- | Just name <- outputHi dflags
- = name
- | otherwise
- = let with_hi = replaceExtension baseName suffix
- in addBootSuffix_maybe (mi_boot iface) with_hi
-- | Compile to hard-code.
hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 53ae5897ed..06f5014684 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -712,9 +712,9 @@ guessOutputFile = modifySession $ \env ->
"must specify -o explicitly"
else Just name'
in
- case outputFile dflags of
+ case outputFile_ dflags of
Just _ -> env
- Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }
+ Nothing -> env { hsc_dflags = dflags { outputFile_ = name_exe } }
-- -----------------------------------------------------------------------------
--
@@ -2300,8 +2300,8 @@ enableCodeGenWhen condition should_modify staticLife dynLife bcknd nodemap =
-- are written into `-odir` and `-hidir` respectively. #16670
if gopt Opt_WriteInterface dflags
then return (ml_hi_file ms_location, ml_obj_file ms_location)
- else (,) <$> (new_temp_file (hiSuf dflags) (dynHiSuf dflags))
- <*> (new_temp_file (objectSuf dflags) (dynObjectSuf dflags))
+ else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))
+ <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))
return $
ms
{ ms_location =
diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs
index 81408ab7c9..c8c4c07d0d 100644
--- a/compiler/GHC/Driver/MakeFile.hs
+++ b/compiler/GHC/Driver/MakeFile.hs
@@ -67,11 +67,11 @@ doMkDependHS srcs = do
-- We therefore do the initial dependency generation with an empty
-- way and .o/.hi extensions, regardless of any flags that might
-- be specified.
- let dflags = dflags0 {
- ways = Set.empty,
- hiSuf = "hi",
- objectSuf = "o"
- }
+ let dflags = dflags0
+ { targetWays_ = Set.empty
+ , hiSuf_ = "hi"
+ , objectSuf_ = "o"
+ }
GHC.setSessionDynFlags dflags
when (null (depSuffixes dflags)) $ liftIO $
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index d8abadc0e5..c65c54ab12 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -4,6 +4,7 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
@@ -258,12 +259,12 @@ compileOne' m_tc_result mHscMessage
hscs_mod_location = mod_location,
hscs_mod_details = hmi_details,
hscs_partial_iface = partial_iface,
- hscs_old_iface_hash = mb_old_iface_hash,
- hscs_iface_dflags = iface_dflags }, Interpreter) -> do
+ hscs_old_iface_hash = mb_old_iface_hash
+ }, 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'{hsc_dflags=iface_dflags} partial_iface Nothing
- liftIO $ hscMaybeWriteIface dflags final_iface mb_old_iface_hash (ms_location summary)
+ final_iface <- mkFullIface hsc_env' partial_iface Nothing
+ liftIO $ hscMaybeWriteIface dflags True final_iface mb_old_iface_hash (ms_location summary)
(hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts mod_location
@@ -773,20 +774,41 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase)
r <- runPipeline' start_phase hsc_env env input_fn'
maybe_loc foreign_os
- -- If we are compiling a Haskell module, and doing
- -- -dynamic-too, but couldn't do the -dynamic-too fast
- -- path, then rerun the pipeline for the dyn way
let dflags = hsc_dflags hsc_env
- -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987)
- when (not $ platformOS (targetPlatform dflags) == OSMinGW32) $
- when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do
- debugTraceMsg dflags 4
- (text "Running the pipeline again for -dynamic-too")
- let dflags' = dynamicTooMkDynamicDynFlags dflags
- hsc_env' <- newHscEnv dflags'
- _ <- runPipeline' start_phase hsc_env' env input_fn'
- maybe_loc foreign_os
- return ()
+ when isHaskellishFile $
+ dynamicTooState dflags >>= \case
+ DT_Dont -> return ()
+ DT_Dyn -> return ()
+ DT_OK -> return ()
+ -- If we are compiling a Haskell module with -dynamic-too, we
+ -- first try the "fast path": that is we compile the non-dynamic
+ -- version and at the same time we check that interfaces depended
+ -- on exist both for the non-dynamic AND the dynamic way. We also
+ -- check that they have the same hash.
+ -- If they don't, dynamicTooState is set to DT_Failed.
+ -- See GHC.Iface.Load.checkBuildDynamicToo
+ -- If they do, in the end we produce both the non-dynamic and
+ -- dynamic outputs.
+ --
+ -- If this "fast path" failed, we execute the whole pipeline
+ -- again, this time for the dynamic way *only*. To do that we
+ -- just set the dynamicNow bit from the start to ensure that the
+ -- dynamic DynFlags fields are used and we disable -dynamic-too
+ -- (its state is already set to DT_Failed so it wouldn't do much
+ -- anyway).
+ DT_Failed
+ -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987)
+ | OSMinGW32 <- platformOS (targetPlatform dflags) -> return ()
+ | otherwise -> do
+ debugTraceMsg dflags 4
+ (text "Running the full pipeline again for -dynamic-too")
+ let dflags' = flip gopt_unset Opt_BuildDynamicToo
+ $ setDynamicNow
+ $ dflags
+ hsc_env' <- newHscEnv dflags'
+ _ <- runPipeline' start_phase hsc_env' env input_fn'
+ maybe_loc foreign_os
+ return ()
return r
runPipeline'
@@ -850,23 +872,40 @@ pipeLoop phase input_fn = do
_
-> do liftIO $ debugTraceMsg dflags 4
(text "Running phase" <+> ppr phase)
- (next_phase, output_fn) <- runHookedPhase phase input_fn dflags
+
case phase of
HscOut {} -> do
- -- We don't pass Opt_BuildDynamicToo to the backend
- -- in DynFlags.
- -- Instead it's run twice with flags accordingly set
- -- per run.
- let noDynToo = pipeLoop next_phase output_fn
+ let noDynToo = do
+ (next_phase, output_fn) <- runHookedPhase phase input_fn dflags
+ pipeLoop next_phase output_fn
let dynToo = do
- setDynFlags $ gopt_unset dflags Opt_BuildDynamicToo
- r <- pipeLoop next_phase output_fn
- setDynFlags $ dynamicTooMkDynamicDynFlags dflags
- -- TODO shouldn't ignore result:
- _ <- pipeLoop phase input_fn
- return r
- ifGeneratingDynamicToo dflags dynToo noDynToo
- _ -> pipeLoop next_phase output_fn
+ -- if Opt_BuildDynamicToo is set and if the platform
+ -- supports it, we first run the backend to generate
+ -- the dynamic objects and then re-run it to generate
+ -- the non-dynamic ones.
+ let dflags' = setDynamicNow dflags -- set "dynamicNow"
+ setDynFlags dflags'
+ (next_phase, output_fn) <- runHookedPhase phase input_fn dflags'
+ _ <- pipeLoop next_phase output_fn
+ -- TODO: we probably shouldn't ignore the result of
+ -- the dynamic compilation
+ setDynFlags dflags -- restore flags without "dynamicNow" set
+ noDynToo
+ dynamicTooState dflags >>= \case
+ DT_Dont -> noDynToo
+ DT_Failed -> noDynToo
+ DT_OK -> dynToo
+ DT_Dyn -> noDynToo
+ -- it shouldn't be possible to be in this last case
+ -- here. It would mean that we executed the whole
+ -- pipeline with DynamicNow and Opt_BuildDynamicToo set.
+ --
+ -- When we restart the whole pipeline for -dynamic-too
+ -- we set DynamicNow but we unset Opt_BuildDynamicToo so
+ -- it's weird.
+ _ -> do
+ (next_phase, output_fn) <- runHookedPhase phase input_fn dflags
+ pipeLoop next_phase output_fn
runHookedPhase :: PhasePlus -> FilePath -> DynFlags
-> CompPipeline (PhasePlus, FilePath)
@@ -1264,8 +1303,8 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do
hscs_mod_location = mod_location,
hscs_mod_details = mod_details,
hscs_partial_iface = partial_iface,
- hscs_old_iface_hash = mb_old_iface_hash,
- hscs_iface_dflags = iface_dflags }
+ hscs_old_iface_hash = mb_old_iface_hash
+ }
-> do output_fn <- phaseOutputFilename next_phase
PipeState{hsc_env=hsc_env'} <- getPipeState
@@ -1273,17 +1312,17 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do
(outputFilename, mStub, foreign_files, cg_infos) <- liftIO $
hscGenHardCode hsc_env' cgguts mod_location output_fn
- final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface (Just cg_infos))
+ let dflags = hsc_dflags hsc_env'
+ final_iface <- liftIO (mkFullIface hsc_env' partial_iface (Just cg_infos))
let final_mod_details
- | gopt Opt_OmitInterfacePragmas iface_dflags
+ | gopt Opt_OmitInterfacePragmas dflags
= mod_details
| otherwise = {-# SCC updateModDetailsIdInfos #-}
updateModDetailsIdInfos cg_infos mod_details
setIface final_iface final_mod_details
-- See Note [Writing interface files]
- let if_dflags = dflags `gopt_unset` Opt_BuildDynamicToo
- liftIO $ hscMaybeWriteIface if_dflags final_iface mb_old_iface_hash mod_location
+ liftIO $ hscMaybeWriteIface dflags False final_iface mb_old_iface_hash mod_location
stub_o <- liftIO (mapM (compileStub hsc_env') mStub)
foreign_os <- liftIO $
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 2000b9760b..9529b0dea8 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -36,12 +36,11 @@ module GHC.Driver.Session (
xopt, xopt_set, xopt_unset,
xopt_set_unlessExplSpec,
lang_set,
- whenGeneratingDynamicToo, ifGeneratingDynamicToo,
- whenCannotGenerateDynamicToo,
- dynamicTooMkDynamicDynFlags,
+ DynamicTooState(..), dynamicTooState, setDynamicNow, setDynamicTooFailed,
dynamicOutputFile,
sccProfilingEnabled,
DynFlags(..), mainModIs,
+ outputFile, hiSuf, objectSuf, ways,
FlagSpec(..),
HasDynFlags(..), ContainsDynFlags(..),
RtsOptsEnabled(..),
@@ -60,8 +59,9 @@ module GHC.Driver.Session (
positionIndependent,
optimisationFlags,
setFlagsFromEnvFile,
+ pprDynFlagsDiff,
- addWay', targetProfile,
+ targetProfile,
mkHomeUnitFromFlags,
@@ -502,7 +502,7 @@ data DynFlags = DynFlags {
homeUnitInstantiations_ :: [(ModuleName, Module)], -- ^ Module instantiations
-- ways
- ways :: Ways, -- ^ Way flags from the command line
+ targetWays_ :: Ways, -- ^ Target way flags from the command line
-- For object splitting
splitInfo :: Maybe (String,Int),
@@ -515,20 +515,25 @@ data DynFlags = DynFlags {
stubDir :: Maybe String,
dumpDir :: Maybe String,
- objectSuf :: String,
+ objectSuf_ :: String,
hcSuf :: String,
- hiSuf :: String,
+ hiSuf_ :: String,
hieSuf :: String,
- canGenerateDynamicToo :: IORef Bool,
- dynObjectSuf :: String,
- dynHiSuf :: String,
+ dynamicTooFailed :: IORef Bool,
+ dynObjectSuf_ :: String,
+ dynHiSuf_ :: String,
- outputFile :: Maybe String,
- dynOutputFile :: Maybe String,
+ outputFile_ :: Maybe String,
+ dynOutputFile_ :: Maybe String,
outputHi :: Maybe String,
dynLibLoader :: DynLibLoader,
+ dynamicNow :: !Bool, -- ^ Indicate if we are now generating dynamic output
+ -- because of -dynamic-too. This predicate is
+ -- used to query the appropriate fields
+ -- (outputFile/dynOutputFile, ways, etc.)
+
-- | This is set by 'GHC.Driver.Pipeline.runPipeline' based on where
-- its output is going.
dumpPrefix :: Maybe FilePath,
@@ -1034,45 +1039,65 @@ data RtsOptsEnabled
positionIndependent :: DynFlags -> Bool
positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags
-whenGeneratingDynamicToo :: MonadIO m => DynFlags -> m () -> m ()
-whenGeneratingDynamicToo dflags f = ifGeneratingDynamicToo dflags f (return ())
-
-ifGeneratingDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a
-ifGeneratingDynamicToo dflags f g = generateDynamicTooConditional dflags f g g
-
-whenCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m () -> m ()
-whenCannotGenerateDynamicToo dflags f
- = ifCannotGenerateDynamicToo dflags f (return ())
-
-ifCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a
-ifCannotGenerateDynamicToo dflags f g
- = generateDynamicTooConditional dflags g f g
-
-generateDynamicTooConditional :: MonadIO m
- => DynFlags -> m a -> m a -> m a -> m a
-generateDynamicTooConditional dflags canGen cannotGen notTryingToGen
- = if gopt Opt_BuildDynamicToo dflags
- then do let ref = canGenerateDynamicToo dflags
- b <- liftIO $ readIORef ref
- if b then canGen else cannotGen
- else notTryingToGen
-
-dynamicTooMkDynamicDynFlags :: DynFlags -> DynFlags
-dynamicTooMkDynamicDynFlags dflags0
- = let dflags1 = addWay' WayDyn dflags0
- dflags2 = dflags1 {
- outputFile = dynOutputFile dflags1,
- hiSuf = dynHiSuf dflags1,
- objectSuf = dynObjectSuf dflags1
- }
- dflags3 = gopt_unset dflags2 Opt_BuildDynamicToo
- in dflags3
+-- Note [-dynamic-too business]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- With -dynamic-too flag, we try to build both the non-dynamic and dynamic
+-- objects in a single run of the compiler: the pipeline is the same down to
+-- Core optimisation, then the backend (from Core to object code) is executed
+-- twice.
+--
+-- The implementation is currently rather hacky: recompilation avoidance is
+-- broken (#17968), we don't clearly separate non-dynamic and dynamic loaded
+-- interfaces (#9176), etc.
+--
+-- To make matters worse, we automatically enable -dynamic-too when some modules
+-- need Template-Haskell and GHC is dynamically linked (cf
+-- GHC.Driver.Pipeline.compileOne').
+--
+-- This somewhat explains why we have "dynamicTooFailed :: IORef Bool" in
+-- DynFlags: when -dynamic-too is enabled, we try to build the dynamic objects,
+-- but we may fail and we shouldn't abort the whole compilation because the user
+-- may not even have asked for -dynamic-too in the first place. So instead we
+-- use this global variable to indicate that we can't build dynamic objects and
+-- compilation continues to build non-dynamic objects only. At the end of the
+-- non-dynamic pipeline, if this value indicates that the dynamic compilation
+-- failed, we run the whole pipeline again for the dynamic way (except on
+-- Windows...). See GHC.Driver.Pipeline.runPipeline.
+
+data DynamicTooState
+ = DT_Dont -- ^ Don't try to build dynamic objects too
+ | DT_Failed -- ^ Won't try to generate dynamic objects for some reason
+ | DT_OK -- ^ Will still try to generate dynamic objects
+ | DT_Dyn -- ^ Currently generating dynamic objects (in the backend)
+ deriving (Eq,Show,Ord)
+
+dynamicTooState :: MonadIO m => DynFlags -> m DynamicTooState
+dynamicTooState dflags
+ | not (gopt Opt_BuildDynamicToo dflags) = return DT_Dont
+ | otherwise = do
+ failed <- liftIO $ readIORef (dynamicTooFailed dflags)
+ if failed
+ then return DT_Failed
+ else if dynamicNow dflags
+ then return DT_Dyn
+ else return DT_OK
+
+setDynamicNow :: DynFlags -> DynFlags
+setDynamicNow dflags0 =
+ dflags0
+ { dynamicNow = True
+ }
+
+setDynamicTooFailed :: MonadIO m => DynFlags -> m ()
+setDynamicTooFailed dflags =
+ liftIO $ writeIORef (dynamicTooFailed dflags) True
-- | Compute the path of the dynamic object corresponding to an object file.
dynamicOutputFile :: DynFlags -> FilePath -> FilePath
dynamicOutputFile dflags outputFile = dynOut outputFile
where
- dynOut = flip addExtension (dynObjectSuf dflags) . dropExtension
+ dynOut = flip addExtension (dynObjectSuf_ dflags) . dropExtension
-----------------------------------------------------------------------------
@@ -1084,7 +1109,7 @@ initDynFlags dflags = do
-- building dynamically or not.
platformCanGenerateDynamicToo
= platformOS (targetPlatform dflags) /= OSMinGW32
- refCanGenerateDynamicToo <- newIORef platformCanGenerateDynamicToo
+ refDynamicTooFailed <- newIORef (not platformCanGenerateDynamicToo)
refNextTempSuffix <- newIORef 0
refFilesToClean <- newIORef emptyFilesToClean
refDirsToClean <- newIORef Map.empty
@@ -1108,7 +1133,7 @@ initDynFlags dflags = do
(adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv)
(useColor dflags, colScheme dflags)
return dflags{
- canGenerateDynamicToo = refCanGenerateDynamicToo,
+ dynamicTooFailed = refDynamicTooFailed,
nextTempSuffix = refNextTempSuffix,
filesToClean = refFilesToClean,
dirsToClean = refDirsToClean,
@@ -1181,14 +1206,15 @@ defaultDynFlags mySettings llvmConfig =
stubDir = Nothing,
dumpDir = Nothing,
- objectSuf = phaseInputExt StopLn,
+ objectSuf_ = phaseInputExt StopLn,
hcSuf = phaseInputExt HCc,
- hiSuf = "hi",
+ hiSuf_ = "hi",
hieSuf = "hie",
- canGenerateDynamicToo = panic "defaultDynFlags: No canGenerateDynamicToo",
- dynObjectSuf = "dyn_" ++ phaseInputExt StopLn,
- dynHiSuf = "dyn_hi",
+ dynamicTooFailed = panic "defaultDynFlags: No dynamicTooFailed",
+ dynObjectSuf_ = "dyn_" ++ phaseInputExt StopLn,
+ dynHiSuf_ = "dyn_hi",
+ dynamicNow = False,
pluginModNames = [],
pluginModNameOpts = [],
@@ -1197,8 +1223,8 @@ defaultDynFlags mySettings llvmConfig =
staticPlugins = [],
hooks = emptyHooks,
- outputFile = Nothing,
- dynOutputFile = Nothing,
+ outputFile_ = Nothing,
+ dynOutputFile_ = Nothing,
outputHi = Nothing,
dynLibLoader = SystemDependent,
dumpPrefix = Nothing,
@@ -1222,7 +1248,7 @@ defaultDynFlags mySettings llvmConfig =
packageEnv = Nothing,
unitDatabases = Nothing,
unitState = emptyUnitState,
- ways = defaultWays mySettings,
+ targetWays_ = defaultWays mySettings,
splitInfo = Nothing,
ghcNameVersion = sGhcNameVersion mySettings,
@@ -1567,8 +1593,19 @@ dopt_unset :: DynFlags -> DumpFlag -> DynFlags
dopt_unset dfs f = dfs{ dumpFlags = EnumSet.delete f (dumpFlags dfs) }
-- | Test whether a 'GeneralFlag' is set
+--
+-- Note that `dynamicNow` (i.e., dynamic objects built with `-dynamic-too`)
+-- always implicitly enables Opt_PIC, Opt_ExternalDynamicRefs, and disables
+-- Opt_SplitSections.
+--
gopt :: GeneralFlag -> DynFlags -> Bool
-gopt f dflags = f `EnumSet.member` generalFlags dflags
+gopt Opt_PIC dflags
+ | dynamicNow dflags = True
+gopt Opt_ExternalDynamicRefs dflags
+ | dynamicNow dflags = True
+gopt Opt_SplitSections dflags
+ | dynamicNow dflags = False
+gopt f dflags = f `EnumSet.member` generalFlags dflags
-- | Set a 'GeneralFlag'
gopt_set :: DynFlags -> GeneralFlag -> DynFlags
@@ -1777,16 +1814,16 @@ setOutputDir f = setObjectDir f
. setDumpDir f
setDylibInstallName f d = d { dylibInstallName = Just f}
-setObjectSuf f d = d { objectSuf = f}
-setDynObjectSuf f d = d { dynObjectSuf = f}
-setHiSuf f d = d { hiSuf = f}
-setHieSuf f d = d { hieSuf = f}
-setDynHiSuf f d = d { dynHiSuf = f}
-setHcSuf f d = d { hcSuf = f}
+setObjectSuf f d = d { objectSuf_ = f}
+setDynObjectSuf f d = d { dynObjectSuf_ = f}
+setHiSuf f d = d { hiSuf_ = f}
+setHieSuf f d = d { hieSuf = f}
+setDynHiSuf f d = d { dynHiSuf_ = f}
+setHcSuf f d = d { hcSuf = f}
-setOutputFile f d = d { outputFile = f}
-setDynOutputFile f d = d { dynOutputFile = f}
-setOutputHi f d = d { outputHi = f}
+setOutputFile f d = d { outputFile_ = f}
+setDynOutputFile f d = d { dynOutputFile_ = f}
+setOutputHi f d = d { outputHi = f}
setJsonLogAction :: DynFlags -> DynFlags
setJsonLogAction d = d { log_action = jsonLogAction }
@@ -1975,15 +2012,12 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
throwGhcExceptionIO (CmdLineError ("combination not supported: " ++
intercalate "/" (map wayDesc (Set.toAscList theWays))))
- let chooseOutput
- | isJust (outputFile dflags2) -- Only iff user specified -o ...
- , not (isJust (dynOutputFile dflags2)) -- but not -dyno
- = return $ dflags2 { dynOutputFile = Just $ dynamicOutputFile dflags2 outFile }
+ let dflags3
+ | Just outFile <- outputFile_ dflags2 -- Only iff user specified -o ...
+ , not (isJust (dynOutputFile_ dflags2)) -- but not -dyno
+ = dflags2 { dynOutputFile_ = Just $ dynamicOutputFile dflags2 outFile }
| otherwise
- = return dflags2
- where
- outFile = fromJust $ outputFile dflags2
- dflags3 <- ifGeneratingDynamicToo dflags2 chooseOutput (return dflags2)
+ = dflags2
let (dflags4, consistency_warnings) = makeDynFlagsConsistent dflags3
@@ -2158,20 +2192,20 @@ dynamic_flags_deps = [
d { enableTimeStats = True })))
------- ways ---------------------------------------------------------------
- , make_ord_flag defGhcFlag "prof" (NoArg (addWay WayProf))
- , make_ord_flag defGhcFlag "eventlog" (NoArg (addWay WayTracing))
- , make_ord_flag defGhcFlag "debug" (NoArg (addWay WayDebug))
- , make_ord_flag defGhcFlag "threaded" (NoArg (addWay WayThreaded))
+ , make_ord_flag defGhcFlag "prof" (NoArg (addWayDynP WayProf))
+ , make_ord_flag defGhcFlag "eventlog" (NoArg (addWayDynP WayTracing))
+ , make_ord_flag defGhcFlag "debug" (NoArg (addWayDynP WayDebug))
+ , make_ord_flag defGhcFlag "threaded" (NoArg (addWayDynP WayThreaded))
, make_ord_flag defGhcFlag "ticky"
- (NoArg (setGeneralFlag Opt_Ticky >> addWay WayDebug))
+ (NoArg (setGeneralFlag Opt_Ticky >> addWayDynP WayDebug))
-- -ticky enables ticky-ticky code generation, and also implies -debug which
-- is required to get the RTS ticky support.
----- Linker --------------------------------------------------------
, make_ord_flag defGhcFlag "static" (NoArg removeWayDyn)
- , make_ord_flag defGhcFlag "dynamic" (NoArg (addWay WayDyn))
+ , make_ord_flag defGhcFlag "dynamic" (NoArg (addWayDynP WayDyn))
, make_ord_flag defGhcFlag "rdynamic" $ noArg $
#if defined(linux_HOST_OS)
addOptl "-rdynamic"
@@ -4258,20 +4292,21 @@ setDumpFlag :: DumpFlag -> OptKind (CmdLineP DynFlags)
setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag)
--------------------------
-addWay :: Way -> DynP ()
-addWay w = upd (addWay' w)
+addWayDynP :: Way -> DynP ()
+addWayDynP = upd . addWay'
addWay' :: Way -> DynFlags -> DynFlags
-addWay' w dflags0 = let platform = targetPlatform dflags0
- dflags1 = dflags0 { ways = Set.insert w (ways dflags0) }
- dflags2 = foldr setGeneralFlag' dflags1
- (wayGeneralFlags platform w)
- dflags3 = foldr unSetGeneralFlag' dflags2
- (wayUnsetGeneralFlags platform w)
- in dflags3
+addWay' w dflags0 =
+ let platform = targetPlatform dflags0
+ dflags1 = dflags0 { targetWays_ = addWay w (targetWays_ dflags0) }
+ dflags2 = foldr setGeneralFlag' dflags1
+ (wayGeneralFlags platform w)
+ dflags3 = foldr unSetGeneralFlag' dflags2
+ (wayUnsetGeneralFlags platform w)
+ in dflags3
removeWayDyn :: DynP ()
-removeWayDyn = upd (\dfs -> dfs { ways = Set.filter (WayDyn /=) (ways dfs) })
+removeWayDyn = upd (\dfs -> dfs { targetWays_ = Set.filter (WayDyn /=) (targetWays_ dfs) })
--------------------------
setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP ()
@@ -4866,7 +4901,7 @@ makeDynFlagsConsistent dflags
, hostIsProfiled
, backendProducesObject (backend dflags)
, WayProf `Set.notMember` ways dflags
- = loop dflags{ways = Set.insert WayProf (ways dflags)}
+ = loop dflags{targetWays_ = addWay WayProf (targetWays_ dflags)}
"Enabling -prof, because -fobject-code is enabled and GHCi is profiled"
| otherwise = (dflags, [])
@@ -5059,3 +5094,44 @@ initSDocContext dflags style = SDC
-- | Initialize the pretty-printing options using the default user style
initDefaultSDocContext :: DynFlags -> SDocContext
initDefaultSDocContext dflags = initSDocContext dflags defaultUserStyle
+
+outputFile :: DynFlags -> Maybe String
+outputFile dflags
+ | dynamicNow dflags = dynOutputFile_ dflags
+ | otherwise = outputFile_ dflags
+
+hiSuf :: DynFlags -> String
+hiSuf dflags
+ | dynamicNow dflags = dynHiSuf_ dflags
+ | otherwise = hiSuf_ dflags
+
+objectSuf :: DynFlags -> String
+objectSuf dflags
+ | dynamicNow dflags = dynObjectSuf_ dflags
+ | otherwise = objectSuf_ dflags
+
+ways :: DynFlags -> Ways
+ways dflags
+ | dynamicNow dflags = addWay WayDyn (targetWays_ dflags)
+ | otherwise = targetWays_ dflags
+
+-- | Pretty-print the difference between 2 DynFlags.
+--
+-- For now only their general flags but it could be extended.
+-- Useful mostly for debugging.
+pprDynFlagsDiff :: DynFlags -> DynFlags -> SDoc
+pprDynFlagsDiff d1 d2 =
+ let gf_removed = EnumSet.difference (generalFlags d1) (generalFlags d2)
+ gf_added = EnumSet.difference (generalFlags d2) (generalFlags d1)
+ ext_removed = EnumSet.difference (extensionFlags d1) (extensionFlags d2)
+ ext_added = EnumSet.difference (extensionFlags d2) (extensionFlags d1)
+ in vcat
+ [ text "Added general flags:"
+ , text $ show $ EnumSet.toList $ gf_added
+ , text "Removed general flags:"
+ , text $ show $ EnumSet.toList $ gf_removed
+ , text "Added extension flags:"
+ , text $ show $ EnumSet.toList $ ext_added
+ , text "Removed extension flags:"
+ , text $ show $ EnumSet.toList $ ext_removed
+ ]
diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs
index 2c49aea43b..bfab4bd661 100644
--- a/compiler/GHC/HsToCore/Usage.hs
+++ b/compiler/GHC/HsToCore/Usage.hs
@@ -199,7 +199,7 @@ mkPluginUsage hsc_env pluginModule
if useDyn
then libLocs
else
- let dflags' = addWay' WayDyn dflags
+ let dflags' = dflags { targetWays_ = addWay WayDyn (targetWays_ dflags) }
dlibLocs = [ searchPath </> platformHsSOName platform dlibLoc
| searchPath <- searchPaths
, dlibLoc <- packageHsLibs dflags' pkg
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs
index 55c3b0ce2a..308119327c 100644
--- a/compiler/GHC/Iface/Load.hs
+++ b/compiler/GHC/Iface/Load.hs
@@ -6,6 +6,8 @@
{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE LambdaCase #-}
+
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Loading interface files
@@ -103,7 +105,6 @@ import GHC.Data.FastString
import Control.Monad
import Control.Exception
-import Data.IORef
import Data.Map ( toList )
import System.FilePath
import System.Directory
@@ -875,27 +876,35 @@ findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file
Failed err -> return (Failed (badIfaceFile file_path err))
Succeeded iface -> return (Succeeded (iface, file_path))
-- Don't forget to fill in the package name...
+
+ -- Indefinite interfaces are ALWAYS non-dynamic.
+ checkBuildDynamicToo (Succeeded (iface, _filePath))
+ | not (moduleIsDefinite (mi_module iface)) = return ()
+
checkBuildDynamicToo (Succeeded (iface, filePath)) = do
+ let load_dynamic = do
+ dflags <- getDynFlags
+ let dynFilePath = addBootSuffix_maybe hi_boot_file
+ $ replaceExtension filePath (hiSuf dflags)
+ r <- read_file dynFilePath
+ case r of
+ Succeeded (dynIface, _)
+ | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) ->
+ return ()
+ | otherwise ->
+ do traceIf (text "Dynamic hash doesn't match")
+ setDynamicTooFailed dflags
+ Failed err ->
+ do traceIf (text "Failed to load dynamic interface file:" $$ err)
+ setDynamicTooFailed dflags
+
dflags <- getDynFlags
- -- Indefinite interfaces are ALWAYS non-dynamic, and
- -- that's OK.
- let is_definite_iface = moduleIsDefinite (mi_module iface)
- when is_definite_iface $
- whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do
- let ref = canGenerateDynamicToo dflags
- dynFilePath = addBootSuffix_maybe hi_boot_file
- $ replaceExtension filePath (dynHiSuf dflags)
- r <- read_file dynFilePath
- case r of
- Succeeded (dynIface, _)
- | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) ->
- return ()
- | otherwise ->
- do traceIf (text "Dynamic hash doesn't match")
- liftIO $ writeIORef ref False
- Failed err ->
- do traceIf (text "Failed to load dynamic interface file:" $$ err)
- liftIO $ writeIORef ref False
+ dynamicTooState dflags >>= \case
+ DT_Dont -> return ()
+ DT_Failed -> return ()
+ DT_Dyn -> load_dynamic
+ DT_OK -> withDynamicNow load_dynamic
+
checkBuildDynamicToo _ = return ()
-- | Write interface file
diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
index a21b6dac07..752844054d 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ b/compiler/GHC/Iface/Recomp.hs
@@ -1384,7 +1384,12 @@ mkHashFun hsc_env eps name
-- so there's no guarantee everything is loaded.
-- Kind of a heinous hack.
initIfaceLoad hsc_env . withException
- $ loadInterface (text "lookupVers2") mod ImportBySystem
+ $ withoutDynamicNow
+ -- For some unknown reason, we need to reset the
+ -- dynamicNow bit, otherwise only dynamic
+ -- interfaces are looked up and some tests fail
+ -- (e.g. T16219).
+ $ loadInterface (text "lookupVers2") mod ImportBySystem
return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse`
pprPanic "lookupVers1" (ppr mod <+> ppr occ))
diff --git a/compiler/GHC/Linker/Dynamic.hs b/compiler/GHC/Linker/Dynamic.hs
index 745758f3e5..e1e669ed0d 100644
--- a/compiler/GHC/Linker/Dynamic.hs
+++ b/compiler/GHC/Linker/Dynamic.hs
@@ -40,7 +40,7 @@ linkDynLib dflags0 o_files dep_packages
-- with the same RTS flags that we link GHC with.
dflags | OSMinGW32 <- os
, hostWays `hasWay` WayDyn
- = dflags0 { ways = hostWays }
+ = dflags0 { targetWays_ = hostWays }
| otherwise
= dflags0
diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs
index d040fe71e5..28e74aa2d9 100644
--- a/compiler/GHC/Linker/Loader.hs
+++ b/compiler/GHC/Linker/Loader.hs
@@ -956,8 +956,8 @@ dynLoadObjs hsc_env pls@LoaderState{..} objs = do
-- Even if we're e.g. profiling, we still want
-- the vanilla dynamic libraries, so we set the
-- ways / build tag to be just WayDyn.
- ways = Set.singleton WayDyn,
- outputFile = Just soFile
+ targetWays_ = Set.singleton WayDyn,
+ outputFile_ = Just soFile
}
-- link all "loaded packages" so symbols in those can be resolved
-- Note: We are loading packages with local scope, so to see the
diff --git a/compiler/GHC/Platform/Ways.hs b/compiler/GHC/Platform/Ways.hs
index 9d01ffe878..3759df0021 100644
--- a/compiler/GHC/Platform/Ways.hs
+++ b/compiler/GHC/Platform/Ways.hs
@@ -24,6 +24,7 @@ module GHC.Platform.Ways
( Way(..)
, Ways
, hasWay
+ , addWay
, allowed_combination
, wayGeneralFlags
, wayUnsetGeneralFlags
@@ -77,6 +78,10 @@ type Ways = Set Way
hasWay :: Ways -> Way -> Bool
hasWay ws w = Set.member w ws
+-- | Add a way
+addWay :: Way -> Ways -> Ways
+addWay = Set.insert
+
-- | Check if a combination of ways is allowed
allowed_combination :: Ways -> Bool
allowed_combination ways = not disallowed
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index de3c4aeb01..6b66c32ccc 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -28,7 +28,7 @@ module GHC.Tc.Utils.Monad(
whenDOptM, whenGOptM, whenWOptM,
whenXOptM, unlessXOptM,
getGhcMode,
- withDoDynamicToo,
+ withDynamicNow, withoutDynamicNow,
getEpsVar,
getEps,
updateEps, updateEps_,
@@ -546,10 +546,15 @@ unlessXOptM flag thing_inside = do b <- xoptM flag
getGhcMode :: TcRnIf gbl lcl GhcMode
getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
-withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
-withDoDynamicToo =
+withDynamicNow :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+withDynamicNow =
updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) ->
- top { hsc_dflags = dynamicTooMkDynamicDynFlags dflags })
+ top { hsc_dflags = setDynamicNow dflags })
+
+withoutDynamicNow :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+withoutDynamicNow =
+ updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) ->
+ top { hsc_dflags = dflags { dynamicNow = False} })
getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
diff --git a/compiler/GHC/Unit/Module/Status.hs b/compiler/GHC/Unit/Module/Status.hs
index d7fb83e582..539158fdb1 100644
--- a/compiler/GHC/Unit/Module/Status.hs
+++ b/compiler/GHC/Unit/Module/Status.hs
@@ -5,8 +5,6 @@ where
import GHC.Prelude
-import GHC.Driver.Session
-
import GHC.Unit
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModIface
@@ -38,9 +36,4 @@ data HscStatus
-- exists. Pass to `hscMaybeWriteIface` when writing the interface to
-- avoid updating the existing interface when the interface isn't
-- changed.
- , hscs_iface_dflags :: !DynFlags
- -- ^ Generate final iface using this DynFlags.
- -- FIXME (osa): I don't understand why this is necessary, but I spent
- -- almost two days trying to figure this out and I couldn't .. perhaps
- -- someone who understands this code better will remove this later.
}
diff --git a/ghc/Main.hs b/ghc/Main.hs
index 41a2f9340a..b7992b10b8 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -199,7 +199,7 @@ main' postLoadMode dflags0 args flagWarnings = do
let dflags4 = case bcknd of
Interpreter | not (gopt Opt_ExternalInterpreter dflags3) ->
let platform = targetPlatform dflags3
- dflags3a = dflags3 { ways = hostFullWays }
+ dflags3a = dflags3 { targetWays_ = hostFullWays }
dflags3b = foldl gopt_set dflags3a
$ concatMap (wayGeneralFlags platform)
hostFullWays
diff --git a/testsuite/tests/plugins/static-plugins.hs b/testsuite/tests/plugins/static-plugins.hs
index f3433aa0ac..af57614ffe 100644
--- a/testsuite/tests/plugins/static-plugins.hs
+++ b/testsuite/tests/plugins/static-plugins.hs
@@ -67,7 +67,7 @@ main = do
dflags <- getSessionDynFlags
setSessionDynFlags dflags { staticPlugins = the_plugins
- , outputFile = Nothing }
+ , outputFile_ = Nothing }
load LoadAllTargets
View Lorry Controller Status