diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2020-01-17 15:13:04 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-02-12 01:57:27 -0500 |
commit | da7f74797e8c322006eba385c9cbdce346dd1d43 (patch) | |
tree | 79a69eed3aa18414caf76b02a5c8dc7c7e6d5f54 /compiler/main | |
parent | f82a2f90ceda5c2bc74088fa7f6a7c8cb9c9756f (diff) | |
download | haskell-da7f74797e8c322006eba385c9cbdce346dd1d43.tar.gz |
Module hierarchy: ByteCode and Runtime (cf #13009)
Update haddock submodule
Diffstat (limited to 'compiler/main')
-rw-r--r-- | compiler/main/DynFlags.hs | 2 | ||||
-rw-r--r-- | compiler/main/DynamicLoading.hs | 283 | ||||
-rw-r--r-- | compiler/main/GHC.hs | 20 | ||||
-rw-r--r-- | compiler/main/GhcMake.hs | 2 | ||||
-rw-r--r-- | compiler/main/HscMain.hs | 8 | ||||
-rw-r--r-- | compiler/main/HscTypes.hs | 8 | ||||
-rw-r--r-- | compiler/main/InteractiveEval.hs | 1271 | ||||
-rw-r--r-- | compiler/main/InteractiveEvalTypes.hs | 89 |
8 files changed, 20 insertions, 1663 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 1ca0f0bb17..2276559cd6 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1106,7 +1106,7 @@ data DynFlags = DynFlags { -- loaded here is directed by pluginModNames. Arguments are loaded from -- pluginModNameOpts. The purpose of this field is to cache the plugins so -- they don't have to be loaded each time they are needed. See - -- 'DynamicLoading.initializePlugins'. + -- 'GHC.Runtime.Loader.initializePlugins'. staticPlugins :: [StaticPlugin], -- ^ static plugins which do not need dynamic loading. These plugins are -- intended to be added by GHC API users directly to this list. diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs deleted file mode 100644 index a48f0238be..0000000000 --- a/compiler/main/DynamicLoading.hs +++ /dev/null @@ -1,283 +0,0 @@ -{-# LANGUAGE CPP, MagicHash #-} - --- | Dynamically lookup up values from modules and loading them. -module DynamicLoading ( - initializePlugins, - -- * Loading plugins - loadFrontendPlugin, - - -- * Force loading information - forceLoadModuleInterfaces, - forceLoadNameModuleInterface, - forceLoadTyCon, - - -- * Finding names - lookupRdrNameInModuleForPlugins, - - -- * Loading values - getValueSafely, - getHValueSafely, - lessUnsafeCoerce - ) where - -import GhcPrelude -import DynFlags - -import Linker ( linkModule, getHValue ) -import GHCi ( wormhole ) -import SrcLoc ( noSrcSpan ) -import Finder ( findPluginModule, cannotFindModule ) -import TcRnMonad ( initTcInteractive, initIfaceTcRn ) -import GHC.Iface.Load ( loadPluginInterface ) -import RdrName ( RdrName, ImportSpec(..), ImpDeclSpec(..) - , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName - , gre_name, mkRdrQual ) -import OccName ( OccName, mkVarOcc ) -import GHC.Rename.Names ( gresFromAvails ) -import Plugins -import PrelNames ( pluginTyConName, frontendPluginTyConName ) - -import HscTypes -import GHCi.RemoteTypes ( HValue ) -import Type ( Type, eqType, mkTyConTy ) -import TyCoPpr ( pprTyThingCategory ) -import TyCon ( TyCon ) -import Name ( Name, nameModule_maybe ) -import Id ( idType ) -import Module ( Module, ModuleName ) -import Panic -import FastString -import ErrUtils -import Outputable -import Exception -import Hooks - -import Control.Monad ( when, unless ) -import Data.Maybe ( mapMaybe ) -import GHC.Exts ( unsafeCoerce# ) - --- | Loads the plugins specified in the pluginModNames field of the dynamic --- flags. Should be called after command line arguments are parsed, but before --- actual compilation starts. Idempotent operation. Should be re-called if --- pluginModNames or pluginModNameOpts changes. -initializePlugins :: HscEnv -> DynFlags -> IO DynFlags -initializePlugins hsc_env df - | map lpModuleName (cachedPlugins df) - == pluginModNames df -- plugins not changed - && all (\p -> paArguments (lpPlugin p) - == argumentsForPlugin p (pluginModNameOpts df)) - (cachedPlugins df) -- arguments not changed - = return df -- no need to reload plugins - | otherwise - = do loadedPlugins <- loadPlugins (hsc_env { hsc_dflags = df }) - let df' = df { cachedPlugins = loadedPlugins } - df'' <- withPlugins df' runDflagsPlugin df' - return df'' - - where argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst) - runDflagsPlugin p opts dynflags = dynflagsPlugin p opts dynflags - -loadPlugins :: HscEnv -> IO [LoadedPlugin] -loadPlugins hsc_env - = do { unless (null to_load) $ - checkExternalInterpreter hsc_env - ; plugins <- mapM loadPlugin to_load - ; return $ zipWith attachOptions to_load plugins } - where - dflags = hsc_dflags hsc_env - to_load = pluginModNames dflags - - attachOptions mod_nm (plug, mod) = - LoadedPlugin (PluginWithArgs plug (reverse options)) mod - where - options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags - , opt_mod_nm == mod_nm ] - loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName hsc_env - - -loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin -loadFrontendPlugin hsc_env mod_name = do - checkExternalInterpreter hsc_env - fst <$> loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName - hsc_env mod_name - --- #14335 -checkExternalInterpreter :: HscEnv -> IO () -checkExternalInterpreter hsc_env = - when (gopt Opt_ExternalInterpreter dflags) $ - throwCmdLineError $ showSDoc dflags $ - text "Plugins require -fno-external-interpreter" - where - dflags = hsc_dflags hsc_env - -loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface) -loadPlugin' occ_name plugin_name hsc_env mod_name - = do { let plugin_rdr_name = mkRdrQual mod_name occ_name - dflags = hsc_dflags hsc_env - ; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name - plugin_rdr_name - ; case mb_name of { - Nothing -> - throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep - [ text "The module", ppr mod_name - , text "did not export the plugin name" - , ppr plugin_rdr_name ]) ; - Just (name, mod_iface) -> - - do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name - ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon) - ; case mb_plugin of - Nothing -> - throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep - [ text "The value", ppr name - , text "did not have the type" - , ppr pluginTyConName, text "as required"]) - Just plugin -> return (plugin, mod_iface) } } } - - --- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used --- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. -forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO () -forceLoadModuleInterfaces hsc_env doc modules - = (initTcInteractive hsc_env $ - initIfaceTcRn $ - mapM_ (loadPluginInterface doc) modules) - >> return () - --- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used --- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. -forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO () -forceLoadNameModuleInterface hsc_env reason name = do - let name_modules = mapMaybe nameModule_maybe [name] - forceLoadModuleInterfaces hsc_env reason name_modules - --- | Load the 'TyCon' associated with the given name, come hell or high water. Fails if: --- --- * The interface could not be loaded --- * The name is not that of a 'TyCon' --- * The name did not exist in the loaded module -forceLoadTyCon :: HscEnv -> Name -> IO TyCon -forceLoadTyCon hsc_env con_name = do - forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of loadTyConTy") con_name - - mb_con_thing <- lookupTypeHscEnv hsc_env con_name - case mb_con_thing of - Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name - Just (ATyCon tycon) -> return tycon - Just con_thing -> throwCmdLineErrorS dflags $ wrongTyThingError con_name con_thing - where dflags = hsc_dflags hsc_env - --- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety --- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at! --- --- If the value found was not of the correct type, returns @Nothing@. Any other condition results in an exception: --- --- * If we could not load the names module --- * If the thing being loaded is not a value --- * If the Name does not exist in the module --- * If the link failed - -getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a) -getValueSafely hsc_env val_name expected_type = do - mb_hval <- lookupHook getValueSafelyHook getHValueSafely dflags hsc_env val_name expected_type - case mb_hval of - Nothing -> return Nothing - Just hval -> do - value <- lessUnsafeCoerce dflags "getValueSafely" hval - return (Just value) - where - dflags = hsc_dflags hsc_env - -getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue) -getHValueSafely hsc_env val_name expected_type = do - forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name - -- Now look up the names for the value and type constructor in the type environment - mb_val_thing <- lookupTypeHscEnv hsc_env val_name - case mb_val_thing of - Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name - Just (AnId id) -> do - -- Check the value type in the interface against the type recovered from the type constructor - -- before finally casting the value to the type we assume corresponds to that constructor - if expected_type `eqType` idType id - then do - -- Link in the module that contains the value, if it has such a module - case nameModule_maybe val_name of - Just mod -> do linkModule hsc_env mod - return () - Nothing -> return () - -- Find the value that we just linked in and cast it given that we have proved it's type - hval <- getHValue hsc_env val_name >>= wormhole dflags - return (Just hval) - else return Nothing - Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing - where dflags = hsc_dflags hsc_env - --- | Coerce a value as usual, but: --- --- 1) Evaluate it immediately to get a segfault early if the coercion was wrong --- --- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened --- if it /does/ segfault -lessUnsafeCoerce :: DynFlags -> String -> a -> IO b -lessUnsafeCoerce dflags context what = do - debugTraceMsg dflags 3 $ (text "Coercing a value in") <+> (text context) <> - (text "...") - output <- evaluate (unsafeCoerce# what) - debugTraceMsg dflags 3 (text "Successfully evaluated coercion") - return output - - --- | Finds the 'Name' corresponding to the given 'RdrName' in the --- context of the 'ModuleName'. Returns @Nothing@ if no such 'Name' --- could be found. Any other condition results in an exception: --- --- * If the module could not be found --- * If we could not determine the imports of the module --- --- Can only be used for looking up names while loading plugins (and is --- *not* suitable for use within plugins). The interface file is --- loaded very partially: just enough that it can be used, without its --- rules and instances affecting (and being linked from!) the module --- being compiled. This was introduced by 57d6798. --- --- Need the module as well to record information in the interface file -lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName - -> IO (Maybe (Name, ModIface)) -lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do - -- First find the package the module resides in by searching exposed packages and home modules - found_module <- findPluginModule hsc_env mod_name - case found_module of - Found _ mod -> do - -- Find the exports of the module - (_, mb_iface) <- initTcInteractive hsc_env $ - initIfaceTcRn $ - loadPluginInterface doc mod - case mb_iface of - Just iface -> do - -- Try and find the required name in the exports - let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name - , is_qual = False, is_dloc = noSrcSpan } - imp_spec = ImpSpec decl_spec ImpAll - env = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) (mi_exports iface)) - case lookupGRE_RdrName rdr_name env of - [gre] -> return (Just (gre_name gre, iface)) - [] -> return Nothing - _ -> panic "lookupRdrNameInModule" - - Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name] - err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err - where - dflags = hsc_dflags hsc_env - doc = text "contains a name used in an invocation of lookupRdrNameInModule" - -wrongTyThingError :: Name -> TyThing -> SDoc -wrongTyThingError name got_thing = hsep [text "The name", ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing] - -missingTyThingError :: Name -> SDoc -missingTyThingError name = hsep [text "The name", ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")] - -throwCmdLineErrorS :: DynFlags -> SDoc -> IO a -throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags - -throwCmdLineError :: String -> IO a -throwCmdLineError = throwGhcExceptionIO . CmdLineError diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 1510947e7b..49017611ce 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -132,7 +132,7 @@ module GHC ( -- ** Compiling expressions HValue, parseExpr, compileParsedExpr, - InteractiveEval.compileExpr, dynCompileExpr, + GHC.Runtime.Eval.compileExpr, dynCompileExpr, ForeignHValue, compileExprRemote, compileParsedExprRemote, @@ -154,8 +154,8 @@ module GHC ( modInfoModBreaks, ModBreaks(..), BreakIndex, BreakInfo(breakInfo_number, breakInfo_module), - InteractiveEval.back, - InteractiveEval.forward, + GHC.Runtime.Eval.back, + GHC.Runtime.Eval.forward, -- * Abstract syntax elements @@ -295,10 +295,10 @@ module GHC ( import GhcPrelude hiding (init) -import ByteCodeTypes -import InteractiveEval -import InteractiveEvalTypes -import GHCi +import GHC.ByteCode.Types +import GHC.Runtime.Eval +import GHC.Runtime.Eval.Types +import GHC.Runtime.Interpreter import GHCi.RemoteTypes import PprTyThing ( pprFamInst ) @@ -1526,15 +1526,15 @@ getGHCiMonad = fmap (ic_monad . hsc_IC) getSession getHistorySpan :: GhcMonad m => History -> m SrcSpan getHistorySpan h = withSession $ \hsc_env -> - return $ InteractiveEval.getHistorySpan hsc_env h + return $ GHC.Runtime.Eval.getHistorySpan hsc_env h obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term obtainTermFromVal bound force ty a = withSession $ \hsc_env -> - liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a + liftIO $ GHC.Runtime.Eval.obtainTermFromVal hsc_env bound force ty a obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term obtainTermFromId bound force id = withSession $ \hsc_env -> - liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id + liftIO $ GHC.Runtime.Eval.obtainTermFromId hsc_env bound force id -- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 0f1e5cdc4b..2a597a205d 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -35,7 +35,7 @@ module GhcMake( import GhcPrelude -import qualified Linker ( unload ) +import qualified GHC.Runtime.Linker as Linker import DriverPhases import DriverPipeline diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 8ce49e4aab..8e7a9db87a 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -89,10 +89,10 @@ import GhcPrelude import Data.Data hiding (Fixity, TyCon) import Data.Maybe ( fromJust ) import Id -import GHCi ( addSptEntry ) +import GHC.Runtime.Interpreter ( addSptEntry ) import GHCi.RemoteTypes ( ForeignHValue ) -import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) -import Linker +import GHC.CoreToByteCode ( byteCodeGen, coreExprToBCOs ) +import GHC.Runtime.Linker import CoreTidy ( tidyExpr ) import Type ( Type ) import {- Kind parts of -} Type ( Kind ) @@ -147,7 +147,7 @@ import Hooks import TcEnv import PrelNames import Plugins -import DynamicLoading ( initializePlugins ) +import GHC.Runtime.Loader ( initializePlugins ) import DynFlags import ErrUtils diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index b43c41db2a..33f827e2c6 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -155,8 +155,8 @@ module HscTypes ( import GhcPrelude -import ByteCodeTypes -import InteractiveEvalTypes ( Resume ) +import GHC.ByteCode.Types +import GHC.Runtime.Eval.Types ( Resume ) import GHCi.Message ( Pipe ) import GHCi.RemoteTypes import GHC.ForeignSrcLang @@ -190,7 +190,7 @@ import TysWiredIn import Packages hiding ( Version(..) ) import CmdLineParser import DynFlags -import LinkerTypes ( DynLinker, Linkable(..), Unlinked(..), SptEntry(..) ) +import GHC.Runtime.Linker.Types ( DynLinker, Linkable(..), Unlinked(..), SptEntry(..) ) import DriverPhases ( Phase, HscSource(..), hscSourceString , isHsBootOrSig, isHsigFile ) import qualified DriverPhases as Phase @@ -1680,7 +1680,7 @@ data InteractiveContext ic_rn_gbl_env :: GlobalRdrEnv, -- ^ The cached 'GlobalRdrEnv', built by - -- 'InteractiveEval.setContext' and updated regularly + -- 'GHC.Runtime.Eval.setContext' and updated regularly -- It contains everything in scope at the command line, -- including everything in ic_tythings diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs deleted file mode 100644 index badb746718..0000000000 --- a/compiler/main/InteractiveEval.hs +++ /dev/null @@ -1,1271 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, - RecordWildCards, BangPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2005-2007 --- --- Running statements interactively --- --- ----------------------------------------------------------------------------- - -module InteractiveEval ( - Resume(..), History(..), - execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..), resumeExec, - runDecls, runDeclsWithLocation, runParsedDecls, - isStmt, hasImport, isImport, isDecl, - parseImportDecl, SingleStep(..), - abandon, abandonAll, - getResumeContext, - getHistorySpan, - getModBreaks, - getHistoryModule, - back, forward, - setContext, getContext, - availsToGlobalRdrEnv, - getNamesInScope, - getRdrNamesInScope, - moduleIsInterpreted, - getInfo, - exprType, - typeKind, - parseName, - parseInstanceHead, - getInstancesForType, - getDocs, - GetDocsFailure(..), - showModule, - moduleIsBootOrNotObjectLinkable, - parseExpr, compileParsedExpr, - compileExpr, dynCompileExpr, - compileExprRemote, compileParsedExprRemote, - Term(..), obtainTermFromId, obtainTermFromVal, reconstructType - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import InteractiveEvalTypes - -import GHCi -import GHCi.Message -import GHCi.RemoteTypes -import GhcMonad -import HscMain -import GHC.Hs -import HscTypes -import InstEnv -import GHC.Iface.Env ( newInteractiveBinder ) -import FamInstEnv ( FamInst ) -import CoreFVs ( orphNamesOfFamInst ) -import TyCon -import Type hiding( typeKind ) -import GHC.Types.RepType -import TcType -import Constraint -import TcOrigin -import Predicate -import Var -import Id -import Name hiding ( varName ) -import NameSet -import Avail -import RdrName -import VarEnv -import ByteCodeTypes -import Linker -import DynFlags -import Unique -import UniqSupply -import MonadUtils -import Module -import PrelNames ( toDynName, pretendNameIsInScope ) -import TysWiredIn ( isCTupleTyConName ) -import Panic -import Maybes -import ErrUtils -import SrcLoc -import RtClosureInspect -import Outputable -import FastString -import Bag -import Util -import qualified Lexer (P (..), ParseResult(..), unP, mkPState) -import qualified Parser (parseStmt, parseModule, parseDeclaration, parseImport) - -import System.Directory -import Data.Dynamic -import Data.Either -import qualified Data.IntMap as IntMap -import Data.List (find,intercalate) -import Data.Map (Map) -import qualified Data.Map as Map -import StringBuffer (stringToStringBuffer) -import Control.Monad -import GHC.Exts -import Data.Array -import Exception - -import TcRnDriver ( runTcInteractive, tcRnType, loadUnqualIfaces ) -import TcHsSyn ( ZonkFlexi (SkolemiseFlexi) ) - -import TcEnv (tcGetInstEnvs) - -import Inst (instDFunType) -import TcSimplify (solveWanteds) -import TcRnMonad -import TcEvidence -import Data.Bifunctor (second) - -import TcSMonad (runTcS) - --- ----------------------------------------------------------------------------- --- running a statement interactively - -getResumeContext :: GhcMonad m => m [Resume] -getResumeContext = withSession (return . ic_resume . hsc_IC) - -mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History -mkHistory hsc_env hval bi = History hval bi (findEnclosingDecls hsc_env bi) - -getHistoryModule :: History -> Module -getHistoryModule = breakInfo_module . historyBreakInfo - -getHistorySpan :: HscEnv -> History -> SrcSpan -getHistorySpan hsc_env History{..} = - let BreakInfo{..} = historyBreakInfo in - case lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) of - Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number - _ -> panic "getHistorySpan" - -getModBreaks :: HomeModInfo -> ModBreaks -getModBreaks hmi - | Just linkable <- hm_linkable hmi, - [BCOs cbc _] <- linkableUnlinked linkable - = fromMaybe emptyModBreaks (bc_breaks cbc) - | otherwise - = emptyModBreaks -- probably object code - -{- | Finds the enclosing top level function name -} --- ToDo: a better way to do this would be to keep hold of the decl_path computed --- by the coverage pass, which gives the list of lexically-enclosing bindings --- for each tick. -findEnclosingDecls :: HscEnv -> BreakInfo -> [String] -findEnclosingDecls hsc_env (BreakInfo modl ix) = - let hmi = expectJust "findEnclosingDecls" $ - lookupHpt (hsc_HPT hsc_env) (moduleName modl) - mb = getModBreaks hmi - in modBreaks_decls mb ! ix - --- | Update fixity environment in the current interactive context. -updateFixityEnv :: GhcMonad m => FixityEnv -> m () -updateFixityEnv fix_env = do - hsc_env <- getSession - let ic = hsc_IC hsc_env - setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } } - --- ----------------------------------------------------------------------------- --- execStmt - --- | default ExecOptions -execOptions :: ExecOptions -execOptions = ExecOptions - { execSingleStep = RunToCompletion - , execSourceFile = "<interactive>" - , execLineNumber = 1 - , execWrap = EvalThis -- just run the statement, don't wrap it in anything - } - --- | Run a statement in the current interactive context. -execStmt - :: GhcMonad m - => String -- ^ a statement (bind or expression) - -> ExecOptions - -> m ExecResult -execStmt input exec_opts@ExecOptions{..} = do - hsc_env <- getSession - - mb_stmt <- - liftIO $ - runInteractiveHsc hsc_env $ - hscParseStmtWithLocation execSourceFile execLineNumber input - - case mb_stmt of - -- empty statement / comment - Nothing -> return (ExecComplete (Right []) 0) - Just stmt -> execStmt' stmt input exec_opts - --- | Like `execStmt`, but takes a parsed statement as argument. Useful when --- doing preprocessing on the AST before execution, e.g. in GHCi (see --- GHCi.UI.runStmt). -execStmt' :: GhcMonad m => GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult -execStmt' stmt stmt_text ExecOptions{..} = do - hsc_env <- getSession - - -- Turn off -fwarn-unused-local-binds when running a statement, to hide - -- warnings about the implicit bindings we introduce. - -- (This is basically `mkInteractiveHscEnv hsc_env`, except we unset - -- -wwarn-unused-local-binds) - let ic = hsc_IC hsc_env -- use the interactive dflags - idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds - hsc_env' = mkInteractiveHscEnv (hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } }) - - r <- liftIO $ hscParsedStmt hsc_env' stmt - - case r of - Nothing -> - -- empty statement / comment - return (ExecComplete (Right []) 0) - Just (ids, hval, fix_env) -> do - updateFixityEnv fix_env - - status <- - withVirtualCWD $ - liftIO $ - evalStmt hsc_env' (isStep execSingleStep) (execWrap hval) - - let ic = hsc_IC hsc_env - bindings = (ic_tythings ic, ic_rn_gbl_env ic) - - size = ghciHistSize idflags' - - handleRunStatus execSingleStep stmt_text bindings ids - status (emptyHistory size) - -runDecls :: GhcMonad m => String -> m [Name] -runDecls = runDeclsWithLocation "<interactive>" 1 - --- | Run some declarations and return any user-visible names that were brought --- into scope. -runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name] -runDeclsWithLocation source line_num input = do - hsc_env <- getSession - decls <- liftIO (hscParseDeclsWithLocation hsc_env source line_num input) - runParsedDecls decls - --- | Like `runDeclsWithLocation`, but takes parsed declarations as argument. --- Useful when doing preprocessing on the AST before execution, e.g. in GHCi --- (see GHCi.UI.runStmt). -runParsedDecls :: GhcMonad m => [LHsDecl GhcPs] -> m [Name] -runParsedDecls decls = do - hsc_env <- getSession - (tyThings, ic) <- liftIO (hscParsedDecls hsc_env decls) - - setSession $ hsc_env { hsc_IC = ic } - hsc_env <- getSession - hsc_env' <- liftIO $ rttiEnvironment hsc_env - setSession hsc_env' - return $ filter (not . isDerivedOccName . nameOccName) - -- For this filter, see Note [What to show to users] - $ map getName tyThings - -{- Note [What to show to users] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't want to display internally-generated bindings to users. -Things like the coercion axiom for newtypes. These bindings all get -OccNames that users can't write, to avoid the possibility of name -clashes (in linker symbols). That gives a convenient way to suppress -them. The relevant predicate is OccName.isDerivedOccName. -See #11051 for more background and examples. --} - -withVirtualCWD :: GhcMonad m => m a -> m a -withVirtualCWD m = do - hsc_env <- getSession - - -- a virtual CWD is only necessary when we're running interpreted code in - -- the same process as the compiler. - if gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) then m else do - - let ic = hsc_IC hsc_env - let set_cwd = do - dir <- liftIO $ getCurrentDirectory - case ic_cwd ic of - Just dir -> liftIO $ setCurrentDirectory dir - Nothing -> return () - return dir - - reset_cwd orig_dir = do - virt_dir <- liftIO $ getCurrentDirectory - hsc_env <- getSession - let old_IC = hsc_IC hsc_env - setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } } - liftIO $ setCurrentDirectory orig_dir - - gbracket set_cwd reset_cwd $ \_ -> m - -parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs) -parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr - -emptyHistory :: Int -> BoundedList History -emptyHistory size = nilBL size - -handleRunStatus :: GhcMonad m - => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id] - -> EvalStatus_ [ForeignHValue] [HValueRef] - -> BoundedList History - -> m ExecResult - -handleRunStatus step expr bindings final_ids status history - | RunAndLogSteps <- step = tracing - | otherwise = not_tracing - where - tracing - | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt _ccs <- status - , not is_exception - = do - hsc_env <- getSession - let hmi = expectJust "handleRunStatus" $ - lookupHptDirectly (hsc_HPT hsc_env) - (mkUniqueGrimily mod_uniq) - modl = mi_module (hm_iface hmi) - breaks = getModBreaks hmi - - b <- liftIO $ - breakpointStatus hsc_env (modBreaks_flags breaks) ix - if b - then not_tracing - -- This breakpoint is explicitly enabled; we want to stop - -- instead of just logging it. - else do - apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref - let bi = BreakInfo modl ix - !history' = mkHistory hsc_env apStack_fhv bi `consBL` history - -- history is strict, otherwise our BoundedList is pointless. - fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt - status <- liftIO $ GHCi.resumeStmt hsc_env True fhv - handleRunStatus RunAndLogSteps expr bindings final_ids - status history' - | otherwise - = not_tracing - - not_tracing - -- Hit a breakpoint - | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt ccs <- status - = do - hsc_env <- getSession - resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt - apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref - let hmi = expectJust "handleRunStatus" $ - lookupHptDirectly (hsc_HPT hsc_env) - (mkUniqueGrimily mod_uniq) - modl = mi_module (hm_iface hmi) - bp | is_exception = Nothing - | otherwise = Just (BreakInfo modl ix) - (hsc_env1, names, span, decl) <- liftIO $ - bindLocalsAtBreakpoint hsc_env apStack_fhv bp - let - resume = Resume - { resumeStmt = expr, resumeContext = resume_ctxt_fhv - , resumeBindings = bindings, resumeFinalIds = final_ids - , resumeApStack = apStack_fhv - , resumeBreakInfo = bp - , resumeSpan = span, resumeHistory = toListBL history - , resumeDecl = decl - , resumeCCS = ccs - , resumeHistoryIx = 0 } - hsc_env2 = pushResume hsc_env1 resume - - setSession hsc_env2 - return (ExecBreak names bp) - - -- Completed successfully - | EvalComplete allocs (EvalSuccess hvals) <- status - = do hsc_env <- getSession - let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids - final_names = map getName final_ids - dl = hsc_dynLinker hsc_env - liftIO $ Linker.extendLinkEnv dl (zip final_names hvals) - hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic} - setSession hsc_env' - return (ExecComplete (Right final_names) allocs) - - -- Completed with an exception - | EvalComplete alloc (EvalException e) <- status - = return (ExecComplete (Left (fromSerializableException e)) alloc) - -#if __GLASGOW_HASKELL__ <= 810 - | otherwise - = panic "not_tracing" -- actually exhaustive, but GHC can't tell -#endif - - -resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m ExecResult -resumeExec canLogSpan step - = do - hsc_env <- getSession - let ic = hsc_IC hsc_env - resume = ic_resume ic - - case resume of - [] -> liftIO $ - throwGhcExceptionIO (ProgramError "not stopped at a breakpoint") - (r:rs) -> do - -- unbind the temporary locals by restoring the TypeEnv from - -- before the breakpoint, and drop this Resume from the - -- InteractiveContext. - let (resume_tmp_te,resume_rdr_env) = resumeBindings r - ic' = ic { ic_tythings = resume_tmp_te, - ic_rn_gbl_env = resume_rdr_env, - ic_resume = rs } - setSession hsc_env{ hsc_IC = ic' } - - -- remove any bindings created since the breakpoint from the - -- linker's environment - let old_names = map getName resume_tmp_te - new_names = [ n | thing <- ic_tythings ic - , let n = getName thing - , not (n `elem` old_names) ] - dl = hsc_dynLinker hsc_env - liftIO $ Linker.deleteFromLinkEnv dl new_names - - case r of - Resume { resumeStmt = expr, resumeContext = fhv - , resumeBindings = bindings, resumeFinalIds = final_ids - , resumeApStack = apStack, resumeBreakInfo = mb_brkpt - , resumeSpan = span - , resumeHistory = hist } -> do - withVirtualCWD $ do - status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv - let prevHistoryLst = fromListBL 50 hist - hist' = case mb_brkpt of - Nothing -> prevHistoryLst - Just bi - | not $canLogSpan span -> prevHistoryLst - | otherwise -> mkHistory hsc_env apStack bi `consBL` - fromListBL 50 hist - handleRunStatus step expr bindings final_ids status hist' - -back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String) -back n = moveHist (+n) - -forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String) -forward n = moveHist (subtract n) - -moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String) -moveHist fn = do - hsc_env <- getSession - case ic_resume (hsc_IC hsc_env) of - [] -> liftIO $ - throwGhcExceptionIO (ProgramError "not stopped at a breakpoint") - (r:rs) -> do - let ix = resumeHistoryIx r - history = resumeHistory r - new_ix = fn ix - -- - when (history `lengthLessThan` new_ix) $ liftIO $ - throwGhcExceptionIO (ProgramError "no more logged breakpoints") - when (new_ix < 0) $ liftIO $ - throwGhcExceptionIO (ProgramError "already at the beginning of the history") - - let - update_ic apStack mb_info = do - (hsc_env1, names, span, decl) <- - liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info - let ic = hsc_IC hsc_env1 - r' = r { resumeHistoryIx = new_ix } - ic' = ic { ic_resume = r':rs } - - setSession hsc_env1{ hsc_IC = ic' } - - return (names, new_ix, span, decl) - - -- careful: we want apStack to be the AP_STACK itself, not a thunk - -- around it, hence the cases are carefully constructed below to - -- make this the case. ToDo: this is v. fragile, do something better. - if new_ix == 0 - then case r of - Resume { resumeApStack = apStack, - resumeBreakInfo = mb_brkpt } -> - update_ic apStack mb_brkpt - else case history !! (new_ix - 1) of - History{..} -> - update_ic historyApStack (Just historyBreakInfo) - - --- ----------------------------------------------------------------------------- --- After stopping at a breakpoint, add free variables to the environment - -result_fs :: FastString -result_fs = fsLit "_result" - -bindLocalsAtBreakpoint - :: HscEnv - -> ForeignHValue - -> Maybe BreakInfo - -> IO (HscEnv, [Name], SrcSpan, String) - --- Nothing case: we stopped when an exception was raised, not at a --- breakpoint. We have no location information or local variables to --- bind, all we can do is bind a local variable to the exception --- value. -bindLocalsAtBreakpoint hsc_env apStack Nothing = do - let exn_occ = mkVarOccFS (fsLit "_exception") - span = mkGeneralSrcSpan (fsLit "<unknown>") - exn_name <- newInteractiveBinder hsc_env exn_occ span - - let e_fs = fsLit "e" - e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span - e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind - exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar) - - ictxt0 = hsc_IC hsc_env - ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id] - dl = hsc_dynLinker hsc_env - -- - Linker.extendLinkEnv dl [(exn_name, apStack)] - return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>") - --- Just case: we stopped at a breakpoint, we have information about the location --- of the breakpoint and the free variables of the expression. -bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do - let - hmi = expectJust "bindLocalsAtBreakpoint" $ - lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) - breaks = getModBreaks hmi - info = expectJust "bindLocalsAtBreakpoint2" $ - IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks) - mbVars = cgb_vars info - result_ty = cgb_resty info - occs = modBreaks_vars breaks ! breakInfo_number - span = modBreaks_locs breaks ! breakInfo_number - decl = intercalate "." $ modBreaks_decls breaks ! breakInfo_number - - -- Filter out any unboxed ids by changing them to Nothings; - -- we can't bind these at the prompt - mbPointers = nullUnboxed <$> mbVars - - (ids, offsets, occs') = syncOccs mbPointers occs - - free_tvs = tyCoVarsOfTypesList (result_ty:map idType ids) - - -- It might be that getIdValFromApStack fails, because the AP_STACK - -- has been accidentally evaluated, or something else has gone wrong. - -- So that we don't fall over in a heap when this happens, just don't - -- bind any free variables instead, and we emit a warning. - mb_hValues <- - mapM (getBreakpointVar hsc_env apStack_fhv . fromIntegral) offsets - when (any isNothing mb_hValues) $ - debugTraceMsg (hsc_dflags hsc_env) 1 $ - text "Warning: _result has been evaluated, some bindings have been lost" - - us <- mkSplitUniqSupply 'I' -- Dodgy; will give the same uniques every time - let tv_subst = newTyVars us free_tvs - (filtered_ids, occs'') = unzip -- again, sync the occ-names - [ (id, occ) | (id, Just _hv, occ) <- zip3 ids mb_hValues occs' ] - (_,tidy_tys) = tidyOpenTypes emptyTidyEnv $ - map (substTy tv_subst . idType) filtered_ids - - new_ids <- zipWith3M mkNewId occs'' tidy_tys filtered_ids - result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span - - let result_id = Id.mkVanillaGlobal result_name - (substTy tv_subst result_ty) - result_ok = isPointer result_id - - final_ids | result_ok = result_id : new_ids - | otherwise = new_ids - ictxt0 = hsc_IC hsc_env - ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids - names = map idName new_ids - dl = hsc_dynLinker hsc_env - - let fhvs = catMaybes mb_hValues - Linker.extendLinkEnv dl (zip names fhvs) - when result_ok $ Linker.extendLinkEnv dl [(result_name, apStack_fhv)] - hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } - return (hsc_env1, if result_ok then result_name:names else names, span, decl) - where - -- We need a fresh Unique for each Id we bind, because the linker - -- state is single-threaded and otherwise we'd spam old bindings - -- whenever we stop at a breakpoint. The InteractveContext is properly - -- saved/restored, but not the linker state. See #1743, test break026. - mkNewId :: OccName -> Type -> Id -> IO Id - mkNewId occ ty old_id - = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id) - ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) } - - newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst - -- Similarly, clone the type variables mentioned in the types - -- we have here, *and* make them all RuntimeUnk tyvars - newTyVars us tvs - = mkTvSubstPrs [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv))) - | (tv, uniq) <- tvs `zip` uniqsFromSupply us - , let name = setNameUnique (tyVarName tv) uniq ] - - isPointer id | [rep] <- typePrimRep (idType id) - , isGcPtrRep rep = True - | otherwise = False - - -- Convert unboxed Id's to Nothings - nullUnboxed (Just (fv@(id, _))) - | isPointer id = Just fv - | otherwise = Nothing - nullUnboxed Nothing = Nothing - - -- See Note [Syncing breakpoint info] - syncOccs :: [Maybe (a,b)] -> [c] -> ([a], [b], [c]) - syncOccs mbVs ocs = unzip3 $ catMaybes $ joinOccs mbVs ocs - where - joinOccs :: [Maybe (a,b)] -> [c] -> [Maybe (a,b,c)] - joinOccs = zipWith joinOcc - joinOcc mbV oc = (\(a,b) c -> (a,b,c)) <$> mbV <*> pure oc - -rttiEnvironment :: HscEnv -> IO HscEnv -rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do - let tmp_ids = [id | AnId id <- ic_tythings ic] - incompletelyTypedIds = - [id | id <- tmp_ids - , not $ noSkolems id - , (occNameFS.nameOccName.idName) id /= result_fs] - hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds) - return hsc_env' - where - noSkolems = noFreeVarsOfType . idType - improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do - let tmp_ids = [id | AnId id <- ic_tythings ic] - Just id = find (\i -> idName i == name) tmp_ids - if noSkolems id - then return hsc_env - else do - mb_new_ty <- reconstructType hsc_env 10 id - let old_ty = idType id - case mb_new_ty of - Nothing -> return hsc_env - Just new_ty -> do - case improveRTTIType hsc_env old_ty new_ty of - Nothing -> return $ - WARN(True, text (":print failed to calculate the " - ++ "improvement for a type")) hsc_env - Just subst -> do - let dflags = hsc_dflags hsc_env - dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI" - FormatText - (fsep [text "RTTI Improvement for", ppr id, equals, - ppr subst]) - - let ic' = substInteractiveContext ic subst - return hsc_env{hsc_IC=ic'} - -pushResume :: HscEnv -> Resume -> HscEnv -pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 } - where - ictxt0 = hsc_IC hsc_env - ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 } - - - {- - Note [Syncing breakpoint info] - - To display the values of the free variables for a single breakpoint, the - function `compiler/main/InteractiveEval.hs:bindLocalsAtBreakpoint` pulls - out the information from the fields `modBreaks_breakInfo` and - `modBreaks_vars` of the `ModBreaks` data structure. - For a specific breakpoint this gives 2 lists of type `Id` (or `Var`) - and `OccName`. - They are used to create the Id's for the free variables and must be kept - in sync! - - There are 3 situations where items are removed from the Id list - (or replaced with `Nothing`): - 1.) If function `compiler/ghci/ByteCodeGen.hs:schemeER_wrk` (which creates - the Id list) doesn't find an Id in the ByteCode environement. - 2.) If function `compiler/main/InteractiveEval.hs:bindLocalsAtBreakpoint` - filters out unboxed elements from the Id list, because GHCi cannot - yet handle them. - 3.) If the GHCi interpreter doesn't find the reference to a free variable - of our breakpoint. This also happens in the function - bindLocalsAtBreakpoint. - - If an element is removed from the Id list, then the corresponding element - must also be removed from the Occ list. Otherwise GHCi will confuse - variable names as in #8487. - -} - --- ----------------------------------------------------------------------------- --- Abandoning a resume context - -abandon :: GhcMonad m => m Bool -abandon = do - hsc_env <- getSession - let ic = hsc_IC hsc_env - resume = ic_resume ic - case resume of - [] -> return False - r:rs -> do - setSession hsc_env{ hsc_IC = ic { ic_resume = rs } } - liftIO $ abandonStmt hsc_env (resumeContext r) - return True - -abandonAll :: GhcMonad m => m Bool -abandonAll = do - hsc_env <- getSession - let ic = hsc_IC hsc_env - resume = ic_resume ic - case resume of - [] -> return False - rs -> do - setSession hsc_env{ hsc_IC = ic { ic_resume = [] } } - liftIO $ mapM_ (abandonStmt hsc_env. resumeContext) rs - return True - --- ----------------------------------------------------------------------------- --- Bounded list, optimised for repeated cons - -data BoundedList a = BL - {-# UNPACK #-} !Int -- length - {-# UNPACK #-} !Int -- bound - [a] -- left - [a] -- right, list is (left ++ reverse right) - -nilBL :: Int -> BoundedList a -nilBL bound = BL 0 bound [] [] - -consBL :: a -> BoundedList a -> BoundedList a -consBL a (BL len bound left right) - | len < bound = BL (len+1) bound (a:left) right - | null right = BL len bound [a] $! tail (reverse left) - | otherwise = BL len bound (a:left) $! tail right - -toListBL :: BoundedList a -> [a] -toListBL (BL _ _ left right) = left ++ reverse right - -fromListBL :: Int -> [a] -> BoundedList a -fromListBL bound l = BL (length l) bound l [] - --- lenBL (BL len _ _ _) = len - --- ----------------------------------------------------------------------------- --- | Set the interactive evaluation context. --- --- (setContext imports) sets the ic_imports field (which in turn --- determines what is in scope at the prompt) to 'imports', and --- constructs the ic_rn_glb_env environment to reflect it. --- --- We retain in scope all the things defined at the prompt, and kept --- in ic_tythings. (Indeed, they shadow stuff from ic_imports.) - -setContext :: GhcMonad m => [InteractiveImport] -> m () -setContext imports - = do { hsc_env <- getSession - ; let dflags = hsc_dflags hsc_env - ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports - ; case all_env_err of - Left (mod, err) -> - liftIO $ throwGhcExceptionIO (formatError dflags mod err) - Right all_env -> do { - ; let old_ic = hsc_IC hsc_env - !final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic - ; setSession - hsc_env{ hsc_IC = old_ic { ic_imports = imports - , ic_rn_gbl_env = final_rdr_env }}}} - where - formatError dflags mod err = ProgramError . showSDoc dflags $ - text "Cannot add module" <+> ppr mod <+> - text "to context:" <+> text err - -findGlobalRdrEnv :: HscEnv -> [InteractiveImport] - -> IO (Either (ModuleName, String) GlobalRdrEnv) --- Compute the GlobalRdrEnv for the interactive context -findGlobalRdrEnv hsc_env imports - = do { idecls_env <- hscRnImportDecls hsc_env idecls - -- This call also loads any orphan modules - ; return $ case partitionEithers (map mkEnv imods) of - ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env) - (err : _, _) -> Left err } - where - idecls :: [LImportDecl GhcPs] - idecls = [noLoc d | IIDecl d <- imports] - - imods :: [ModuleName] - imods = [m | IIModule m <- imports] - - mkEnv mod = case mkTopLevEnv (hsc_HPT hsc_env) mod of - Left err -> Left (mod, err) - Right env -> Right env - -availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv -availsToGlobalRdrEnv mod_name avails - = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails) - where - -- We're building a GlobalRdrEnv as if the user imported - -- all the specified modules into the global interactive module - imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll} - decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, - is_qual = False, - is_dloc = srcLocSpan interactiveSrcLoc } - -mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv -mkTopLevEnv hpt modl - = case lookupHpt hpt modl of - Nothing -> Left "not a home module" - Just details -> - case mi_globals (hm_iface details) of - Nothing -> Left "not interpreted" - Just env -> Right env - --- | Get the interactive evaluation context, consisting of a pair of the --- set of modules from which we take the full top-level scope, and the set --- of modules from which we take just the exports respectively. -getContext :: GhcMonad m => m [InteractiveImport] -getContext = withSession $ \HscEnv{ hsc_IC=ic } -> - return (ic_imports ic) - --- | Returns @True@ if the specified module is interpreted, and hence has --- its full top-level scope available. -moduleIsInterpreted :: GhcMonad m => Module -> m Bool -moduleIsInterpreted modl = withSession $ \h -> - if moduleUnitId modl /= thisPackage (hsc_dflags h) - then return False - else case lookupHpt (hsc_HPT h) (moduleName modl) of - Just details -> return (isJust (mi_globals (hm_iface details))) - _not_a_home_module -> return False - --- | Looks up an identifier in the current interactive context (for :info) --- Filter the instances by the ones whose tycons (or clases resp) --- are in scope (qualified or otherwise). Otherwise we list a whole lot too many! --- The exact choice of which ones to show, and which to hide, is a judgement call. --- (see #1581) -getInfo :: GhcMonad m => Bool -> Name - -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst], SDoc)) -getInfo allInfo name - = withSession $ \hsc_env -> - do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name - case mb_stuff of - Nothing -> return Nothing - Just (thing, fixity, cls_insts, fam_insts, docs) -> do - let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env) - - -- Filter the instances based on whether the constituent names of their - -- instance heads are all in scope. - let cls_insts' = filter (plausible rdr_env . orphNamesOfClsInst) cls_insts - fam_insts' = filter (plausible rdr_env . orphNamesOfFamInst) fam_insts - return (Just (thing, fixity, cls_insts', fam_insts', docs)) - where - plausible rdr_env names - -- Dfun involving only names that are in ic_rn_glb_env - = allInfo - || nameSetAll ok names - where -- A name is ok if it's in the rdr_env, - -- whether qualified or not - ok n | n == name = True - -- The one we looked for in the first place! - | pretendNameIsInScope n = True - | isBuiltInSyntax n = True - | isCTupleTyConName n = True - | isExternalName n = isJust (lookupGRE_Name rdr_env n) - | otherwise = True - --- | Returns all names in scope in the current interactive context -getNamesInScope :: GhcMonad m => m [Name] -getNamesInScope = withSession $ \hsc_env -> do - return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) - --- | Returns all 'RdrName's in scope in the current interactive --- context, excluding any that are internally-generated. -getRdrNamesInScope :: GhcMonad m => m [RdrName] -getRdrNamesInScope = withSession $ \hsc_env -> do - let - ic = hsc_IC hsc_env - gbl_rdrenv = ic_rn_gbl_env ic - gbl_names = concatMap greRdrNames $ globalRdrEnvElts gbl_rdrenv - -- Exclude internally generated names; see e.g. #11328 - return (filter (not . isDerivedOccName . rdrNameOcc) gbl_names) - - --- | Parses a string as an identifier, and returns the list of 'Name's that --- the identifier can refer to in the current interactive context. -parseName :: GhcMonad m => String -> m [Name] -parseName str = withSession $ \hsc_env -> liftIO $ - do { lrdr_name <- hscParseIdentifier hsc_env str - ; hscTcRnLookupRdrName hsc_env lrdr_name } - --- | Returns @True@ if passed string is a statement. -isStmt :: DynFlags -> String -> Bool -isStmt dflags stmt = - case parseThing Parser.parseStmt dflags stmt of - Lexer.POk _ _ -> True - Lexer.PFailed _ -> False - --- | Returns @True@ if passed string has an import declaration. -hasImport :: DynFlags -> String -> Bool -hasImport dflags stmt = - case parseThing Parser.parseModule dflags stmt of - Lexer.POk _ thing -> hasImports thing - Lexer.PFailed _ -> False - where - hasImports = not . null . hsmodImports . unLoc - --- | Returns @True@ if passed string is an import declaration. -isImport :: DynFlags -> String -> Bool -isImport dflags stmt = - case parseThing Parser.parseImport dflags stmt of - Lexer.POk _ _ -> True - Lexer.PFailed _ -> False - --- | Returns @True@ if passed string is a declaration but __/not a splice/__. -isDecl :: DynFlags -> String -> Bool -isDecl dflags stmt = do - case parseThing Parser.parseDeclaration dflags stmt of - Lexer.POk _ thing -> - case unLoc thing of - SpliceD _ _ -> False - _ -> True - Lexer.PFailed _ -> False - -parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing -parseThing parser dflags stmt = do - let buf = stringToStringBuffer stmt - loc = mkRealSrcLoc (fsLit "<interactive>") 1 1 - - Lexer.unP parser (Lexer.mkPState dflags buf loc) - -getDocs :: GhcMonad m - => Name - -> m (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)) - -- TODO: What about docs for constructors etc.? -getDocs name = - withSession $ \hsc_env -> do - case nameModule_maybe name of - Nothing -> pure (Left (NameHasNoModule name)) - Just mod -> do - if isInteractiveModule mod - then pure (Left InteractiveName) - else do - ModIface { mi_doc_hdr = mb_doc_hdr - , mi_decl_docs = DeclDocMap dmap - , mi_arg_docs = ArgDocMap amap - } <- liftIO $ hscGetModuleInterface hsc_env mod - if isNothing mb_doc_hdr && Map.null dmap && Map.null amap - then pure (Left (NoDocsInIface mod compiled)) - else pure (Right ( Map.lookup name dmap - , Map.findWithDefault Map.empty name amap)) - where - compiled = - -- TODO: Find a more direct indicator. - case nameSrcLoc name of - RealSrcLoc {} -> False - UnhelpfulLoc {} -> True - --- | Failure modes for 'getDocs'. - --- TODO: Find a way to differentiate between modules loaded without '-haddock' --- and modules that contain no docs. -data GetDocsFailure - - -- | 'nameModule_maybe' returned 'Nothing'. - = NameHasNoModule Name - - -- | This is probably because the module was loaded without @-haddock@, - -- but it's also possible that the entire module contains no documentation. - | NoDocsInIface - Module - Bool -- ^ 'True': The module was compiled. - -- 'False': The module was :loaded. - - -- | The 'Name' was defined interactively. - | InteractiveName - -instance Outputable GetDocsFailure where - ppr (NameHasNoModule name) = - quotes (ppr name) <+> text "has no module where we could look for docs." - ppr (NoDocsInIface mod compiled) = vcat - [ text "Can't find any documentation for" <+> ppr mod <> char '.' - , text "This is probably because the module was" - <+> text (if compiled then "compiled" else "loaded") - <+> text "without '-haddock'," - , text "but it's also possible that the module contains no documentation." - , text "" - , if compiled - then text "Try re-compiling with '-haddock'." - else text "Try running ':set -haddock' and :load the file again." - -- TODO: Figure out why :reload doesn't load the docs and maybe fix it. - ] - ppr InteractiveName = - text "Docs are unavailable for interactive declarations." - --- ----------------------------------------------------------------------------- --- Getting the type of an expression - --- | Get the type of an expression --- Returns the type as described by 'TcRnExprMode' -exprType :: GhcMonad m => TcRnExprMode -> String -> m Type -exprType mode expr = withSession $ \hsc_env -> do - ty <- liftIO $ hscTcExpr hsc_env mode expr - return $ tidyType emptyTidyEnv ty - --- ----------------------------------------------------------------------------- --- Getting the kind of a type - --- | Get the kind of a type -typeKind :: GhcMonad m => Bool -> String -> m (Type, Kind) -typeKind normalise str = withSession $ \hsc_env -> do - liftIO $ hscKcType hsc_env normalise str - --- ---------------------------------------------------------------------------- --- Getting the class instances for a type - -{- - Note [Querying instances for a type] - - Here is the implementation of GHC proposal 41. - (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0041-ghci-instances.rst) - - The objective is to take a query string representing a (partial) type, and - report all the class single-parameter class instances available to that type. - Extending this feature to multi-parameter typeclasses is left as future work. - - The general outline of how we solve this is: - - 1. Parse the type, leaving skolems in the place of type-holes. - 2. For every class, get a list of all instances that match with the query type. - 3. For every matching instance, ask GHC for the context the instance dictionary needs. - 4. Format and present the results, substituting our query into the instance - and simplifying the context. - - For example, given the query "Maybe Int", we want to return: - - instance Show (Maybe Int) - instance Read (Maybe Int) - instance Eq (Maybe Int) - .... - - [Holes in queries] - - Often times we want to know what instances are available for a polymorphic type, - like `Maybe a`, and we'd like to return instances such as: - - instance Show a => Show (Maybe a) - .... - - These queries are expressed using type holes, so instead of `Maybe a` the user writes - `Maybe _`, we parse the type and during zonking, we skolemise it, replacing the holes - with (un-named) type variables. - - When zonking the type holes we have two real choices: replace them with Any or replace - them with skolem typevars. Using skolem type variables ensures that the output is more - intuitive to end users, and there is no difference in the results between Any and skolems. - --} - --- Find all instances that match a provided type -getInstancesForType :: GhcMonad m => Type -> m [ClsInst] -getInstancesForType ty = withSession $ \hsc_env -> do - liftIO $ runInteractiveHsc hsc_env $ do - ioMsgMaybe $ runTcInteractive hsc_env $ do - -- Bring class and instances from unqualified modules into scope, this fixes #16793. - loadUnqualIfaces hsc_env (hsc_IC hsc_env) - matches <- findMatchingInstances ty - fmap catMaybes . forM matches $ uncurry checkForExistence - --- Parse a type string and turn any holes into skolems -parseInstanceHead :: GhcMonad m => String -> m Type -parseInstanceHead str = withSession $ \hsc_env0 -> do - (ty, _) <- liftIO $ runInteractiveHsc hsc_env0 $ do - hsc_env <- getHscEnv - ty <- hscParseType str - ioMsgMaybe $ tcRnType hsc_env SkolemiseFlexi True ty - - return ty - --- Get all the constraints required of a dictionary binding -getDictionaryBindings :: PredType -> TcM WantedConstraints -getDictionaryBindings theta = do - dictName <- newName (mkDictOcc (mkVarOcc "magic")) - let dict_var = mkVanillaGlobal dictName theta - loc <- getCtLocM (GivenOrigin UnkSkol) Nothing - let wCs = mkSimpleWC [CtDerived - { ctev_pred = varType dict_var - , ctev_loc = loc - }] - - return wCs - -{- - When we've found an instance that a query matches against, we still need to - check that all the instance's constraints are satisfiable. checkForExistence - creates an instance dictionary and verifies that any unsolved constraints - mention a type-hole, meaning it is blocked on an unknown. - - If the instance satisfies this condition, then we return it with the query - substituted into the instance and all constraints simplified, for example given: - - instance D a => C (MyType a b) where - - and the query `MyType _ String` - - the unsolved constraints will be [D _] so we apply the substitution: - - { a -> _; b -> String} - - and return the instance: - - instance D _ => C (MyType _ String) - --} - -checkForExistence :: ClsInst -> [DFunInstType] -> TcM (Maybe ClsInst) -checkForExistence res mb_inst_tys = do - (tys, thetas) <- instDFunType (is_dfun res) mb_inst_tys - - wanteds <- forM thetas getDictionaryBindings - (residuals, _) <- second evBindMapBinds <$> runTcS (solveWanteds (unionsWC wanteds)) - - let all_residual_constraints = bagToList $ wc_simple residuals - let preds = map ctPred all_residual_constraints - if all isSatisfiablePred preds && (null $ wc_impl residuals) - then return . Just $ substInstArgs tys preds res - else return Nothing - - where - - -- Stricter version of isTyVarClassPred that requires all TyConApps to have at least - -- one argument or for the head to be a TyVar. The reason is that we want to ensure - -- that all residual constraints mention a type-hole somewhere in the constraint, - -- meaning that with the correct choice of a concrete type it could be possible for - -- the constraint to be discharged. - isSatisfiablePred :: PredType -> Bool - isSatisfiablePred ty = case getClassPredTys_maybe ty of - Just (_, tys@(_:_)) -> all isTyVarTy tys - _ -> isTyVarTy ty - - empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType (idType $ is_dfun res))) - - {- Create a ClsInst with instantiated arguments and constraints. - - The thetas are the list of constraints that couldn't be solved because - they mention a type-hole. - -} - substInstArgs :: [Type] -> [PredType] -> ClsInst -> ClsInst - substInstArgs tys thetas inst = let - subst = foldl' (\a b -> uncurry (extendTvSubstAndInScope a) b) empty_subst (zip dfun_tvs tys) - -- Build instance head with arguments substituted in - tau = mkClassPred cls (substTheta subst args) - -- Constrain the instance with any residual constraints - phi = mkPhiTy thetas tau - sigma = mkForAllTys (map (\v -> Bndr v Inferred) dfun_tvs) phi - - in inst { is_dfun = (is_dfun inst) { varType = sigma }} - where - (dfun_tvs, _, cls, args) = instanceSig inst - --- Find instances where the head unifies with the provided type -findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])] -findMatchingInstances ty = do - ies@(InstEnvs {ie_global = ie_global, ie_local = ie_local}) <- tcGetInstEnvs - let allClasses = instEnvClasses ie_global ++ instEnvClasses ie_local - - concat <$> mapM (\cls -> do - let (matches, _, _) = lookupInstEnv True ies cls [ty] - return matches) allClasses - ------------------------------------------------------------------------------ --- Compile an expression, run it, and deliver the result - --- | Parse an expression, the parsed expression can be further processed and --- passed to compileParsedExpr. -parseExpr :: GhcMonad m => String -> m (LHsExpr GhcPs) -parseExpr expr = withSession $ \hsc_env -> do - liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr - --- | Compile an expression, run it, and deliver the resulting HValue. -compileExpr :: GhcMonad m => String -> m HValue -compileExpr expr = do - parsed_expr <- parseExpr expr - compileParsedExpr parsed_expr - --- | Compile an expression, run it, and deliver the resulting HValue. -compileExprRemote :: GhcMonad m => String -> m ForeignHValue -compileExprRemote expr = do - parsed_expr <- parseExpr expr - compileParsedExprRemote parsed_expr - --- | Compile a parsed expression (before renaming), run it, and deliver --- the resulting HValue. -compileParsedExprRemote :: GhcMonad m => LHsExpr GhcPs -> m ForeignHValue -compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do - -- > let _compileParsedExpr = expr - -- Create let stmt from expr to make hscParsedStmt happy. - -- We will ignore the returned [Id], namely [expr_id], and not really - -- create a new binding. - let expr_fs = fsLit "_compileParsedExpr" - expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc - let_stmt = L loc . LetStmt noExtField . L loc . (HsValBinds noExtField) $ - ValBinds noExtField - (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) [] - - pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt - let (hvals_io, fix_env) = case pstmt of - Just ([_id], hvals_io', fix_env') -> (hvals_io', fix_env') - _ -> panic "compileParsedExprRemote" - - updateFixityEnv fix_env - status <- liftIO $ evalStmt hsc_env False (EvalThis hvals_io) - case status of - EvalComplete _ (EvalSuccess [hval]) -> return hval - EvalComplete _ (EvalException e) -> - liftIO $ throwIO (fromSerializableException e) - _ -> panic "compileParsedExpr" - -compileParsedExpr :: GhcMonad m => LHsExpr GhcPs -> m HValue -compileParsedExpr expr = do - fhv <- compileParsedExprRemote expr - dflags <- getDynFlags - liftIO $ wormhole dflags fhv - --- | Compile an expression, run it and return the result as a Dynamic. -dynCompileExpr :: GhcMonad m => String -> m Dynamic -dynCompileExpr expr = do - parsed_expr <- parseExpr expr - -- > Data.Dynamic.toDyn expr - let loc = getLoc parsed_expr - to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L loc $ getRdrName toDynName) - parsed_expr - hval <- compileParsedExpr to_dyn_expr - return (unsafeCoerce# hval :: Dynamic) - ------------------------------------------------------------------------------ --- show a module and it's source/object filenames - -showModule :: GhcMonad m => ModSummary -> m String -showModule mod_summary = - withSession $ \hsc_env -> do - interpreted <- moduleIsBootOrNotObjectLinkable mod_summary - let dflags = hsc_dflags hsc_env - return (showModMsg dflags (hscTarget dflags) interpreted mod_summary) - -moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool -moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env -> - case lookupHpt (hsc_HPT hsc_env) (ms_mod_name mod_summary) of - Nothing -> panic "missing linkable" - Just mod_info -> return $ case hm_linkable mod_info of - Nothing -> True - Just linkable -> not (isObjectLinkable linkable) - ----------------------------------------------------------------------------- --- RTTI primitives - -obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term -obtainTermFromVal hsc_env bound force ty x - | gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) - = throwIO (InstallationError - "this operation requires -fno-external-interpreter") - | otherwise - = cvObtainTerm hsc_env bound force ty (unsafeCoerce# x) - -obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term -obtainTermFromId hsc_env bound force id = do - hv <- Linker.getHValue hsc_env (varName id) - cvObtainTerm hsc_env bound force (idType id) hv - --- Uses RTTI to reconstruct the type of an Id, making it less polymorphic -reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type) -reconstructType hsc_env bound id = do - hv <- Linker.getHValue hsc_env (varName id) - cvReconstructType hsc_env bound (idType id) hv - -mkRuntimeUnkTyVar :: Name -> Kind -> TyVar -mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk diff --git a/compiler/main/InteractiveEvalTypes.hs b/compiler/main/InteractiveEvalTypes.hs deleted file mode 100644 index 3bc043f88b..0000000000 --- a/compiler/main/InteractiveEvalTypes.hs +++ /dev/null @@ -1,89 +0,0 @@ --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2005-2007 --- --- Running statements interactively --- --- ----------------------------------------------------------------------------- - -module InteractiveEvalTypes ( - Resume(..), History(..), ExecResult(..), - SingleStep(..), isStep, ExecOptions(..), - BreakInfo(..) - ) where - -import GhcPrelude - -import GHCi.RemoteTypes -import GHCi.Message (EvalExpr, ResumeContext) -import Id -import Name -import Module -import RdrName -import Type -import SrcLoc -import Exception - -import Data.Word -import GHC.Stack.CCS - -data ExecOptions - = ExecOptions - { execSingleStep :: SingleStep -- ^ stepping mode - , execSourceFile :: String -- ^ filename (for errors) - , execLineNumber :: Int -- ^ line number (for errors) - , execWrap :: ForeignHValue -> EvalExpr ForeignHValue - } - -data SingleStep - = RunToCompletion - | SingleStep - | RunAndLogSteps - -isStep :: SingleStep -> Bool -isStep RunToCompletion = False -isStep _ = True - -data ExecResult - = ExecComplete - { execResult :: Either SomeException [Name] - , execAllocation :: Word64 - } - | ExecBreak - { breakNames :: [Name] - , breakInfo :: Maybe BreakInfo - } - -data BreakInfo = BreakInfo - { breakInfo_module :: Module - , breakInfo_number :: Int - } - -data Resume = Resume - { resumeStmt :: String -- the original statement - , resumeContext :: ForeignRef (ResumeContext [HValueRef]) - , resumeBindings :: ([TyThing], GlobalRdrEnv) - , resumeFinalIds :: [Id] -- [Id] to bind on completion - , resumeApStack :: ForeignHValue -- The object from which we can get - -- value of the free variables. - , resumeBreakInfo :: Maybe BreakInfo - -- the breakpoint we stopped at - -- (module, index) - -- (Nothing <=> exception) - , resumeSpan :: SrcSpan -- just a copy of the SrcSpan - -- from the ModBreaks, - -- otherwise it's a pain to - -- fetch the ModDetails & - -- ModBreaks to get this. - , resumeDecl :: String -- ditto - , resumeCCS :: RemotePtr CostCentreStack - , resumeHistory :: [History] - , resumeHistoryIx :: Int -- 0 <==> at the top of the history - } - -data History - = History { - historyApStack :: ForeignHValue, - historyBreakInfo :: BreakInfo, - historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint - } |