Commit 86bec429 authored by Simon Marlow's avatar Simon Marlow
Browse files

Refactoring, tidyup and improve layering

The stack of breakpoint resume contexts is now part of the
InteractiveContext and managed by the GHC API.  This prevents misuse
of the resume context by the client (e.g. resuming a breakpoint that
isn't the topmost, which would lead to a confused IC at the least).

I changed the TypeEnv in the IC to a [Id].  It only contained Ids
anyway, and this allows us to have shadowing, which removes an ugly
and annoying restriction.

The parts of the GHC API which deal with interactive evaluation are
now in a module of their own, InteractiveEval.
parent 065ce67b
......@@ -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
}
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
This diff is collapsed.
......@@ -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)
......
......@@ -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
......
This diff is collapsed.
module InteractiveEval (Resume) where
data Resume
......@@ -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:"),
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment