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

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