Commit 1f4bc1f3 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Separate language option handling into 2 phases

We now first collect the option instructions (from the commandline,
from pragmas in source files, etc), and then later flatten them into
the list of enabled options. This will enable us to use different
standards (H98, H2010, etc) as a base upon which to apply the
instructions, when we don't know what the base will be when we start
collecting instructions.
parent 27286cf2
......@@ -698,27 +698,30 @@ 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
src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
let dflags0' = flattenLanguageFlags dflags0
src_opts <- liftIO $ getOptionsFromFile dflags0' input_fn
(dflags1, unhandled_flags, warns)
<- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
checkProcessArgsResult unhandled_flags
let dflags1' = flattenLanguageFlags dflags1
if not (dopt Opt_Cpp dflags1) then do
if not (dopt 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
unless (dopt Opt_Pp dflags2) $ handleFlagWarnings dflags2 warns
let dflags2' = flattenLanguageFlags dflags2
unless (dopt Opt_Pp dflags2') $ handleFlagWarnings dflags2' warns
-- the HsPp pass below will emit warnings
checkProcessArgsResult unhandled_flags
......@@ -729,10 +732,11 @@ 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' = flattenLanguageFlags 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,13 +750,14 @@ 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
handleFlagWarnings dflags1 warns
let dflags1' = flattenLanguageFlags dflags1
handleFlagWarnings dflags1' warns
checkProcessArgsResult unhandled_flags
return (Hsc sf, dflags1, maybe_loc, output_fn)
return (Hsc sf, dflags1', maybe_loc, output_fn)
-----------------------------------------------------------------------------
-- Hsc phase
......@@ -900,9 +905,10 @@ 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
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)
dflags' = flattenLanguageFlags 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)
runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc
= do
......
......@@ -14,6 +14,10 @@ module DynFlags (
DOpt(..),
DynFlag(..),
LanguageFlag(..),
flattenLanguageFlags,
ensureFlattenedLanguageFlags,
lopt_set_flattened,
lopt_unset_flattened,
DynFlags(..),
HscTarget(..), isObjectTarget, defaultObjectTarget,
GhcMode(..), isOneShot,
......@@ -473,7 +477,8 @@ data DynFlags = DynFlags {
-- hsc dynamic flags
flags :: [DynFlag],
languageFlags :: [LanguageFlag],
languageFlags :: Either [OnOff LanguageFlag]
[LanguageFlag],
-- | Message output action: use "ErrUtils" instead of this if you can
log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO (),
......@@ -725,16 +730,7 @@ defaultDynFlags =
-- The default -O0 options
++ standardWarnings,
languageFlags = [
Opt_MonoPatBinds, -- Experimentally, I'm making this non-standard
-- behaviour the default, to see if anyone notices
-- SLPJ July 06
Opt_ImplicitPrelude,
Opt_MonomorphismRestriction,
Opt_NPlusKPatterns,
Opt_DatatypeContexts
],
languageFlags = Left [],
log_action = \severity srcSpan style msg ->
case severity of
......@@ -759,6 +755,46 @@ Note [Verbosity levels]
5 | "ghc -v -ddump-all"
-}
data OnOff a = On a
| Off a
flattenLanguageFlags :: DynFlags -> DynFlags
flattenLanguageFlags dflags
= case languageFlags dflags of
Left onoffs ->
dflags {
languageFlags = Right $ flattenLanguageFlags' onoffs
}
Right _ ->
panic "Flattening already-flattened language flags"
ensureFlattenedLanguageFlags :: DynFlags -> DynFlags
ensureFlattenedLanguageFlags dflags
= case languageFlags dflags of
Left onoffs ->
dflags {
languageFlags = Right $ flattenLanguageFlags' onoffs
}
Right _ ->
dflags
-- OnOffs accumulate in reverse order, so we use foldr in order to
-- process them in the right order
flattenLanguageFlags' :: [OnOff LanguageFlag] -> [LanguageFlag]
flattenLanguageFlags' = foldr f defaultLanguageFlags
where f (On f) flags = f : delete f flags
f (Off f) flags = delete f flags
defaultLanguageFlags = [
Opt_MonoPatBinds, -- Experimentally, I'm making this non-standard
-- behaviour the default, to see if anyone notices
-- SLPJ July 06
Opt_ImplicitPrelude,
Opt_MonomorphismRestriction,
Opt_NPlusKPatterns,
Opt_DatatypeContexts
]
-- The DOpt class is a temporary workaround, to avoid having to do
-- a mass-renaming dopt->lopt at the moment
class DOpt a where
......@@ -790,15 +826,37 @@ dopt_unset' dfs f = dfs{ flags = filter (/= f) (flags dfs) }
-- | Test whether a 'LanguageFlag' is set
lopt :: LanguageFlag -> DynFlags -> Bool
lopt f dflags = f `elem` languageFlags dflags
lopt f dflags = case languageFlags dflags of
Left _ -> panic ("Testing for language flag " ++ show f ++ " before flattening")
Right flags -> f `elem` flags
-- | Set a 'LanguageFlag'
lopt_set :: DynFlags -> LanguageFlag -> DynFlags
lopt_set dfs f = dfs{ languageFlags = f : languageFlags dfs }
lopt_set dfs f = case languageFlags dfs of
Left onoffs -> dfs { languageFlags = Left (On f : onoffs) }
Right _ -> panic ("Setting language flag " ++ show f ++ " after flattening")
-- | Set a 'LanguageFlag'
lopt_set_flattened :: DynFlags -> LanguageFlag -> DynFlags
lopt_set_flattened dfs f = case languageFlags dfs of
Left _ ->
panic ("Setting language flag " ++ show f ++ " before flattening, but expected flattened")
Right flags ->
dfs { languageFlags = Right (f : delete f flags) }
-- | Unset a 'LanguageFlag'
lopt_unset :: DynFlags -> LanguageFlag -> DynFlags
lopt_unset dfs f = dfs{ languageFlags = filter (/= f) (languageFlags dfs) }
lopt_unset dfs f = case languageFlags dfs of
Left onoffs -> dfs { languageFlags = Left (Off f : onoffs) }
Right _ -> panic ("Unsetting language flag " ++ show f ++ " after flattening")
-- | Unset a 'LanguageFlag'
lopt_unset_flattened :: DynFlags -> LanguageFlag -> DynFlags
lopt_unset_flattened dfs f = case languageFlags dfs of
Left _ ->
panic ("Unsetting language flag " ++ show f ++ " before flattening, but expected flattened")
Right flags ->
dfs { languageFlags = Right (delete f flags) }
-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order
getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from
......
......@@ -233,11 +233,13 @@ getDOpts = do { env <- getTopEnv; return (hsc_dflags env) }
doptM :: DOpt d => d -> TcRnIf gbl lcl Bool
doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }
setOptM :: DOpt d => d -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
-- XXX setOptM and unsetOptM operate on different types. One should be renamed.
setOptM :: LanguageFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
env { env_top = top { hsc_dflags = dopt_set (hsc_dflags top) flag}} )
env { env_top = top { hsc_dflags = lopt_set_flattened (hsc_dflags top) flag}} )
unsetOptM :: DOpt d => d -> 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 }) ->
env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} )
......
......@@ -657,7 +657,7 @@ runStmt stmt step
-- a file, otherwise the read buffer can't be flushed).
_ <- liftIO $ IO.try $ hFlushAll stdin
#endif
result <- GhciMonad.runStmt stmt step
result <- withFlattenedDynflags $ GhciMonad.runStmt stmt step
afterRunStmt (const True) result
--afterRunStmt :: GHC.RunResult -> GHCi Bool
......@@ -815,7 +815,8 @@ help _ = io (putStr helpText)
info :: String -> InputT GHCi ()
info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
info s = handleSourceError GHC.printExceptionAndWarnings $ do
info s = handleSourceError GHC.printExceptionAndWarnings $
withFlattenedDynflags $ do
{ let names = words s
; dflags <- getDynFlags
; let pefas = dopt Opt_PrintExplicitForalls dflags
......@@ -856,7 +857,8 @@ runMain :: String -> GHCi ()
runMain s = case toArgs s of
Left err -> io (hPutStrLn stderr err)
Right args ->
do dflags <- getDynFlags
withFlattenedDynflags $ do
dflags <- getDynFlags
case mainFunIs dflags of
Nothing -> doWithArgs args "main"
Just f -> doWithArgs args f
......@@ -974,7 +976,8 @@ defineMacro overwrite s = do
let new_expr = '(' : definition ++ ") :: String -> IO String"
-- compile the expression
handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
handleSourceError (\e -> GHC.printExceptionAndWarnings e) $
withFlattenedDynflags $ do
hv <- GHC.compileExpr new_expr
io (writeIORef macros_ref --
(filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
......@@ -1001,7 +1004,8 @@ undefineMacro str = mapM_ undef (words str)
cmdCmd :: String -> GHCi ()
cmdCmd str = do
let expr = '(' : str ++ ") :: IO String"
handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
handleSourceError (\e -> GHC.printExceptionAndWarnings e) $
withFlattenedDynflags $ do
hv <- GHC.compileExpr expr
cmds <- io $ (unsafeCoerce# hv :: IO String)
enqueueCommands (lines cmds)
......@@ -1084,7 +1088,7 @@ afterLoad ok retain_context prev_context = do
loaded_mod_names = map GHC.moduleName loaded_mods
modulesLoadedMsg ok loaded_mod_names
lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
withFlattenedDynflags $ lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
setContextAfterLoad :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> Bool -> [GHC.ModSummary] -> GHCi ()
......@@ -1164,7 +1168,9 @@ modulesLoadedMsg ok mods = do
typeOfExpr :: String -> InputT GHCi ()
typeOfExpr str
= handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
= handleSourceError (\e -> GHC.printExceptionAndWarnings e)
$ withFlattenedDynflags
$ do
ty <- GHC.exprType str
dflags <- getDynFlags
let pefas = dopt Opt_PrintExplicitForalls dflags
......@@ -1172,7 +1178,9 @@ typeOfExpr str
kindOfType :: String -> InputT GHCi ()
kindOfType str
= handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
= handleSourceError (\e -> GHC.printExceptionAndWarnings e)
$ withFlattenedDynflags
$ do
ty <- GHC.typeKind str
printForUser $ text str <+> dcolon <+> ppr ty
......@@ -1182,6 +1190,13 @@ quit _ = return True
shellEscape :: String -> GHCi Bool
shellEscape str = io (system str >> return False)
withFlattenedDynflags :: GHC.GhcMonad m => m a -> m a
withFlattenedDynflags m
= do dflags <- GHC.getSessionDynFlags
gbracket (GHC.setSessionDynFlags (ensureFlattenedLanguageFlags dflags))
(\_ -> GHC.setSessionDynFlags dflags)
(\_ -> m)
-----------------------------------------------------------------------------
-- Browsing a module's contents
......@@ -1210,7 +1225,7 @@ browseCmd bang m =
-- indicate import modules, to aid qualifying unqualified names
-- with sorted, sort items alphabetically
browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
browseModule bang modl exports_only = do
browseModule bang modl exports_only = withFlattenedDynflags $ do
-- :browse! reports qualifiers wrt current context
current_unqual <- GHC.getPrintUnqual
-- Temporarily set the context to the module we're interested in,
......@@ -1323,6 +1338,7 @@ setContext str
playCtxtCmd:: Bool -> CtxtCmd -> GHCi ()
playCtxtCmd fail cmd = do
withFlattenedDynflags $ do
(prev_as,prev_bs) <- GHC.getContext
case cmd of
SetContext as bs -> do
......@@ -1850,7 +1866,7 @@ forceCmd = pprintCommand False True
pprintCommand :: Bool -> Bool -> String -> GHCi ()
pprintCommand bind force str = do
pprintClosureCommand bind force str
withFlattenedDynflags $ pprintClosureCommand bind force str
stepCmd :: String -> GHCi ()
stepCmd [] = doContinue (const True) GHC.SingleStep
......@@ -1981,7 +1997,7 @@ forwardCmd = noArgs $ do
-- handle the "break" command
breakCmd :: String -> GHCi ()
breakCmd argLine = do
breakSwitch $ words argLine
withFlattenedDynflags $ breakSwitch $ words argLine
breakSwitch :: [String] -> GHCi ()
breakSwitch [] = do
......@@ -2114,7 +2130,10 @@ end_bold :: String
end_bold = "\ESC[0m"
listCmd :: String -> InputT GHCi ()
listCmd "" = do
listCmd c = withFlattenedDynflags $ listCmd' c
listCmd' :: String -> InputT GHCi ()
listCmd' "" = do
mb_span <- lift getCurrentBreakSpan
case mb_span of
Nothing ->
......@@ -2133,7 +2152,7 @@ listCmd "" = do
printForUser (text "Unable to list source for" <+>
ppr span
$$ text "Try" <+> doWhat)
listCmd str = list2 (words str)
listCmd' str = list2 (words str)
list2 :: [String] -> InputT GHCi ()
list2 [arg] | all isDigit arg = do
......
......@@ -76,7 +76,8 @@ import Data.Maybe
-- GHC's command-line interface
main :: IO ()
main =
main = do
hSetBuffering stdout NoBuffering
GHC.defaultErrorHandler defaultDynFlags $ do
-- 1. extract the -B flag from the args
argv0 <- getArgs
......
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