diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/main/DynFlags.hs | 17 | ||||
| -rw-r--r-- | compiler/main/GHC.hs | 63 | ||||
| -rw-r--r-- | compiler/main/GhcMake.hs | 15 | ||||
| -rw-r--r-- | compiler/main/HscMain.hs | 52 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 11 | ||||
| -rw-r--r-- | compiler/main/InteractiveEval.hs | 17 | ||||
| -rw-r--r-- | compiler/typecheck/TcEnv.lhs | 8 | ||||
| -rw-r--r-- | compiler/typecheck/TcSMonad.lhs | 4 |
8 files changed, 128 insertions, 59 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 93fab1f66e..eeb1dfc280 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -16,6 +16,7 @@ module DynFlags ( DynFlag(..), WarningFlag(..), ExtensionFlag(..), + Language(..), LogAction, FlushOut(..), FlushErr(..), ProfAuto(..), glasgowExtsFlags, @@ -28,6 +29,7 @@ module DynFlags ( xopt, xopt_set, xopt_unset, + lang_set, DynFlags(..), HasDynFlags(..), ContainsDynFlags(..), RtsOptsEnabled(..), @@ -1078,15 +1080,16 @@ xopt_unset dfs f in dfs { extensions = onoffs, extensionFlags = flattenExtensionFlags (language dfs) onoffs } +lang_set :: DynFlags -> Maybe Language -> DynFlags +lang_set dflags lang = + dflags { + language = lang, + extensionFlags = flattenExtensionFlags lang (extensions dflags) + } + -- | Set the Haskell language standard to use 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 - } +setLanguage l = upd (`lang_set` Just l) -- | Some modules have dependencies on others through the DynFlags rather than textual imports dynFlagDependencies :: DynFlags -> [ModuleName] diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index c3206aab11..9e33aae2bb 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -24,8 +24,9 @@ module GHC ( DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt, GhcMode(..), GhcLink(..), defaultObjectTarget, parseDynamicFlags, - getSessionDynFlags, - setSessionDynFlags, + getSessionDynFlags, setSessionDynFlags, + getProgramDynFlags, setProgramDynFlags, + getInteractiveDynFlags, setInteractiveDynFlags, parseStaticFlags, -- * Targets @@ -449,11 +450,33 @@ initGhcMonad mb_top_dir = do -- %* * -- %************************************************************************ --- | Updates the DynFlags in a Session. This also reads --- the package database (unless it has already been read), --- and prepares the compilers knowledge about packages. It --- can be called again to load new packages: just add new --- package flags to (packageFlags dflags). +-- $DynFlags +-- +-- The GHC session maintains two sets of 'DynFlags': +-- +-- * The "interactive" @DynFlags@, which are used for everything +-- related to interactive evaluation, including 'runStmt', +-- 'runDecls', 'exprType', 'lookupName' and so on (everything +-- under \"Interactive evaluation\" in this module). +-- +-- * The "program" @DynFlags@, which are used when loading +-- whole modules with 'load' +-- +-- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the +-- interactive @DynFlags@. +-- +-- 'setProgramDynFlags', 'getProgramDynFlags' work with the +-- program @DynFlags@. +-- +-- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags' +-- retrieves the program @DynFlags@ (for backwards compatibility). + + +-- | Updates both the interactive and program DynFlags in a Session. +-- This also reads the package database (unless it has already been +-- read), and prepares the compilers knowledge about packages. It can +-- be called again to load new packages: just add new package flags to +-- (packageFlags dflags). -- -- Returns a list of new packages that may need to be linked in using -- the dynamic linker (see 'linkPackages') as a result of new package @@ -463,9 +486,33 @@ initGhcMonad mb_top_dir = do setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId] setSessionDynFlags dflags = do (dflags', preload) <- liftIO $ initPackages dflags - modifySession (\h -> h{ hsc_dflags = dflags' }) + modifySession $ \h -> h{ hsc_dflags = dflags' + , hsc_IC = (hsc_IC h){ ic_dflags = dflags' } } + return preload + +-- | Sets the program 'DynFlags'. +setProgramDynFlags :: GhcMonad m => DynFlags -> m [PackageId] +setProgramDynFlags dflags = do + (dflags', preload) <- liftIO $ initPackages dflags + modifySession $ \h -> h{ hsc_dflags = dflags' } return preload +-- | Returns the program 'DynFlags'. +getProgramDynFlags :: GhcMonad m => m DynFlags +getProgramDynFlags = getSessionDynFlags + +-- | Set the 'DynFlags' used to evaluate interactive expressions. +-- Note: this cannot be used for changes to packages. Use +-- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the +-- 'pkgState' into the interactive @DynFlags@. +setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () +setInteractiveDynFlags dflags = do + modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags }} + +-- | Get the 'DynFlags' used to evaluate interactive expressions. +getInteractiveDynFlags :: GhcMonad m => m DynFlags +getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h)) + parseDynamicFlags :: Monad m => DynFlags -> [Located String] diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index a2fb9edf16..545993d62d 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -198,8 +198,7 @@ load2 how_much mod_graph = do -- before we unload anything, make sure we don't leave an old -- interactive context around pointing to dead bindings. Also, -- write the pruned HPT to allow the old HPT to be GC'd. - modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext, - hsc_HPT = pruned_hpt } + modifySession $ \_ -> discardIC $ hsc_env { hsc_HPT = pruned_hpt } liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ text "Stable BCO:" <+> ppr stable_bco) @@ -362,16 +361,20 @@ loadFinish _all_ok Failed -- Empty the interactive context and set the module context to the topmost -- newly loaded module, or the Prelude if none were loaded. loadFinish all_ok Succeeded - = do modifySession $ \hsc_env -> hsc_env{ hsc_IC = emptyInteractiveContext } + = do modifySession discardIC return all_ok -- Forget the current program, but retain the persistent info in HscEnv discardProg :: HscEnv -> HscEnv discardProg hsc_env - = hsc_env { hsc_mod_graph = emptyMG, - hsc_IC = emptyInteractiveContext, - hsc_HPT = emptyHomePackageTable } + = discardIC $ hsc_env { hsc_mod_graph = emptyMG + , hsc_HPT = emptyHomePackageTable } + +-- discard the contents of the InteractiveContext, but keep the DynFlags +discardIC :: HscEnv -> HscEnv +discardIC hsc_env + = hsc_env { hsc_IC = emptyInteractiveContext (ic_dflags (hsc_IC hsc_env)) } intermediateCleanTempFiles :: DynFlags -> [ModSummary] -> HscEnv -> IO () intermediateCleanTempFiles dflags summaries hsc_env diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 1fe9077046..89d4d212c2 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -175,7 +175,7 @@ newHscEnv dflags = do return HscEnv { hsc_dflags = dflags, hsc_targets = [], hsc_mod_graph = [], - hsc_IC = emptyInteractiveContext, + hsc_IC = emptyInteractiveContext dflags, hsc_HPT = emptyHomePackageTable, hsc_EPS = eps_var, hsc_NC = nc_var, @@ -217,6 +217,13 @@ runHsc hsc_env (Hsc hsc) = do printOrThrowWarnings (hsc_dflags hsc_env) w return a +-- A variant of runHsc that switches in the DynFlags from the +-- InteractiveContext before running the Hsc computation. +-- +runInteractiveHsc :: HscEnv -> Hsc a -> IO a +runInteractiveHsc hsc_env = + runHsc (hsc_env { hsc_dflags = ic_dflags (hsc_IC hsc_env) }) + getWarnings :: Hsc WarningMessages getWarnings = Hsc $ \_ w -> return (w, w) @@ -287,31 +294,36 @@ ioMsgMaybe' ioA = do #ifdef GHCI hscTcRnLookupRdrName :: HscEnv -> RdrName -> IO [Name] -hscTcRnLookupRdrName hsc_env rdr_name = - runHsc hsc_env $ ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name +hscTcRnLookupRdrName hsc_env0 rdr_name = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name #endif hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing) -hscTcRcLookupName hsc_env name = - runHsc hsc_env $ ioMsgMaybe' $ tcRnLookupName hsc_env name +hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe' $ tcRnLookupName hsc_env name -- ignore errors: the only error we're likely to get is -- "name not found", and the Maybe in the return type -- is used to indicate that. hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [ClsInst])) -hscTcRnGetInfo hsc_env name = - runHsc hsc_env $ ioMsgMaybe' $ tcRnGetInfo hsc_env name +hscTcRnGetInfo hsc_env0 name = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe' $ tcRnGetInfo hsc_env name #ifdef GHCI hscGetModuleInterface :: HscEnv -> Module -> IO ModIface -hscGetModuleInterface hsc_env mod = - runHsc hsc_env $ ioMsgMaybe $ getModuleInterface hsc_env mod +hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ getModuleInterface hsc_env mod -- ----------------------------------------------------------------------------- -- | Rename some import declarations hscRnImportDecls :: HscEnv -> [LImportDecl RdrName] -> IO GlobalRdrEnv -hscRnImportDecls hsc_env import_decls = - runHsc hsc_env $ ioMsgMaybe $ tcRnImportDecls hsc_env import_decls +hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ tcRnImportDecls hsc_env import_decls #endif -- ----------------------------------------------------------------------------- @@ -1378,7 +1390,9 @@ hscStmtWithLocation :: HscEnv -> String -- ^ The source -> Int -- ^ Starting line -> IO (Maybe ([Id], IO [HValue])) -hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do +hscStmtWithLocation hsc_env0 stmt source linenumber = + runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv maybe_stmt <- hscParseStmtWithLocation source linenumber stmt case maybe_stmt of Nothing -> return Nothing @@ -1418,7 +1432,9 @@ hscDeclsWithLocation :: HscEnv -> String -- ^ The source -> Int -- ^ Starting line -> IO ([TyThing], InteractiveContext) -hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do +hscDeclsWithLocation hsc_env0 str source linenumber = + runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv L _ (HsModule{ hsmodDecls = decls }) <- hscParseThingWithLocation source linenumber parseModule str @@ -1489,7 +1505,7 @@ hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do return (tythings, ictxt) hscImport :: HscEnv -> String -> IO (ImportDecl RdrName) -hscImport hsc_env str = runHsc hsc_env $ do +hscImport hsc_env str = runInteractiveHsc hsc_env $ do (L _ (HsModule{hsmodImports=is})) <- hscParseThing parseModule str case is of @@ -1502,7 +1518,8 @@ hscImport hsc_env str = runHsc hsc_env $ do hscTcExpr :: HscEnv -> String -- ^ The expression -> IO Type -hscTcExpr hsc_env expr = runHsc hsc_env $ do +hscTcExpr hsc_env0 expr = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv maybe_stmt <- hscParseStmt expr case maybe_stmt of Just (L _ (ExprStmt expr _ _ _)) -> @@ -1517,7 +1534,8 @@ hscKcType -> Bool -- ^ Normalise the type -> String -- ^ The type as a string -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind -hscKcType hsc_env normalise str = runHsc hsc_env $ do +hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv ty <- hscParseType str ioMsgMaybe $ tcRnType hsc_env (hsc_IC hsc_env) normalise ty @@ -1535,7 +1553,7 @@ hscParseType = hscParseThing parseType hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName) hscParseIdentifier hsc_env str = - runHsc hsc_env $ hscParseThing parseIdentifier str + runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str hscParseThing :: (Outputable thing) => Lexer.P thing -> String -> Hsc thing hscParseThing = hscParseThingWithLocation "<interactive>" 1 diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index e0eea7dc4b..adc98765cf 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -917,6 +917,10 @@ appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) -- context in which statements are executed in a GHC session. data InteractiveContext = InteractiveContext { + ic_dflags :: DynFlags, + -- ^ The 'DynFlags' used to evaluate interative expressions + -- and statements. + ic_imports :: [InteractiveImport], -- ^ The GHCi context is extended with these imports -- @@ -977,9 +981,10 @@ hscDeclsWithLocation) and save them in ic_sys_vars. -} -- | Constructs an empty InteractiveContext. -emptyInteractiveContext :: InteractiveContext -emptyInteractiveContext - = InteractiveContext { ic_imports = [], +emptyInteractiveContext :: DynFlags -> InteractiveContext +emptyInteractiveContext dflags + = InteractiveContext { ic_dflags = dflags, + ic_imports = [], ic_rn_gbl_env = emptyGlobalRdrEnv, ic_tythings = [], ic_sys_vars = [], diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index b62ec40ec0..8cc94a3ce8 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -195,8 +195,9 @@ runStmtWithLocation source linenumber expr step = -- Turn off -fwarn-unused-bindings when running a statement, to hide -- warnings about the implicit bindings we introduce. - let dflags' = wopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds - hsc_env' = hsc_env{ hsc_dflags = dflags' } + let ic = hsc_IC hsc_env -- use the interactive dflags + idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedBinds + hsc_env' = hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } } -- compile to value (IO [HValue]), don't run r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber @@ -208,8 +209,8 @@ runStmtWithLocation source linenumber expr step = Just (tyThings, hval) -> do status <- withVirtualCWD $ - withBreakAction (isStep step) dflags' breakMVar statusMVar $ do - liftIO $ sandboxIO dflags' statusMVar hval + withBreakAction (isStep step) idflags' breakMVar statusMVar $ do + liftIO $ sandboxIO idflags' statusMVar hval let ic = hsc_IC hsc_env bindings = (ic_tythings ic, ic_rn_gbl_env ic) @@ -229,13 +230,7 @@ runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name] runDeclsWithLocation source linenumber expr = do hsc_env <- getSession - - -- Turn off -fwarn-unused-bindings when running a statement, to hide - -- warnings about the implicit bindings we introduce. - let dflags' = wopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds - hsc_env' = hsc_env{ hsc_dflags = dflags' } - - (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env' expr source linenumber + (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env expr source linenumber setSession $ hsc_env { hsc_IC = ic } hsc_env <- getSession diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 3411d23360..a94663e67b 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -572,15 +572,13 @@ thTopLevelId id = isGlobalId id || isExternalName (idName id) %************************************************************************ \begin{code} -tcGetDefaultTys :: Bool -- True <=> interactive context - -> TcM ([Type], -- Default types +tcGetDefaultTys :: TcM ([Type], -- Default types (Bool, -- True <=> Use overloaded strings Bool)) -- True <=> Use extended defaulting rules -tcGetDefaultTys interactive +tcGetDefaultTys = do { dflags <- getDynFlags ; let ovl_strings = xopt Opt_OverloadedStrings dflags - extended_defaults = interactive - || xopt Opt_ExtendedDefaultRules dflags + extended_defaults = xopt Opt_ExtendedDefaultRules dflags -- See also Trac #1974 flags = (ovl_strings, extended_defaults) diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 77c81e7993..964a3d375e 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -1081,7 +1081,7 @@ warnTcS loc warn_if doc getDefaultInfo :: TcS (SimplContext, [Type], (Bool, Bool)) getDefaultInfo = do { ctxt <- getTcSContext - ; (tys, flags) <- wrapTcS (TcM.tcGetDefaultTys (isInteractive ctxt)) + ; (tys, flags) <- wrapTcS TcM.tcGetDefaultTys ; return (ctxt, tys, flags) } -- Just get some environments needed for instance looking up and matching @@ -1423,4 +1423,4 @@ getCtCoercion ct -- solved, so it is not safe to simply do a mkTcCoVarCo (cc_id ct) -- Instead we use the most accurate type, given by ctPred c where maybe_given = isGiven_maybe (cc_flavor ct) -\end{code}
\ No newline at end of file +\end{code} |