diff options
| -rw-r--r-- | compiler/ghci/ByteCodeInstr.lhs | 2 | ||||
| -rw-r--r-- | compiler/ghci/Debugger.hs | 16 | ||||
| -rw-r--r-- | compiler/ghci/GhciMonad.hs | 27 | ||||
| -rw-r--r-- | compiler/ghci/InteractiveUI.hs | 143 | ||||
| -rw-r--r-- | compiler/main/GHC.hs | 530 | ||||
| -rw-r--r-- | compiler/main/HscMain.lhs | 11 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 55 | ||||
| -rw-r--r-- | compiler/main/InteractiveEval.hs | 688 | ||||
| -rw-r--r-- | compiler/main/InteractiveEval.hs-boot | 3 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnDriver.lhs | 24 |
10 files changed, 830 insertions, 669 deletions
diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs index adb47c8ac4..fee17bccb5 100644 --- a/compiler/ghci/ByteCodeInstr.lhs +++ b/compiler/ghci/ByteCodeInstr.lhs @@ -140,7 +140,7 @@ data BCInstr data BreakInfo = BreakInfo { breakInfo_module :: Module - , breakInfo_number :: Int + , breakInfo_number :: {-# UNPACK #-} !Int , breakInfo_vars :: [(Id,Int)] , breakInfo_resty :: Type } diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index f4941d2447..89d658dfea 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -95,17 +95,15 @@ pprintClosureCommand session bindThings force str = do hsc_env <- readIORef ref inScope <- GHC.getBindings cms let ictxt = hsc_IC hsc_env - type_env = ic_type_env ictxt - ids = typeEnvIds type_env + ids = ic_tmp_ids ictxt ids' = map (\id -> id `setIdType` substTy subst (idType id)) ids - type_env'= extendTypeEnvWithIds type_env ids' subst_dom= varEnvKeys$ getTvSubstEnv subst subst_ran= varEnvElts$ getTvSubstEnv subst new_tvs = [ tv | t <- subst_ran, let Just tv = getTyVar_maybe t] ic_tyvars'= (`delVarSetListByKey` subst_dom) . (`extendVarSetList` new_tvs) $ ic_tyvars ictxt - ictxt' = ictxt { ic_type_env = type_env' + ictxt' = ictxt { ic_tmp_ids = ids' , ic_tyvars = ic_tyvars' } writeIORef ref (hsc_env {hsc_IC = ictxt'}) @@ -129,7 +127,7 @@ bindSuspensions cms@(Session ref) t = do hsc_env <- readIORef ref inScope <- GHC.getBindings cms let ictxt = hsc_IC hsc_env - type_env = ic_type_env ictxt + type_env = ic_tmp_ids ictxt prefix = "_t" alreadyUsedNames = map (occNameString . nameOccName . getName) inScope availNames = map ((prefix++) . show) [1..] \\ alreadyUsedNames @@ -140,9 +138,8 @@ bindSuspensions cms@(Session ref) t = do let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo | (name,ty) <- zip names tys'] new_tyvars = tyVarsOfTypes tys' - new_type_env = extendTypeEnvWithIds type_env ids old_tyvars = ic_tyvars ictxt - new_ic = ictxt { ic_type_env = new_type_env, + new_ic = ictxt { ic_tmp_ids = ids ++ ic_tmp_ids ictxt, ic_tyvars = old_tyvars `unionVarSet` new_tyvars } extendLinkEnv (zip names hvals) writeIORef ref (hsc_env {hsc_IC = new_ic }) @@ -199,10 +196,9 @@ printTerm cms@(Session ref) = cPprTerm cPpr bindToFreshName hsc_env ty userName = do name <- newGrimName cms userName let ictxt = hsc_IC hsc_env - type_env = ic_type_env ictxt + tmp_ids = ic_tmp_ids ictxt id = mkGlobalId VanillaGlobal name ty vanillaIdInfo - new_type_env = extendTypeEnv type_env (AnId id) - new_ic = ictxt { ic_type_env = new_type_env } + new_ic = ictxt { ic_tmp_ids = id : tmp_ids } return (hsc_env {hsc_IC = new_ic }, name) -- Create new uniques and give them sequentially numbered names diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs index f7f2014ea2..5086022d05 100644 --- a/compiler/ghci/GhciMonad.hs +++ b/compiler/ghci/GhciMonad.hs @@ -47,7 +47,6 @@ data GHCiState = GHCiState session :: GHC.Session, options :: [GHCiOption], prelude :: GHC.Module, - resume :: [EvalInProgress], breaks :: !ActiveBreakPoints, tickarrays :: ModuleEnv TickArray -- tickarrays caches the TickArray for loaded modules, @@ -69,14 +68,6 @@ data ActiveBreakPoints , breakLocations :: ![(Int, BreakLocation)] -- break location uniquely numbered } --- The context of an evaluation in progress that stopped at a breakpoint -data EvalInProgress - = EvalInProgress - { evalStmt :: String, - evalSpan :: SrcSpan, - evalThreadId :: ThreadId, - evalResumeHandle :: GHC.ResumeHandle } - instance Outputable ActiveBreakPoints where ppr activeBrks = prettyLocations $ breakLocations activeBrks @@ -189,24 +180,6 @@ unsetOption opt io :: IO a -> GHCi a io m = GHCi { unGHCi = \s -> m >>= return } -popResume :: GHCi (Maybe EvalInProgress) -popResume = do - st <- getGHCiState - case (resume st) of - [] -> return Nothing - (x:xs) -> do setGHCiState $ st { resume = xs } ; return (Just x) - -pushResume :: EvalInProgress -> GHCi () -pushResume eval = do - st <- getGHCiState - let oldResume = resume st - setGHCiState $ st { resume = eval : oldResume } - -discardResumeContext :: GHCi () -discardResumeContext = do - st <- getGHCiState - setGHCiState st { resume = [] } - printForUser :: SDoc -> GHCi () printForUser doc = do session <- getSession diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 8f22af887b..fc4f30daf0 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -21,7 +21,7 @@ import Debugger import qualified GHC import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..), Type, Module, ModuleName, TyThing(..), Phase, - BreakIndex, Name, SrcSpan ) + BreakIndex, Name, SrcSpan, Resume ) import DynFlags import Packages import PackageConfig @@ -34,7 +34,6 @@ import Module -- for ModuleEnv import Digraph import BasicTypes hiding (isTopLevel) import Panic hiding (showException) -import FastString ( unpackFS ) import Config import StaticFlags import Linker @@ -269,7 +268,6 @@ interactiveUI session srcs maybe_expr = do session = session, options = [], prelude = prel_mod, - resume = [], breaks = emptyActiveBreakPoints, tickarrays = emptyModuleEnv } @@ -417,7 +415,8 @@ fileLoop hdl show_prompt = do session <- getSession (mod,imports) <- io (GHC.getContext session) st <- getGHCiState - when show_prompt (io (putStr (mkPrompt mod imports (resume st) (prompt st)))) + resumes <- io $ GHC.getResumeContext session + when show_prompt (io (putStr (mkPrompt mod imports resumes (prompt st)))) l <- io (IO.try (hGetLine hdl)) case l of Left e | isEOFError e -> return () @@ -453,7 +452,7 @@ mkPrompt toplevs exports resumes prompt perc_s | eval:rest <- resumes = (if not (null rest) then text "... " else empty) - <> brackets (ppr (evalSpan eval)) <+> modules_prompt + <> brackets (ppr (GHC.resumeSpan eval)) <+> modules_prompt | otherwise = modules_prompt @@ -471,7 +470,8 @@ readlineLoop = do io yield saveSession -- for use by completion st <- getGHCiState - l <- io (readline (mkPrompt mod imports (resume st) (prompt st)) + resumes <- io $ GHC.getResumeContext session + l <- io (readline (mkPrompt mod imports resumes (prompt st)) `finally` setNonBlockingFD 0) -- readline sometimes puts stdin into blocking mode, -- so we need to put it back for the IO library @@ -492,7 +492,7 @@ runCommand c = ghciHandle handler (doCommand c) where doCommand (':' : command) = specialCommand command doCommand stmt - = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms) + = do timeIt $ runStmt stmt return False -- This version is for the GHC command-line option -e. The only difference @@ -506,28 +506,50 @@ runCommandEval c = ghciHandle handleEval (doCommand c) doCommand (':' : command) = specialCommand command doCommand stmt - = do nms <- runStmt stmt - case nms of - Nothing -> io (exitWith (ExitFailure 1)) + = do r <- runStmt stmt + case r of + False -> io (exitWith (ExitFailure 1)) -- failure to run the command causes exit(1) for ghc -e. - _ -> do finishEvalExpr nms - return True + _ -> return True -runStmt :: String -> GHCi (Maybe (Bool,[Name])) +runStmt :: String -> GHCi Bool runStmt stmt - | null (filter (not.isSpace) stmt) = return (Just (False,[])) + | null (filter (not.isSpace) stmt) = return False | otherwise = do st <- getGHCiState session <- getSession result <- io $ withProgName (progname st) $ withArgs (args st) $ GHC.runStmt session stmt - switchOnRunResult stmt result + afterRunStmt result + return False -switchOnRunResult :: String -> GHC.RunResult -> GHCi (Maybe (Bool,[Name])) -switchOnRunResult stmt GHC.RunFailed = return Nothing -switchOnRunResult stmt (GHC.RunException e) = throw e -switchOnRunResult stmt (GHC.RunOk names) = return $ Just (False,names) -switchOnRunResult stmt (GHC.RunBreak threadId names info resume) = do + +afterRunStmt :: GHC.RunResult -> GHCi (Maybe (Bool,[Name])) +afterRunStmt run_result = do + mb_result <- switchOnRunResult run_result + + -- possibly print the type and revert CAFs after evaluating an expression + show_types <- isOptionSet ShowType + session <- getSession + case mb_result of + Nothing -> return () + Just (is_break,names) -> + when (is_break || show_types) $ + mapM_ (showTypeOfName session) names + + flushInterpBuffers + io installSignalHandlers + b <- isOptionSet RevertCAFs + io (when b revertCAFs) + + return mb_result + + +switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name])) +switchOnRunResult GHC.RunFailed = return Nothing +switchOnRunResult (GHC.RunException e) = throw e +switchOnRunResult (GHC.RunOk names) = return $ Just (False,names) +switchOnRunResult (GHC.RunBreak threadId names info) = do session <- getSession Just mod_info <- io $ GHC.getModuleInfo session (GHC.breakInfo_module info) let modBreaks = GHC.modInfoModBreaks mod_info @@ -537,31 +559,12 @@ switchOnRunResult stmt (GHC.RunBreak threadId names info resume) = do let location = ticks ! GHC.breakInfo_number info printForUser $ ptext SLIT("Stopped at") <+> ppr location - pushResume EvalInProgress{ evalStmt = stmt, - evalSpan = location, - evalThreadId = threadId, - evalResumeHandle = resume } - -- run the command set with ":set stop <cmd>" st <- getGHCiState runCommand (stop st) return (Just (True,names)) --- possibly print the type and revert CAFs after evaluating an expression -finishEvalExpr mb_names - = do show_types <- isOptionSet ShowType - session <- getSession - case mb_names of - Nothing -> return () - Just (is_break,names) -> - when (is_break || show_types) $ - mapM_ (showTypeOfName session) names - - flushInterpBuffers - io installSignalHandlers - b <- isOptionSet RevertCAFs - io (when b revertCAFs) showTypeOfName :: Session -> Name -> GHCi () showTypeOfName session n @@ -787,7 +790,6 @@ reloadModule m = do afterLoad ok session = do io (revertCAFs) -- always revert CAFs on load. - discardResumeContext discardTickArrays discardActiveBreakPoints graph <- io (GHC.getModuleGraph session) @@ -1152,12 +1154,14 @@ showBkptTable = do showContext :: GHCi () showContext = do - st <- getGHCiState - printForUser $ vcat (map pp_resume (reverse (resume st))) + session <- getSession + resumes <- io $ GHC.getResumeContext session + printForUser $ vcat (map pp_resume (reverse resumes)) where - pp_resume eval = - ptext SLIT("--> ") <> text (evalStmt eval) - $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (evalSpan eval)) + pp_resume resume = + ptext SLIT("--> ") <> text (GHC.resumeStmt resume) + $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume)) + -- ----------------------------------------------------------------------------- -- Completion @@ -1370,44 +1374,34 @@ pprintCommand bind force str = do session <- getSession io $ pprintClosureCommand session bind force str -foreign import ccall "rts_setStepFlag" setStepFlag :: IO () - stepCmd :: String -> GHCi Bool -stepCmd [] = doContinue setStepFlag +stepCmd [] = doContinue True stepCmd expression = do - io $ setStepFlag runCommand expression continueCmd :: String -> GHCi Bool -continueCmd [] = doContinue $ return () +continueCmd [] = doContinue False continueCmd other = do io $ putStrLn "The continue command accepts no arguments." return False -doContinue :: IO () -> GHCi Bool -doContinue actionBeforeCont = do - resumeAction <- popResume - case resumeAction of - Nothing -> do - io $ putStrLn "There is no computation running." - return False - Just eval -> do - io $ actionBeforeCont - session <- getSession - runResult <- io $ GHC.resume session (evalResumeHandle eval) - names <- switchOnRunResult (evalStmt eval) runResult - finishEvalExpr names - return False +doContinue :: Bool -> GHCi Bool +doContinue step = do + session <- getSession + let resume | step = GHC.stepResume + | otherwise = GHC.resume + runResult <- io $ resume session + afterRunStmt runResult + return False abandonCmd :: String -> GHCi () abandonCmd "" = do - mb_res <- popResume - case mb_res of - Nothing -> do - io $ putStrLn "There is no computation running." - Just eval -> - return () - -- the prompt will change to indicate the new context + s <- getSession + b <- io $ GHC.abandon s -- the prompt will change to indicate the new context + when (not b) $ io $ putStrLn "There is no computation running." + return () +abandonCmd _ = do + io $ putStrLn "The abandon command accepts no arguments." deleteCmd :: String -> GHCi () deleteCmd argLine = do @@ -1572,10 +1566,11 @@ end_bold = BS.pack "\ESC[0m" listCmd :: String -> GHCi () listCmd str = do - st <- getGHCiState - case resume st of + session <- getSession + resumes <- io $ GHC.getResumeContext session + case resumes of [] -> printForUser $ text "not stopped at a breakpoint; nothing to list" - eval:_ -> io $ listAround (evalSpan eval) True + eval:_ -> io $ listAround (GHC.resumeSpan eval) True -- | list a section of a source file around a particular SrcSpan. -- If the highlight flag is True, also highlight the span using diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 2a373d51d5..35e4d9db1c 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -77,18 +77,21 @@ module GHC ( exprType, typeKind, parseName, - RunResult(..), ResumeHandle, - runStmt, - resume, + RunResult(..), + runStmt, stepStmt, -- traceStmt, + resume, stepResume, -- traceResume, + Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan), + getResumeContext, + abandon, abandonAll, showModule, isModuleInterpreted, compileExpr, HValue, dynCompileExpr, lookupName, obtainTerm, obtainTerm1, + modInfoModBreaks, ModBreaks(..), BreakIndex, BreakInfo(breakInfo_number, breakInfo_module), BreakArray, setBreakOn, setBreakOff, getBreak, - modInfoModBreaks, #endif -- * Abstract syntax elements @@ -191,21 +194,13 @@ module GHC ( #include "HsVersions.h" #ifdef GHCI -import RtClosureInspect ( cvObtainTerm, Term ) -import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo, - tcRnLookupName, getModuleExports ) -import GHC.Exts ( unsafeCoerce#, Ptr ) -import Foreign.StablePtr( deRefStablePtr, StablePtr, newStablePtr, freeStablePtr ) -import Foreign ( poke ) import qualified Linker import Linker ( HValue ) - -import Data.Dynamic ( Dynamic ) - import ByteCodeInstr -import IdInfo -import HscMain ( hscParseIdentifier, hscTcExpr, hscKcType, hscStmt ) import BreakArray +import NameSet +import TcRnDriver +import InteractiveEval #endif import Packages @@ -216,8 +211,6 @@ import Type hiding (typeKind) import TcType hiding (typeKind) import Id import Var hiding (setIdType) -import VarEnv -import VarSet import TysPrim ( alphaTyVars ) import TyCon import Class @@ -225,7 +218,6 @@ import FunDeps import DataCon import Name hiding ( varName ) import OccName ( parenSymOcc ) -import NameEnv import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr ) import SrcLoc import DriverPipeline @@ -255,10 +247,7 @@ import BasicTypes import Maybes ( expectJust, mapCatMaybes ) import HaddockParse import HaddockLex ( tokenise ) -import Unique -import System.IO.Unsafe -import Data.Array import Control.Concurrent import System.Directory ( getModificationTime, doesFileExist ) import Data.Maybe @@ -354,12 +343,6 @@ newSession mb_top_dir = do sessionHscEnv :: Session -> IO HscEnv sessionHscEnv (Session ref) = readIORef ref -withSession :: Session -> (HscEnv -> IO a) -> IO a -withSession (Session ref) f = do h <- readIORef ref; f h - -modifySession :: Session -> (HscEnv -> HscEnv) -> IO () -modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h - -- ----------------------------------------------------------------------------- -- Flags & settings @@ -1342,9 +1325,6 @@ mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries] nodeMapElts :: NodeMap a -> [a] nodeMapElts = eltsFM -ms_mod_name :: ModSummary -> ModuleName -ms_mod_name = moduleName . ms_mod - -- If there are {-# SOURCE #-} imports between strongly connected -- components in the topological sort, then those imports can -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE @@ -1764,7 +1744,14 @@ isLoaded s m = withSession s $ \hsc_env -> return $! isJust (lookupUFM (hsc_HPT hsc_env) m) getBindings :: Session -> IO [TyThing] -getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC) +getBindings s = withSession s $ \hsc_env -> + -- we have to implement the shadowing behaviour of ic_tmp_ids here + -- (see InteractiveContext) and the quickest way is to use an OccEnv. + let + tmp_ids = reverse (ic_tmp_ids (hsc_IC hsc_env)) + env = mkOccEnv [ (nameOccName (idName id), id) | id <- tmp_ids ] + in + return (map AnId (occEnvElts env)) getPrintUnqual :: Session -> IO PrintUnqualified getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC) @@ -1947,484 +1934,3 @@ findModule' hsc_env mod_name maybe_pkg = text "is not loaded")) err -> let msg = cannotFindModule dflags mod_name err in throwDyn (CmdLineError (showSDoc msg)) - -#ifdef GHCI - --- | Set the interactive evaluation context. --- --- Setting the context doesn't throw away any bindings; the bindings --- we've built up in the InteractiveContext simply move to the new --- module. They always shadow anything in scope in the current context. -setContext :: Session - -> [Module] -- entire top level scope of these modules - -> [Module] -- exports only of these modules - -> IO () -setContext sess@(Session ref) toplev_mods export_mods = do - hsc_env <- readIORef ref - let old_ic = hsc_IC hsc_env - hpt = hsc_HPT hsc_env - -- - export_env <- mkExportEnv hsc_env export_mods - toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods - let all_env = foldr plusGlobalRdrEnv export_env toplev_envs - writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods, - ic_exports = export_mods, - ic_rn_gbl_env = all_env }} - --- Make a GlobalRdrEnv based on the exports of the modules only. -mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv -mkExportEnv hsc_env mods = do - stuff <- mapM (getModuleExports hsc_env) mods - let - (_msgs, mb_name_sets) = unzip stuff - gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod) - | (Just avails, mod) <- zip mb_name_sets mods ] - -- - return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres - -nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv -nameSetToGlobalRdrEnv names mod = - mkGlobalRdrEnv [ GRE { gre_name = name, gre_prov = vanillaProv mod } - | name <- nameSetToList names ] - -vanillaProv :: ModuleName -> Provenance --- We're building a GlobalRdrEnv as if the user imported --- all the specified modules into the global interactive module -vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] - where - decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, - is_qual = False, - is_dloc = srcLocSpan interactiveSrcLoc } - -mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv -mkTopLevEnv hpt modl - = case lookupUFM hpt (moduleName modl) of - Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++ - showSDoc (ppr modl))) - Just details -> - case mi_globals (hm_iface details) of - Nothing -> - throwDyn (ProgramError ("mkTopLevEnv: not interpreted " - ++ showSDoc (ppr modl))) - Just env -> return 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 :: Session -> IO ([Module],[Module]) -getContext s = withSession s (\HscEnv{ hsc_IC=ic } -> - return (ic_toplev_scope ic, ic_exports ic)) - --- | Returns 'True' if the specified module is interpreted, and hence has --- its full top-level scope available. -moduleIsInterpreted :: Session -> Module -> IO Bool -moduleIsInterpreted s modl = withSession s $ \h -> - if modulePackageId modl /= thisPackage (hsc_dflags h) - then return False - else case lookupUFM (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) -getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance])) -getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name - --- | Returns all names in scope in the current interactive context -getNamesInScope :: Session -> IO [Name] -getNamesInScope s = withSession s $ \hsc_env -> do - return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) - -getRdrNamesInScope :: Session -> IO [RdrName] -getRdrNamesInScope s = withSession s $ \hsc_env -> do - let - ic = hsc_IC hsc_env - gbl_rdrenv = ic_rn_gbl_env ic - ids = typeEnvIds (ic_type_env ic) - gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv)) - lcl_names = map (mkRdrUnqual.nameOccName.idName) ids - -- - return (gbl_names ++ lcl_names) - - --- ToDo: move to RdrName -greToRdrNames :: GlobalRdrElt -> [RdrName] -greToRdrNames GRE{ gre_name = name, gre_prov = prov } - = case prov of - LocalDef -> [unqual] - Imported specs -> concat (map do_spec (map is_decl specs)) - where - occ = nameOccName name - unqual = Unqual occ - do_spec decl_spec - | is_qual decl_spec = [qual] - | otherwise = [unqual,qual] - where qual = Qual (is_as decl_spec) occ - --- | 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 :: Session -> String -> IO [Name] -parseName s str = withSession s $ \hsc_env -> do - maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str - case maybe_rdr_name of - Nothing -> return [] - Just (L _ rdr_name) -> do - mb_names <- tcRnLookupRdrName hsc_env rdr_name - case mb_names of - Nothing -> return [] - Just ns -> return ns - -- ToDo: should return error messages - --- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any --- entity known to GHC, including 'Name's defined using 'runStmt'. -lookupName :: Session -> Name -> IO (Maybe TyThing) -lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name - --- ----------------------------------------------------------------------------- --- Getting the type of an expression - --- | Get the type of an expression -exprType :: Session -> String -> IO (Maybe Type) -exprType s expr = withSession s $ \hsc_env -> do - maybe_stuff <- hscTcExpr hsc_env expr - case maybe_stuff of - Nothing -> return Nothing - Just ty -> return (Just tidy_ty) - where - tidy_ty = tidyType emptyTidyEnv ty - --- ----------------------------------------------------------------------------- --- Getting the kind of a type - --- | Get the kind of a type -typeKind :: Session -> String -> IO (Maybe Kind) -typeKind s str = withSession s $ \hsc_env -> do - maybe_stuff <- hscKcType hsc_env str - case maybe_stuff of - Nothing -> return Nothing - Just kind -> return (Just kind) - ------------------------------------------------------------------------------ --- cmCompileExpr: compile an expression and deliver an HValue - -compileExpr :: Session -> String -> IO (Maybe HValue) -compileExpr s expr = withSession s $ \hsc_env -> do - maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr) - case maybe_stuff of - Nothing -> return Nothing - Just (new_ic, names, hval) -> do - -- Run it! - hvals <- (unsafeCoerce# hval) :: IO [HValue] - - case (names,hvals) of - ([n],[hv]) -> return (Just hv) - _ -> panic "compileExpr" - --- ----------------------------------------------------------------------------- --- Compile an expression into a dynamic - -dynCompileExpr :: Session -> String -> IO (Maybe Dynamic) -dynCompileExpr ses expr = do - (full,exports) <- getContext ses - setContext ses full $ - (mkModule - (stringToPackageId "base") (mkModuleName "Data.Dynamic") - ):exports - let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")" - res <- withSession ses (flip hscStmt stmt) - setContext ses full exports - case res of - Nothing -> return Nothing - Just (_, names, hvals) -> do - vals <- (unsafeCoerce# hvals :: IO [Dynamic]) - case (names,vals) of - (_:[], v:[]) -> return (Just v) - _ -> panic "dynCompileExpr" - --- ----------------------------------------------------------------------------- --- running a statement interactively - -data RunResult - = RunOk [Name] -- ^ names bound by this evaluation - | RunFailed -- ^ statement failed compilation - | RunException Exception -- ^ statement raised an exception - | RunBreak ThreadId [Name] BreakInfo ResumeHandle - -data Status - = Break HValue BreakInfo ThreadId - -- ^ the computation hit a breakpoint - | Complete (Either Exception [HValue]) - -- ^ the computation completed with either an exception or a value - --- | This is a token given back to the client when runStmt stops at a --- breakpoint. It allows the original computation to be resumed, restoring --- the old interactive context. -data ResumeHandle - = ResumeHandle - ThreadId -- thread running the computation - (MVar ()) -- breakMVar - (MVar Status) -- statusMVar - [Name] -- [Name] to bind on completion - InteractiveContext -- IC on completion - InteractiveContext -- IC to restore on resumption - [Name] -- [Name] to remove from the link env - --- We need to track two InteractiveContexts: --- - the IC before runStmt, which is restored on each resume --- - the IC binding the results of the original statement, which --- will be the IC when runStmt returns with RunOk. - --- | Run a statement in the current interactive context. Statement --- may bind multple values. -runStmt :: Session -> String -> IO RunResult -runStmt (Session ref) expr - = do - hsc_env <- readIORef ref - - breakMVar <- newEmptyMVar -- wait on this when we hit a breakpoint - statusMVar <- newEmptyMVar -- wait on this when a computation is running - - -- Turn off -fwarn-unused-bindings when running a statement, to hide - -- warnings about the implicit bindings we introduce. - let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds - hsc_env' = hsc_env{ hsc_dflags = dflags' } - - maybe_stuff <- hscStmt hsc_env' expr - - case maybe_stuff of - Nothing -> return RunFailed - Just (new_IC, names, hval) -> do - - -- set the onBreakAction to be performed when we hit a - -- breakpoint this is visible in the Byte Code - -- Interpreter, thus it is a global variable, - -- implemented with stable pointers - withBreakAction breakMVar statusMVar $ do - - let thing_to_run = unsafeCoerce# hval :: IO [HValue] - status <- sandboxIO statusMVar thing_to_run - handleRunStatus ref new_IC names (hsc_IC hsc_env) - breakMVar statusMVar status - -handleRunStatus ref final_ic final_names resume_ic breakMVar statusMVar status = - case status of - -- did we hit a breakpoint or did we complete? - (Break apStack info tid) -> do - hsc_env <- readIORef ref - mod_info <- getHomeModuleInfo hsc_env (moduleName (breakInfo_module info)) - let breaks = minf_modBreaks (expectJust "handlRunStatus" mod_info) - let index = breakInfo_number info - occs = modBreaks_vars breaks ! index - span = modBreaks_locs breaks ! index - (new_hsc_env, names) <- extendEnvironment hsc_env apStack span - (breakInfo_vars info) - (breakInfo_resty info) occs - writeIORef ref new_hsc_env - let res = ResumeHandle breakMVar statusMVar final_names - final_ic resume_ic names - return (RunBreak tid names info res) - (Complete either_hvals) -> - case either_hvals of - Left e -> return (RunException e) - Right hvals -> do - hsc_env <- readIORef ref - writeIORef ref hsc_env{hsc_IC=final_ic} - Linker.extendLinkEnv (zip final_names hvals) - return (RunOk final_names) - --- this points to the IO action that is executed when a breakpoint is hit -foreign import ccall "&breakPointIOAction" - breakPointIOAction :: Ptr (StablePtr (BreakInfo -> HValue -> IO ())) - --- When running a computation, we redirect ^C exceptions to the running --- thread. ToDo: we might want a way to continue even if the target --- thread doesn't die when it receives the exception... "this thread --- is not responding". -sandboxIO :: MVar Status -> IO [HValue] -> IO Status -sandboxIO statusMVar thing = do - ts <- takeMVar interruptTargetThread - child <- forkIO (do res <- Exception.try thing; putMVar statusMVar (Complete res)) - putMVar interruptTargetThread (child:ts) - takeMVar statusMVar `finally` modifyMVar_ interruptTargetThread (return.tail) - -withBreakAction breakMVar statusMVar io - = bracket setBreakAction resetBreakAction (\_ -> io) - where - setBreakAction = do - stablePtr <- newStablePtr onBreak - poke breakPointIOAction stablePtr - return stablePtr - - onBreak info apStack = do - tid <- myThreadId - putMVar statusMVar (Break apStack info tid) - takeMVar breakMVar - - resetBreakAction stablePtr = do - poke breakPointIOAction noBreakStablePtr - freeStablePtr stablePtr - -noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction -noBreakAction info apStack = putStrLn "*** Ignoring breakpoint" - -resume :: Session -> ResumeHandle -> IO RunResult -resume (Session ref) res@(ResumeHandle breakMVar statusMVar - final_names final_ic resume_ic names) - = do - -- restore the original interactive context. This is not entirely - -- satisfactory: any new bindings made since the breakpoint stopped - -- will be dropped from the interactive context, but not from the - -- linker's environment. - hsc_env <- readIORef ref - writeIORef ref hsc_env{ hsc_IC = resume_ic } - Linker.deleteFromLinkEnv names - - withBreakAction breakMVar statusMVar $ do - putMVar breakMVar () -- this awakens the stopped thread... - status <- takeMVar statusMVar -- and wait for the result - handleRunStatus ref final_ic final_names resume_ic - breakMVar statusMVar status - -{- --- This version of sandboxIO runs the expression in a completely new --- RTS main thread. It is disabled for now because ^C exceptions --- won't be delivered to the new thread, instead they'll be delivered --- to the (blocked) GHCi main thread. - --- SLPJ: when re-enabling this, reflect a wrong-stat error as an exception - -sandboxIO :: IO a -> IO (Either Int (Either Exception a)) -sandboxIO thing = do - st_thing <- newStablePtr (Exception.try thing) - alloca $ \ p_st_result -> do - stat <- rts_evalStableIO st_thing p_st_result - freeStablePtr st_thing - if stat == 1 - then do st_result <- peek p_st_result - result <- deRefStablePtr st_result - freeStablePtr st_result - return (Right result) - else do - return (Left (fromIntegral stat)) - -foreign import "rts_evalStableIO" {- safe -} - rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt - -- more informative than the C type! - -XXX the type of rts_evalStableIO no longer matches the above - --} - --- ----------------------------------------------------------------------------- --- After stopping at a breakpoint, add free variables to the environment - --- Todo: turn this into a primop, and provide special version(s) for unboxed things -foreign import ccall unsafe "rts_getApStackVal" - getApStackVal :: StablePtr a -> Int -> IO (StablePtr b) - -getIdValFromApStack :: a -> Int -> IO HValue -getIdValFromApStack apStack stackDepth = do - apSptr <- newStablePtr apStack - resultSptr <- getApStackVal apSptr (stackDepth - 1) - result <- deRefStablePtr resultSptr - freeStablePtr apSptr - freeStablePtr resultSptr - return (unsafeCoerce# result) - -extendEnvironment - :: HscEnv - -> a -- the AP_STACK object built by the interpreter - -> SrcSpan - -> [(Id, Int)] -- free variables and offsets into the AP_STACK - -> Type - -> [OccName] -- names for the variables (from the source code) - -> IO (HscEnv, [Name]) -extendEnvironment hsc_env apStack span idsOffsets result_ty occs = do - - -- filter out any unboxed ids; we can't bind these at the prompt - let pointers = filter (\(id,_) -> isPointer id) idsOffsets - isPointer id | PtrRep <- idPrimRep id = True - | otherwise = False - - let (ids, offsets) = unzip pointers - hValues <- mapM (getIdValFromApStack apStack) offsets - new_ids <- zipWithM mkNewId occs ids - let names = map idName ids - - -- make an Id for _result. We use the Unique of the FastString "_result"; - -- we don't care about uniqueness here, because there will only be one - -- _result in scope at any time. - let result_fs = FSLIT("_result") - result_name = mkInternalName (getUnique result_fs) - (mkVarOccFS result_fs) (srcSpanStart span) - result_id = Id.mkLocalId result_name result_ty - - -- for each Id we're about to bind in the local envt: - -- - skolemise the type variables in its type, so they can't - -- be randomly unified with other types. These type variables - -- can only be resolved by type reconstruction in RtClosureInspect - -- - tidy the type variables - -- - globalise the Id (Ids are supposed to be Global, apparently). - -- - let all_ids | isPointer result_id = result_id : ids - | otherwise = ids - (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids - (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys - new_tyvars = unionVarSets tyvarss - new_ids = zipWith setIdType all_ids tidy_tys - global_ids = map (globaliseId VanillaGlobal) new_ids - - let ictxt = extendInteractiveContext (hsc_IC hsc_env) - global_ids new_tyvars - - Linker.extendLinkEnv (zip names hValues) - Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] - return (hsc_env{hsc_IC = ictxt}, result_name:names) - where - mkNewId :: OccName -> Id -> IO Id - mkNewId occ id = do - let uniq = idUnique id - loc = nameSrcLoc (idName id) - name = mkInternalName uniq occ loc - ty = tidyTopType (idType id) - new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id) - return new_id - -skolemiseTy :: Type -> (Type, TyVarSet) -skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars) - where env = mkVarEnv (zip tyvars new_tyvar_tys) - subst = mkTvSubst emptyInScopeSet env - tyvars = varSetElems (tyVarsOfType ty) - new_tyvars = map skolemiseTyVar tyvars - new_tyvar_tys = map mkTyVarTy new_tyvars - -skolemiseTyVar :: TyVar -> TyVar -skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar) - (SkolemTv RuntimeUnkSkol) - ------------------------------------------------------------------------------ --- show a module and it's source/object filenames - -showModule :: Session -> ModSummary -> IO String -showModule s mod_summary = withSession s $ \hsc_env -> - isModuleInterpreted s mod_summary >>= \interpreted -> - return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary) - -isModuleInterpreted :: Session -> ModSummary -> IO Bool -isModuleInterpreted s mod_summary = withSession s $ \hsc_env -> - case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of - Nothing -> panic "missing linkable" - Just mod_info -> return (not obj_linkable) - where - obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info)) - -obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term -obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x) - -obtainTerm :: Session -> Bool -> Id -> IO (Maybe Term) -obtainTerm sess force id = withSession sess $ \hsc_env -> do - mb_v <- Linker.getHValue (varName id) - case mb_v of - Just v -> fmap Just$ cvObtainTerm hsc_env force (Just$ idType id) v - Nothing -> return Nothing - -#endif /* GHCI */ diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 4da59433a3..b4026e8b0e 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -797,7 +797,7 @@ A naked expression returns a singleton Name [it]. hscStmt -- Compile a stmt all the way to an HValue, but don't run it :: HscEnv -> String -- The statement - -> IO (Maybe (InteractiveContext, [Name], HValue)) + -> IO (Maybe ([Id], HValue)) hscStmt hsc_env stmt = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt @@ -812,12 +812,11 @@ hscStmt hsc_env stmt ; case maybe_tc_result of { Nothing -> return Nothing ; - Just (new_ic, bound_names, tc_expr) -> do { - + Just (ids, tc_expr) -> do { -- Desugar it - ; let rdr_env = ic_rn_gbl_env new_ic - type_env = ic_type_env new_ic + ; let rdr_env = ic_rn_gbl_env icontext + type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext)) ; mb_ds_expr <- deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr ; case mb_ds_expr of { @@ -828,7 +827,7 @@ hscStmt hsc_env stmt ; let src_span = srcLocSpan interactiveSrcLoc ; hval <- compileExpr hsc_env src_span ds_expr - ; return (Just (new_ic, bound_names, hval)) + ; return (Just (ids, hval)) }}}}}}} hscTcExpr -- Typecheck an expression (but don't run it) diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index f1b96229a6..126f07fa2d 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -6,7 +6,8 @@ \begin{code} module HscTypes ( -- * Sessions and compilation state - Session(..), HscEnv(..), hscEPS, + Session(..), withSession, modifySession, + HscEnv(..), hscEPS, FinderCache, FindResult(..), ModLocationCache, Target(..), TargetId(..), pprTarget, pprTargetId, ModuleGraph, emptyMG, @@ -14,7 +15,7 @@ module HscTypes ( ModDetails(..), emptyModDetails, ModGuts(..), CgGuts(..), ModImports(..), ForeignStubs(..), - ModSummary(..), showModMsg, isBootSummary, + ModSummary(..), ms_mod_name, showModMsg, isBootSummary, msHsFilePath, msHiFilePath, msObjFilePath, HscSource(..), isHsBoot, hscSourceString, -- Re-exported from DriverPhases @@ -69,6 +70,7 @@ module HscTypes ( #ifdef GHCI import ByteCodeAsm ( CompiledByteCode ) +import {-# SOURCE #-} InteractiveEval ( Resume ) #endif import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, @@ -112,7 +114,7 @@ import FastString ( FastString ) import StringBuffer ( StringBuffer ) import System.Time ( ClockTime ) -import Data.IORef ( IORef, readIORef ) +import Data.IORef import Data.Array ( Array, array ) \end{code} @@ -130,6 +132,12 @@ import Data.Array ( Array, array ) -- constituting the current program or library, the context for -- interactive evaluation, and various caches. newtype Session = Session (IORef HscEnv) + +withSession :: Session -> (HscEnv -> IO a) -> IO a +withSession (Session ref) f = do h <- readIORef ref; f h + +modifySession :: Session -> (HscEnv -> HscEnv) -> IO () +modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h \end{code} HscEnv is like Session, except that some of the fields are immutable. @@ -615,27 +623,32 @@ data InteractiveContext ic_rn_gbl_env :: GlobalRdrEnv, -- The cached GlobalRdrEnv, built from -- ic_toplev_scope and ic_exports - ic_type_env :: TypeEnv, -- Type env for names bound during - -- interaction. NB. the names from - -- these Ids are used to populate - -- the LocalRdrEnv used during - -- typechecking of a statement, so - -- there should be no duplicate - -- names in here. + ic_tmp_ids :: [Id], -- Names bound during interaction. + -- Earlier Ids shadow + -- later ones with the same OccName. ic_tyvars :: TyVarSet -- skolem type variables free in - -- ic_type_env. These arise at + -- ic_tmp_ids. These arise at -- breakpoints in a polymorphic -- context, where we have only partial -- type information. + +#ifdef GHCI + , ic_resume :: [Resume] -- the stack of breakpoint contexts +#endif } + emptyInteractiveContext = InteractiveContext { ic_toplev_scope = [], ic_exports = [], ic_rn_gbl_env = emptyGlobalRdrEnv, - ic_type_env = emptyTypeEnv, - ic_tyvars = emptyVarSet } + ic_tmp_ids = [], + ic_tyvars = emptyVarSet +#ifdef GHCI + , ic_resume = [] +#endif + } icPrintUnqual :: InteractiveContext -> PrintUnqualified icPrintUnqual ictxt = mkPrintUnqualified (ic_rn_gbl_env ictxt) @@ -647,19 +660,8 @@ extendInteractiveContext -> TyVarSet -> InteractiveContext extendInteractiveContext ictxt ids tyvars - = ictxt { ic_type_env = extendTypeEnvWithIds filtered_type_env ids, + = ictxt { ic_tmp_ids = ids ++ ic_tmp_ids ictxt, ic_tyvars = ic_tyvars ictxt `unionVarSet` tyvars } - where - type_env = ic_type_env ictxt - bound_names = map idName ids - -- Remove any shadowed bindings from the type_env; - -- we aren't allowed any duplicates because the LocalRdrEnv is - -- build directly from the Ids in the type env in here. - old_bound_names = map idName (typeEnvIds type_env) - shadowed = [ n | name <- bound_names, - n <- old_bound_names, - nameOccName name == nameOccName n ] - filtered_type_env = delListFromNameEnv type_env shadowed \end{code} %************************************************************************ @@ -1141,6 +1143,9 @@ data ModSummary ms_hspp_buf :: Maybe StringBuffer -- The actual preprocessed source, maybe. } +ms_mod_name :: ModSummary -> ModuleName +ms_mod_name = moduleName . ms_mod + -- The ModLocation contains both the original source filename and the -- filename of the cleaned-up source file after all preprocessing has been -- done. The point is that the summariser will have to cpp/unlit/whatever diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs new file mode 100644 index 0000000000..ef9e5afa58 --- /dev/null +++ b/compiler/main/InteractiveEval.hs @@ -0,0 +1,688 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2005-2007 +-- +-- Running statements interactively +-- +-- ----------------------------------------------------------------------------- + +module InteractiveEval ( +#ifdef GHCI + RunResult(..), Status(..), Resume(..), + runStmt, stepStmt, -- traceStmt, + resume, stepResume, -- traceResume, + abandon, abandonAll, + getResumeContext, + setContext, getContext, + nameSetToGlobalRdrEnv, + getNamesInScope, + getRdrNamesInScope, + moduleIsInterpreted, + getInfo, + exprType, + typeKind, + parseName, + showModule, + isModuleInterpreted, + compileExpr, dynCompileExpr, + lookupName, + obtainTerm, obtainTerm1 +#endif + ) where + +#ifdef GHCI + +#include "HsVersions.h" + +import HscMain hiding (compileExpr) +import HscTypes +import TcRnDriver +import Type hiding (typeKind) +import TcType hiding (typeKind) +import InstEnv +import Var hiding (setIdType) +import Id +import IdInfo +import Name hiding ( varName ) +import NameSet +import RdrName +import VarSet +import VarEnv +import ByteCodeInstr +import Linker +import DynFlags +import Unique +import Module +import Panic +import UniqFM +import Maybes +import Util +import SrcLoc +import RtClosureInspect +import Packages +import BasicTypes +import Outputable + +import Data.Dynamic +import Control.Monad +import Foreign +import GHC.Exts +import Data.Array +import Control.Exception as Exception +import Control.Concurrent +import Data.IORef +import Foreign.StablePtr + +-- ----------------------------------------------------------------------------- +-- running a statement interactively + +data RunResult + = RunOk [Name] -- ^ names bound by this evaluation + | RunFailed -- ^ statement failed compilation + | RunException Exception -- ^ statement raised an exception + | RunBreak ThreadId [Name] BreakInfo + +data Status + = Break HValue BreakInfo ThreadId + -- ^ the computation hit a breakpoint + | Complete (Either Exception [HValue]) + -- ^ the computation completed with either an exception or a value + +data Resume + = Resume { + resumeStmt :: String, -- the original statement + resumeThreadId :: ThreadId, -- thread running the computation + resumeBreakMVar :: MVar (), + resumeStatMVar :: MVar Status, + resumeBindings :: ([Id], TyVarSet), + resumeFinalIds :: [Id], -- [Id] to bind on completion + resumeApStack :: HValue, -- The object from which we can get + -- value of the free variables. + resumeBreakInfo :: BreakInfo, -- the breakpoint we stopped at. + resumeSpan :: SrcSpan -- just a cache, otherwise it's a pain + -- to fetch the ModDetails & ModBreaks + -- to get this. + } + +getResumeContext :: Session -> IO [Resume] +getResumeContext s = withSession s (return . ic_resume . hsc_IC) + +data SingleStep + = RunToCompletion + | SingleStep + | RunAndLogSteps + +isStep RunToCompletion = False +isStep _ = True + +-- type History = [HistoryItem] +-- +-- data HistoryItem = HistoryItem HValue BreakInfo +-- +-- historyBreakInfo :: HistoryItem -> BreakInfo +-- historyBreakInfo (HistoryItem _ bi) = bi +-- +-- setContextToHistoryItem :: Session -> HistoryItem -> IO () +-- setContextToHistoryItem + +-- We need to track two InteractiveContexts: +-- - the IC before runStmt, which is restored on each resume +-- - the IC binding the results of the original statement, which +-- will be the IC when runStmt returns with RunOk. + +-- | Run a statement in the current interactive context. Statement +-- may bind multple values. +runStmt :: Session -> String -> IO RunResult +runStmt session expr = runStmt_ session expr RunToCompletion + +-- | Run a statement, stopping at the first breakpoint location encountered +-- (regardless of whether the breakpoint is enabled). +stepStmt :: Session -> String -> IO RunResult +stepStmt session expr = runStmt_ session expr SingleStep + +-- | Run a statement, logging breakpoints passed, and stopping when either +-- an enabled breakpoint is reached, or the statement completes. +-- traceStmt :: Session -> String -> IO (RunResult, History) +-- traceStmt session expr = runStmt_ session expr RunAndLogSteps + +runStmt_ (Session ref) expr step + = do + hsc_env <- readIORef ref + + breakMVar <- newEmptyMVar -- wait on this when we hit a breakpoint + statusMVar <- newEmptyMVar -- wait on this when a computation is running + + -- Turn off -fwarn-unused-bindings when running a statement, to hide + -- warnings about the implicit bindings we introduce. + let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds + hsc_env' = hsc_env{ hsc_dflags = dflags' } + + maybe_stuff <- hscStmt hsc_env' expr + + case maybe_stuff of + Nothing -> return RunFailed + Just (ids, hval) -> do + + when (isStep step) $ setStepFlag + + -- set the onBreakAction to be performed when we hit a + -- breakpoint this is visible in the Byte Code + -- Interpreter, thus it is a global variable, + -- implemented with stable pointers + withBreakAction breakMVar statusMVar $ do + + let thing_to_run = unsafeCoerce# hval :: IO [HValue] + status <- sandboxIO statusMVar thing_to_run + + let ic = hsc_IC hsc_env + bindings = (ic_tmp_ids ic, ic_tyvars ic) + handleRunStatus expr ref bindings ids breakMVar statusMVar status + +handleRunStatus expr ref bindings final_ids breakMVar statusMVar status = + case status of + -- did we hit a breakpoint or did we complete? + (Break apStack info tid) -> do + hsc_env <- readIORef ref + let + mod_name = moduleName (breakInfo_module info) + mod_details = fmap hm_details (lookupUFM (hsc_HPT hsc_env) mod_name) + breaks = md_modBreaks (expectJust "handlRunStatus" mod_details) + -- + (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env + apStack info breaks + let + resume = Resume expr tid breakMVar statusMVar + bindings final_ids apStack info span + hsc_env2 = pushResume hsc_env1 resume + -- + writeIORef ref hsc_env2 + return (RunBreak tid names info) + (Complete either_hvals) -> + case either_hvals of + Left e -> return (RunException e) + Right hvals -> do + hsc_env <- readIORef ref + let final_ic = extendInteractiveContext (hsc_IC hsc_env) + final_ids emptyVarSet + -- the bound Ids never have any free TyVars + final_names = map idName final_ids + writeIORef ref hsc_env{hsc_IC=final_ic} + Linker.extendLinkEnv (zip final_names hvals) + return (RunOk final_names) + +{- +traceRunStatus ref final_ids + breakMVar statusMVar status history = do + hsc_env <- readIORef ref + case status of + -- when tracing, if we hit a breakpoint that is not explicitly + -- enabled, then we just log the event in the history and continue. + (Break apStack info tid) | not (isBreakEnabled hsc_env info) -> do + let history' = consBL (apStack,info) history + withBreakAction breakMVar statusMVar $ do + status <- withInterruptsSentTo + (do putMVar breakMVar () -- this awakens the stopped thread... + return tid) + (takeMVar statusMVar) -- and wait for the result + + traceRunStatus ref final_ids + breakMVar statusMVar status history' + _other -> + handleRunStatus ref final_ids + breakMVar statusMVar status + +-} + +foreign import ccall "rts_setStepFlag" setStepFlag :: IO () + +-- this points to the IO action that is executed when a breakpoint is hit +foreign import ccall "&breakPointIOAction" + breakPointIOAction :: Ptr (StablePtr (BreakInfo -> HValue -> IO ())) + +-- When running a computation, we redirect ^C exceptions to the running +-- thread. ToDo: we might want a way to continue even if the target +-- thread doesn't die when it receives the exception... "this thread +-- is not responding". +sandboxIO :: MVar Status -> IO [HValue] -> IO Status +sandboxIO statusMVar thing = + withInterruptsSentTo + (forkIO (do res <- Exception.try thing + putMVar statusMVar (Complete res))) + (takeMVar statusMVar) + +withInterruptsSentTo :: IO ThreadId -> IO r -> IO r +withInterruptsSentTo io get_result = do + ts <- takeMVar interruptTargetThread + child <- io + putMVar interruptTargetThread (child:ts) + get_result `finally` modifyMVar_ interruptTargetThread (return.tail) + +withBreakAction breakMVar statusMVar io + = bracket setBreakAction resetBreakAction (\_ -> io) + where + setBreakAction = do + stablePtr <- newStablePtr onBreak + poke breakPointIOAction stablePtr + return stablePtr + + onBreak info apStack = do + tid <- myThreadId + putMVar statusMVar (Break apStack info tid) + takeMVar breakMVar + + resetBreakAction stablePtr = do + poke breakPointIOAction noBreakStablePtr + freeStablePtr stablePtr + +noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction +noBreakAction info apStack = putStrLn "*** Ignoring breakpoint" + +resume :: Session -> IO RunResult +resume session = resume_ session RunToCompletion + +stepResume :: Session -> IO RunResult +stepResume session = resume_ session SingleStep + +-- traceResume :: Session -> IO RunResult +-- traceResume session handle = resume_ session handle RunAndLogSteps + +resume_ :: Session -> SingleStep -> IO RunResult +resume_ (Session ref) step + = do + hsc_env <- readIORef ref + let ic = hsc_IC hsc_env + resume = ic_resume ic + + case resume of + [] -> throwDyn (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_ids, resume_tyvars) = resumeBindings r + ic' = ic { ic_tmp_ids = resume_tmp_ids, + ic_tyvars = resume_tyvars, + ic_resume = rs } + writeIORef ref hsc_env{ hsc_IC = ic' } + + -- remove any bindings created since the breakpoint from the + -- linker's environment + let new_names = map idName (filter (`notElem` resume_tmp_ids) + (ic_tmp_ids ic)) + Linker.deleteFromLinkEnv new_names + + + when (isStep step) $ setStepFlag + case r of + Resume expr tid breakMVar statusMVar bindings + final_ids apStack info _ -> do + withBreakAction breakMVar statusMVar $ do + status <- withInterruptsSentTo + (do putMVar breakMVar () + -- this awakens the stopped thread... + return tid) + (takeMVar statusMVar) + -- and wait for the result + handleRunStatus expr ref bindings final_ids + breakMVar statusMVar status + +-- ----------------------------------------------------------------------------- +-- After stopping at a breakpoint, add free variables to the environment + +bindLocalsAtBreakpoint + :: HscEnv + -> HValue + -> BreakInfo + -> ModBreaks + -> IO (HscEnv, [Name], SrcSpan) +bindLocalsAtBreakpoint hsc_env apStack info breaks = do + + let + index = breakInfo_number info + vars = breakInfo_vars info + result_ty = breakInfo_resty info + occs = modBreaks_vars breaks ! index + span = modBreaks_locs breaks ! index + + -- filter out any unboxed ids; we can't bind these at the prompt + let pointers = filter (\(id,_) -> isPointer id) vars + isPointer id | PtrRep <- idPrimRep id = True + | otherwise = False + + let (ids, offsets) = unzip pointers + hValues <- mapM (getIdValFromApStack apStack) offsets + new_ids <- zipWithM mkNewId occs ids + let names = map idName ids + + -- make an Id for _result. We use the Unique of the FastString "_result"; + -- we don't care about uniqueness here, because there will only be one + -- _result in scope at any time. + let result_fs = FSLIT("_result") + result_name = mkInternalName (getUnique result_fs) + (mkVarOccFS result_fs) (srcSpanStart span) + result_id = Id.mkLocalId result_name result_ty + + -- for each Id we're about to bind in the local envt: + -- - skolemise the type variables in its type, so they can't + -- be randomly unified with other types. These type variables + -- can only be resolved by type reconstruction in RtClosureInspect + -- - tidy the type variables + -- - globalise the Id (Ids are supposed to be Global, apparently). + -- + let all_ids | isPointer result_id = result_id : ids + | otherwise = ids + (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids + (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys + new_tyvars = unionVarSets tyvarss + new_ids = zipWith setIdType all_ids tidy_tys + global_ids = map (globaliseId VanillaGlobal) new_ids + + let ictxt0 = hsc_IC hsc_env + ictxt1 = extendInteractiveContext ictxt0 global_ids new_tyvars + + Linker.extendLinkEnv (zip names hValues) + Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] + return (hsc_env{ hsc_IC = ictxt1 }, result_name:names, span) + where + mkNewId :: OccName -> Id -> IO Id + mkNewId occ id = do + let uniq = idUnique id + loc = nameSrcLoc (idName id) + name = mkInternalName uniq occ loc + ty = tidyTopType (idType id) + new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id) + return new_id + +skolemiseTy :: Type -> (Type, TyVarSet) +skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars) + where env = mkVarEnv (zip tyvars new_tyvar_tys) + subst = mkTvSubst emptyInScopeSet env + tyvars = varSetElems (tyVarsOfType ty) + new_tyvars = map skolemiseTyVar tyvars + new_tyvar_tys = map mkTyVarTy new_tyvars + +skolemiseTyVar :: TyVar -> TyVar +skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar) + (SkolemTv RuntimeUnkSkol) + +-- Todo: turn this into a primop, and provide special version(s) for +-- unboxed things +foreign import ccall unsafe "rts_getApStackVal" + getApStackVal :: StablePtr a -> Int -> IO (StablePtr b) + +getIdValFromApStack :: a -> Int -> IO HValue +getIdValFromApStack apStack stackDepth = do + apSptr <- newStablePtr apStack + resultSptr <- getApStackVal apSptr (stackDepth - 1) + result <- deRefStablePtr resultSptr + freeStablePtr apSptr + freeStablePtr resultSptr + return (unsafeCoerce# result) + +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 } + +-- ----------------------------------------------------------------------------- +-- Abandoning a resume context + +abandon :: Session -> IO Bool +abandon (Session ref) = do + hsc_env <- readIORef ref + let ic = hsc_IC hsc_env + resume = ic_resume ic + case resume of + [] -> return False + _:rs -> do + writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = rs } } + return True + +abandonAll :: Session -> IO Bool +abandonAll (Session ref) = do + hsc_env <- readIORef ref + let ic = hsc_IC hsc_env + resume = ic_resume ic + case resume of + [] -> return False + _:rs -> do + writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = [] } } + 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) + +consBL a (BL len bound left right) + | len < bound = BL (len+1) bound (a:left) right + | null right = BL len bound [] $! tail (reverse left) + | otherwise = BL len bound [] $! tail right + +toListBL (BL _ _ left right) = left ++ reverse right + +lenBL (BL len _ _ _) = len + +-- ----------------------------------------------------------------------------- +-- | Set the interactive evaluation context. +-- +-- Setting the context doesn't throw away any bindings; the bindings +-- we've built up in the InteractiveContext simply move to the new +-- module. They always shadow anything in scope in the current context. +setContext :: Session + -> [Module] -- entire top level scope of these modules + -> [Module] -- exports only of these modules + -> IO () +setContext sess@(Session ref) toplev_mods export_mods = do + hsc_env <- readIORef ref + let old_ic = hsc_IC hsc_env + hpt = hsc_HPT hsc_env + -- + export_env <- mkExportEnv hsc_env export_mods + toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods + let all_env = foldr plusGlobalRdrEnv export_env toplev_envs + writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods, + ic_exports = export_mods, + ic_rn_gbl_env = all_env }} + +-- Make a GlobalRdrEnv based on the exports of the modules only. +mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv +mkExportEnv hsc_env mods = do + stuff <- mapM (getModuleExports hsc_env) mods + let + (_msgs, mb_name_sets) = unzip stuff + gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod) + | (Just avails, mod) <- zip mb_name_sets mods ] + -- + return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres + +nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv +nameSetToGlobalRdrEnv names mod = + mkGlobalRdrEnv [ GRE { gre_name = name, gre_prov = vanillaProv mod } + | name <- nameSetToList names ] + +vanillaProv :: ModuleName -> Provenance +-- We're building a GlobalRdrEnv as if the user imported +-- all the specified modules into the global interactive module +vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] + where + decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, + is_qual = False, + is_dloc = srcLocSpan interactiveSrcLoc } + +mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv +mkTopLevEnv hpt modl + = case lookupUFM hpt (moduleName modl) of + Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++ + showSDoc (ppr modl))) + Just details -> + case mi_globals (hm_iface details) of + Nothing -> + throwDyn (ProgramError ("mkTopLevEnv: not interpreted " + ++ showSDoc (ppr modl))) + Just env -> return 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 :: Session -> IO ([Module],[Module]) +getContext s = withSession s (\HscEnv{ hsc_IC=ic } -> + return (ic_toplev_scope ic, ic_exports ic)) + +-- | Returns 'True' if the specified module is interpreted, and hence has +-- its full top-level scope available. +moduleIsInterpreted :: Session -> Module -> IO Bool +moduleIsInterpreted s modl = withSession s $ \h -> + if modulePackageId modl /= thisPackage (hsc_dflags h) + then return False + else case lookupUFM (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) +getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance])) +getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name + +-- | Returns all names in scope in the current interactive context +getNamesInScope :: Session -> IO [Name] +getNamesInScope s = withSession s $ \hsc_env -> do + return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) + +getRdrNamesInScope :: Session -> IO [RdrName] +getRdrNamesInScope s = withSession s $ \hsc_env -> do + let + ic = hsc_IC hsc_env + gbl_rdrenv = ic_rn_gbl_env ic + ids = ic_tmp_ids ic + gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv)) + lcl_names = map (mkRdrUnqual.nameOccName.idName) ids + -- + return (gbl_names ++ lcl_names) + + +-- ToDo: move to RdrName +greToRdrNames :: GlobalRdrElt -> [RdrName] +greToRdrNames GRE{ gre_name = name, gre_prov = prov } + = case prov of + LocalDef -> [unqual] + Imported specs -> concat (map do_spec (map is_decl specs)) + where + occ = nameOccName name + unqual = Unqual occ + do_spec decl_spec + | is_qual decl_spec = [qual] + | otherwise = [unqual,qual] + where qual = Qual (is_as decl_spec) occ + +-- | 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 :: Session -> String -> IO [Name] +parseName s str = withSession s $ \hsc_env -> do + maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str + case maybe_rdr_name of + Nothing -> return [] + Just (L _ rdr_name) -> do + mb_names <- tcRnLookupRdrName hsc_env rdr_name + case mb_names of + Nothing -> return [] + Just ns -> return ns + -- ToDo: should return error messages + +-- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any +-- entity known to GHC, including 'Name's defined using 'runStmt'. +lookupName :: Session -> Name -> IO (Maybe TyThing) +lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name + +-- ----------------------------------------------------------------------------- +-- Getting the type of an expression + +-- | Get the type of an expression +exprType :: Session -> String -> IO (Maybe Type) +exprType s expr = withSession s $ \hsc_env -> do + maybe_stuff <- hscTcExpr hsc_env expr + case maybe_stuff of + Nothing -> return Nothing + Just ty -> return (Just tidy_ty) + where + tidy_ty = tidyType emptyTidyEnv ty + +-- ----------------------------------------------------------------------------- +-- Getting the kind of a type + +-- | Get the kind of a type +typeKind :: Session -> String -> IO (Maybe Kind) +typeKind s str = withSession s $ \hsc_env -> do + maybe_stuff <- hscKcType hsc_env str + case maybe_stuff of + Nothing -> return Nothing + Just kind -> return (Just kind) + +----------------------------------------------------------------------------- +-- cmCompileExpr: compile an expression and deliver an HValue + +compileExpr :: Session -> String -> IO (Maybe HValue) +compileExpr s expr = withSession s $ \hsc_env -> do + maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr) + case maybe_stuff of + Nothing -> return Nothing + Just (ids, hval) -> do + -- Run it! + hvals <- (unsafeCoerce# hval) :: IO [HValue] + + case (ids,hvals) of + ([n],[hv]) -> return (Just hv) + _ -> panic "compileExpr" + +-- ----------------------------------------------------------------------------- +-- Compile an expression into a dynamic + +dynCompileExpr :: Session -> String -> IO (Maybe Dynamic) +dynCompileExpr ses expr = do + (full,exports) <- getContext ses + setContext ses full $ + (mkModule + (stringToPackageId "base") (mkModuleName "Data.Dynamic") + ):exports + let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")" + res <- withSession ses (flip hscStmt stmt) + setContext ses full exports + case res of + Nothing -> return Nothing + Just (ids, hvals) -> do + vals <- (unsafeCoerce# hvals :: IO [Dynamic]) + case (ids,vals) of + (_:[], v:[]) -> return (Just v) + _ -> panic "dynCompileExpr" + +----------------------------------------------------------------------------- +-- show a module and it's source/object filenames + +showModule :: Session -> ModSummary -> IO String +showModule s mod_summary = withSession s $ \hsc_env -> + isModuleInterpreted s mod_summary >>= \interpreted -> + return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary) + +isModuleInterpreted :: Session -> ModSummary -> IO Bool +isModuleInterpreted s mod_summary = withSession s $ \hsc_env -> + case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of + Nothing -> panic "missing linkable" + Just mod_info -> return (not obj_linkable) + where + obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info)) + +obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term +obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x) + +obtainTerm :: Session -> Bool -> Id -> IO (Maybe Term) +obtainTerm sess force id = withSession sess $ \hsc_env -> do + mb_v <- Linker.getHValue (varName id) + case mb_v of + Just v -> fmap Just$ cvObtainTerm hsc_env force (Just$ idType id) v + Nothing -> return Nothing + +#endif /* GHCI */ diff --git a/compiler/main/InteractiveEval.hs-boot b/compiler/main/InteractiveEval.hs-boot new file mode 100644 index 0000000000..67b77436d1 --- /dev/null +++ b/compiler/main/InteractiveEval.hs-boot @@ -0,0 +1,3 @@ +module InteractiveEval (Resume) where + +data Resume diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 05777df471..15cda27fe1 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -62,7 +62,6 @@ import CoreSyn import ErrUtils import Id import Var -import VarSet import Module import UniqFM import Name @@ -833,7 +832,7 @@ setInteractiveContext hsc_env icxt thing_inside tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $ - tcExtendIdEnv (typeEnvIds (ic_type_env icxt)) $ + tcExtendIdEnv (reverse (ic_tmp_ids icxt)) $ -- tcExtendIdEnv does lots: -- - it extends the local type env (tcl_env) with the given Ids, -- - it extends the local rdr env (tcl_rdr) with the Names from @@ -841,11 +840,11 @@ setInteractiveContext hsc_env icxt thing_inside -- - it adds the free tyvars of the Ids to the tcl_tyvars -- set. -- - -- We should have no Ids with the same name in the - -- ic_type_env, otherwise we'll end up with shadowing in the - -- tcl_rdr, and it's random which one will be in scope. + -- earlier ids in ic_tmp_ids must shadow later ones with the same + -- OccName, but tcExtendIdEnv has the opposite behaviour, hence the + -- reverse above. - do { traceTc (text "setIC" <+> ppr (ic_type_env icxt)) + do { traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt)) ; thing_inside } \end{code} @@ -854,9 +853,10 @@ setInteractiveContext hsc_env icxt thing_inside tcRnStmt :: HscEnv -> InteractiveContext -> LStmt RdrName - -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id)) - -- The returned [Name] is the same as the input except for - -- ExprStmt, in which case the returned [Name] is [itName] + -> IO (Maybe ([Id], LHsExpr Id)) + -- The returned [Id] is the list of new Ids bound by + -- this statement. It can be used to extend the + -- InteractiveContext via extendInteractiveContext. -- -- The returned TypecheckedHsExpr is of type IO [ () ], -- a list of the bound values, coerced to (). @@ -891,8 +891,6 @@ tcRnStmt hsc_env ictxt rdr_stmt -- up to have tidy types global_ids = map globaliseAndTidy zonked_ids ; - bound_names = map idName global_ids ; - {- --------------------------------------------- At one stage I removed any shadowed bindings from the type_env; they are inaccessible but might, I suppose, cause a space leak if we leave them there. @@ -911,15 +909,13 @@ tcRnStmt hsc_env ictxt rdr_stmt Hence this code is commented out -------------------------------------------------- -} - - new_ic = extendInteractiveContext ictxt global_ids emptyVarSet ; } ; dumpOptTcRn Opt_D_dump_tc (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, text "Typechecked expr" <+> ppr zonked_expr]) ; - returnM (new_ic, bound_names, zonked_expr) + returnM (global_ids, zonked_expr) } where bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"), |