From 287d8483e90fded899601a37b7b5e34229072325 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Sat, 23 Oct 2010 21:04:42 +0000 Subject: [PATCH] Remove the need to explicitly flatten the dynflags --- compiler/main/DriverPipeline.hs | 36 +++++++--------- compiler/main/DynFlags.hs | 86 +++++++++++++------------------------- compiler/typecheck/TcRnMonad.lhs | 2 +- ghc/InteractiveUI.hs | 2 +- 4 files changed, 45 insertions(+), 81 deletions(-) diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index c690e84..1c29c7f 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 96037f4..fa92d57 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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 @@ -1872,10 +1846,6 @@ 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) ; mapM_ setExtensionFlag deps } diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 646abca..097db04 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -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 }) -> diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 11a3c98..7249ef4 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -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) -- 1.7.10.4