From 1f4bc1f36380776c68431dbc3b5fa41dd6d2182e Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Sat, 24 Jul 2010 21:20:13 +0000 Subject: [PATCH] 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. --- compiler/main/DriverPipeline.hs | 34 ++++++++------- compiler/main/DynFlags.hs | 86 +++++++++++++++++++++++++++++++------- compiler/typecheck/TcRnMonad.lhs | 8 ++-- ghc/InteractiveUI.hs | 45 ++++++++++++++------ ghc/Main.hs | 5 ++- 5 files changed, 132 insertions(+), 46 deletions(-) diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 8e11bf1..a77aa7a 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 3f5c4f1..74ca83f 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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 diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 06f08a3..d9c41c0 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -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}} ) diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 8669f94..1998e86 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -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 '") -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 diff --git a/ghc/Main.hs b/ghc/Main.hs index 519d9cd..b7da083 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -76,8 +76,9 @@ import Data.Maybe -- GHC's command-line interface main :: IO () -main = - GHC.defaultErrorHandler defaultDynFlags $ do +main = do + hSetBuffering stdout NoBuffering + GHC.defaultErrorHandler defaultDynFlags $ do -- 1. extract the -B flag from the args argv0 <- getArgs -- 1.7.10.4