Commit 287d8483 authored by Ian Lynagh's avatar Ian Lynagh

Remove the need to explicitly flatten the dynflags

parent 28cb2d6d
......@@ -694,30 +694,27 @@ runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_l
runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
= do let dflags0 = hsc_dflags hsc_env
let dflags0' = flattenExtensionFlags dflags0
src_opts <- liftIO $ getOptionsFromFile dflags0' input_fn
src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
(dflags1, unhandled_flags, warns)
<- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
checkProcessArgsResult unhandled_flags
let dflags1' = flattenExtensionFlags dflags1
if not (xopt Opt_Cpp dflags1') then do
if not (xopt Opt_Cpp dflags1) then do
-- we have to be careful to emit warnings only once.
unless (dopt Opt_Pp dflags1') $ handleFlagWarnings dflags1' warns
unless (dopt Opt_Pp dflags1) $ handleFlagWarnings dflags1 warns
-- no need to preprocess CPP, just pass input file along
-- to the next phase of the pipeline.
return (HsPp sf, dflags1, maybe_loc, input_fn)
else do
output_fn <- liftIO $ get_output_fn dflags1' (HsPp sf) maybe_loc
liftIO $ doCpp dflags1' True{-raw-} False{-no CC opts-} input_fn output_fn
output_fn <- liftIO $ get_output_fn dflags1 (HsPp sf) maybe_loc
liftIO $ doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn
-- re-read the pragmas now that we've preprocessed the file
-- See #2464,#3457
src_opts <- liftIO $ getOptionsFromFile dflags0' output_fn
src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn
(dflags2, unhandled_flags, warns)
<- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
let dflags2' = flattenExtensionFlags dflags2
unless (dopt Opt_Pp dflags2') $ handleFlagWarnings dflags2' warns
unless (dopt Opt_Pp dflags2) $ handleFlagWarnings dflags2 warns
-- the HsPp pass below will emit warnings
checkProcessArgsResult unhandled_flags
......@@ -728,11 +725,10 @@ runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
= do let dflags = hsc_dflags hsc_env
dflags' = flattenExtensionFlags dflags
if not (dopt Opt_Pp dflags) then
-- no need to preprocess, just pass input file along
-- to the next phase of the pipeline.
return (Hsc sf, dflags', maybe_loc, input_fn)
return (Hsc sf, dflags, maybe_loc, input_fn)
else do
let hspp_opts = getOpts dflags opt_F
let orig_fn = basename <.> suff
......@@ -746,14 +742,13 @@ runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
)
-- re-read pragmas now that we've parsed the file (see #3674)
src_opts <- liftIO $ getOptionsFromFile dflags' output_fn
src_opts <- liftIO $ getOptionsFromFile dflags output_fn
(dflags1, unhandled_flags, warns)
<- liftIO $ parseDynamicNoPackageFlags dflags src_opts
let dflags1' = flattenExtensionFlags dflags1
handleFlagWarnings dflags1' warns
handleFlagWarnings dflags1 warns
checkProcessArgsResult unhandled_flags
return (Hsc sf, dflags1', maybe_loc, output_fn)
return (Hsc sf, dflags1, maybe_loc, output_fn)
-----------------------------------------------------------------------------
-- Hsc phase
......@@ -901,14 +896,13 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma
runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
= do
let dflags = hsc_dflags hsc_env
dflags' = flattenExtensionFlags dflags
output_fn <- liftIO $ get_output_fn dflags' Cmm maybe_loc
liftIO $ doCpp dflags' False{-not raw-} True{-include CC opts-} input_fn output_fn
return (Cmm, dflags', maybe_loc, output_fn)
output_fn <- liftIO $ get_output_fn dflags Cmm maybe_loc
liftIO $ doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn
return (Cmm, dflags, maybe_loc, output_fn)
runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc
= do
let dflags = ensureFlattenedExtensionFlags $ hsc_dflags hsc_env
let dflags = hsc_dflags hsc_env
let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags)
let next_phase = hscNextPhase dflags HsSrcFile hsc_lang
output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc
......
......@@ -17,16 +17,12 @@ module DynFlags (
DynFlag(..),
ExtensionFlag(..),
glasgowExtsFlags,
flattenExtensionFlags,
ensureFlattenedExtensionFlags,
dopt,
dopt_set,
dopt_unset,
xopt,
xopt_set,
xopt_unset,
xopt_set_flattened,
xopt_unset_flattened,
DynFlags(..),
RtsOptsEnabled(..),
HscTarget(..), isObjectTarget, defaultObjectTarget,
......@@ -501,9 +497,13 @@ data DynFlags = DynFlags {
-- hsc dynamic flags
flags :: [DynFlag],
-- Don't change this without updating extensionFlags:
language :: Maybe Language,
extensionFlags :: Either [OnOff ExtensionFlag]
[ExtensionFlag],
-- Don't change this without updating extensionFlags:
extensions :: [OnOff ExtensionFlag],
-- extensionFlags should always be equal to
-- flattenExtensionFlags language extensions
extensionFlags :: [ExtensionFlag],
-- | Message output action: use "ErrUtils" instead of this if you can
log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO (),
......@@ -741,7 +741,8 @@ defaultDynFlags =
haddockOptions = Nothing,
flags = defaultFlags,
language = Nothing,
extensionFlags = Left [],
extensions = [],
extensionFlags = flattenExtensionFlags Nothing [],
log_action = \severity srcSpan style msg ->
case severity of
......@@ -770,31 +771,11 @@ Note [Verbosity levels]
data OnOff a = On a
| Off a
flattenExtensionFlags :: DynFlags -> DynFlags
flattenExtensionFlags dflags
= case extensionFlags dflags of
Left onoffs ->
dflags {
extensionFlags = Right $ flattenExtensionFlags' (language dflags) onoffs
}
Right _ ->
panic "Flattening already-flattened extension flags"
ensureFlattenedExtensionFlags :: DynFlags -> DynFlags
ensureFlattenedExtensionFlags dflags
= case extensionFlags dflags of
Left onoffs ->
dflags {
extensionFlags = Right $ flattenExtensionFlags' (language dflags) onoffs
}
Right _ ->
dflags
-- OnOffs accumulate in reverse order, so we use foldr in order to
-- process them in the right order
flattenExtensionFlags' :: Maybe Language -> [OnOff ExtensionFlag]
-> [ExtensionFlag]
flattenExtensionFlags' ml = foldr f defaultExtensionFlags
flattenExtensionFlags :: Maybe Language -> [OnOff ExtensionFlag]
-> [ExtensionFlag]
flattenExtensionFlags ml = foldr f defaultExtensionFlags
where f (On f) flags = f : delete f flags
f (Off f) flags = delete f flags
defaultExtensionFlags = languageExtensions ml
......@@ -837,37 +818,30 @@ dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) }
-- | Test whether a 'ExtensionFlag' is set
xopt :: ExtensionFlag -> DynFlags -> Bool
xopt f dflags = case extensionFlags dflags of
Left _ -> panic ("Testing for extension flag " ++ show f ++ " before flattening")
Right flags -> f `elem` flags
xopt f dflags = f `elem` extensionFlags dflags
-- | Set a 'ExtensionFlag'
xopt_set :: DynFlags -> ExtensionFlag -> DynFlags
xopt_set dfs f = case extensionFlags dfs of
Left onoffs -> dfs { extensionFlags = Left (On f : onoffs) }
Right _ -> panic ("Setting extension flag " ++ show f ++ " after flattening")
-- | Set a 'ExtensionFlag'
xopt_set_flattened :: DynFlags -> ExtensionFlag -> DynFlags
xopt_set_flattened dfs f = case extensionFlags dfs of
Left _ ->
panic ("Setting extension flag " ++ show f ++ " before flattening, but expected flattened")
Right flags ->
dfs { extensionFlags = Right (f : delete f flags) }
xopt_set dfs f
= let onoffs = On f : extensions dfs
in dfs { extensions = onoffs,
extensionFlags = flattenExtensionFlags (language dfs) onoffs }
-- | Unset a 'ExtensionFlag'
xopt_unset :: DynFlags -> ExtensionFlag -> DynFlags
xopt_unset dfs f = case extensionFlags dfs of
Left onoffs -> dfs { extensionFlags = Left (Off f : onoffs) }
Right _ -> panic ("Unsetting extension flag " ++ show f ++ " after flattening")
xopt_unset dfs f
= let onoffs = Off f : extensions dfs
in dfs { extensions = onoffs,
extensionFlags = flattenExtensionFlags (language dfs) onoffs }
-- | Unset a 'ExtensionFlag'
xopt_unset_flattened :: DynFlags -> ExtensionFlag -> DynFlags
xopt_unset_flattened dfs f = case extensionFlags dfs of
Left _ ->
panic ("Unsetting extension flag " ++ show f ++ " before flattening, but expected flattened")
Right flags ->
dfs { extensionFlags = Right (delete f flags) }
setLanguage :: Language -> DynP ()
setLanguage l = upd f
where f dfs = let mLang = Just l
oneoffs = extensions dfs
in dfs {
language = mLang,
extensionFlags = flattenExtensionFlags mLang oneoffs
}
-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order
getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from
......@@ -1871,10 +1845,6 @@ setDynFlag, unSetDynFlag :: DynFlag -> DynP ()
setDynFlag f = upd (\dfs -> dopt_set dfs f)
unSetDynFlag f = upd (\dfs -> dopt_unset dfs f)
--------------------------
setLanguage :: Language -> DynP ()
setLanguage l = upd (\dfs -> dfs { language = Just l })
--------------------------
setExtensionFlag, unSetExtensionFlag :: ExtensionFlag -> DynP ()
setExtensionFlag f = do { upd (\dfs -> xopt_set dfs f)
......
......@@ -253,7 +253,7 @@ doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }
setOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
env { env_top = top { hsc_dflags = xopt_set_flattened (hsc_dflags top) flag}} )
env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} )
unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
......
......@@ -1194,7 +1194,7 @@ shellEscape str = io (system str >> return False)
withFlattenedDynflags :: GHC.GhcMonad m => m a -> m a
withFlattenedDynflags m
= do dflags <- GHC.getSessionDynFlags
gbracket (GHC.setSessionDynFlags (ensureFlattenedExtensionFlags dflags))
gbracket (GHC.setSessionDynFlags dflags)
(\_ -> GHC.setSessionDynFlags dflags)
(\_ -> m)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment