summaryrefslogtreecommitdiff
path: root/compiler/main
diff options
context:
space:
mode:
authorSylvain Henry <sylvain@haskus.fr>2020-01-17 15:13:04 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-02-12 01:57:27 -0500
commitda7f74797e8c322006eba385c9cbdce346dd1d43 (patch)
tree79a69eed3aa18414caf76b02a5c8dc7c7e6d5f54 /compiler/main
parentf82a2f90ceda5c2bc74088fa7f6a7c8cb9c9756f (diff)
downloadhaskell-da7f74797e8c322006eba385c9cbdce346dd1d43.tar.gz
Module hierarchy: ByteCode and Runtime (cf #13009)
Update haddock submodule
Diffstat (limited to 'compiler/main')
-rw-r--r--compiler/main/DynFlags.hs2
-rw-r--r--compiler/main/DynamicLoading.hs283
-rw-r--r--compiler/main/GHC.hs20
-rw-r--r--compiler/main/GhcMake.hs2
-rw-r--r--compiler/main/HscMain.hs8
-rw-r--r--compiler/main/HscTypes.hs8
-rw-r--r--compiler/main/InteractiveEval.hs1271
-rw-r--r--compiler/main/InteractiveEvalTypes.hs89
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
- }