-- ** Source locations
SrcLoc, pprDefnLoc,
+ mkSrcLoc, isGoodSrcLoc,
+ srcLocFile, srcLocLine, srcLocCol,
+ SrcSpan,
+ mkSrcSpan, srcLocSpan,
+ srcSpanStart, srcSpanEnd,
+ srcSpanFile,
+ srcSpanStartLine, srcSpanEndLine,
+ srcSpanStartCol, srcSpanEndCol,
-- * Exceptions
GhcException(..), showGhcException,
import RtClosureInspect ( cvObtainTerm, Term )
import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo,
tcRnLookupName, getModuleExports )
-import VarEnv ( emptyTidyEnv )
import GHC.Exts ( unsafeCoerce#, Ptr )
import Foreign.StablePtr( deRefStablePtr, StablePtr, newStablePtr, freeStablePtr )
import Foreign ( poke )
import Data.Dynamic ( Dynamic )
import ByteCodeInstr
-import DebuggerTys
import IdInfo
import HscMain ( hscParseIdentifier, hscTcExpr, hscKcType, hscStmt )
import BreakArray
import RdrName
import HsSyn
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
import Maybes ( expectJust, mapCatMaybes )
import HaddockParse
import HaddockLex ( tokenise )
+import PrelNames
+import Unique
+import Data.Array
import Control.Concurrent
import System.Directory ( getModificationTime, doesFileExist )
import Data.Maybe
| RunBreak ThreadId [Name] BreakInfo ResumeHandle
data Status
- = Break HValue BreakInfo ThreadId (MVar ()) (MVar Status) [Name]
+ = Break HValue BreakInfo ThreadId
-- ^ the computation hit a breakpoint
| Complete (Either Exception [HValue])
-- ^ the computation completed with either an exception or a value
(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
case maybe_stuff of
Nothing -> return RunFailed
- Just (new_hsc_env, names, hval) -> do
- writeIORef ref new_hsc_env
+ 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
- stablePtr <- setBreakAction breakMVar statusMVar names
+ stablePtr <- setBreakAction breakMVar statusMVar
let thing_to_run = unsafeCoerce# hval :: IO [HValue]
status <- sandboxIO statusMVar thing_to_run
freeStablePtr stablePtr -- be careful not to leak stable pointers!
- handleRunStatus ref (hsc_IC new_hsc_env) names status
+ handleRunStatus ref new_IC names (hsc_IC hsc_env)
+ breakMVar statusMVar status
-handleRunStatus ref ic names 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 breakMVar statusMVar final_names) -> do
- hsc_env <- readIORef ref
- (new_hsc_env, names) <- extendEnvironment hsc_env apStack
- (breakInfo_vars info)
- writeIORef ref new_hsc_env
- let res = ResumeHandle breakMVar statusMVar final_names
- ic names
- return (RunBreak tid names info res)
+ (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
- Linker.extendLinkEnv (zip names hvals)
- return (RunOk names)
-
+ 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 ()))
putMVar interruptTargetThread (child:ts)
takeMVar statusMVar `finally` modifyMVar_ interruptTargetThread (return.tail)
-setBreakAction breakMVar statusMVar final_names = do
+setBreakAction breakMVar statusMVar = do
stablePtr <- newStablePtr onBreak
poke breakPointIOAction stablePtr
return stablePtr
where onBreak ids apStack = do
tid <- myThreadId
- putMVar statusMVar (Break apStack ids tid breakMVar statusMVar
- final_names)
+ putMVar statusMVar (Break apStack ids tid)
takeMVar breakMVar
resume :: Session -> ResumeHandle -> IO RunResult
resume (Session ref) res@(ResumeHandle breakMVar statusMVar
- final_names ic names)
+ 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 = ic }
+ writeIORef ref hsc_env{ hsc_IC = resume_ic }
Linker.deleteFromLinkEnv names
- stablePtr <- setBreakAction breakMVar statusMVar final_names
+ stablePtr <- setBreakAction breakMVar statusMVar
putMVar breakMVar () -- this awakens the stopped thread...
status <- takeMVar statusMVar -- and wait for the result
freeStablePtr stablePtr -- be careful not to leak stable pointers!
- handleRunStatus ref ic names status
+ handleRunStatus ref final_ic final_names resume_ic
+ breakMVar statusMVar status
{-
-- This version of sandboxIO runs the expression in a completely new
freeStablePtr resultSptr
return (identifier, unsafeCoerce# result)
-extendEnvironment :: HscEnv -> a -> [(Id, Int)] -> IO (HscEnv, [Name])
-extendEnvironment hsc_env apStack idsOffsets = do
+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
idsVals <- mapM (getIdValFromApStack apStack) idsOffsets
let (ids, hValues) = unzip idsVals
+ new_ids <- zipWithM mkNewId occs ids
let names = map idName ids
- let global_ids = map globaliseAndTidy ids
- typed_ids <- mapM instantiateIdType global_ids
- let ictxt = hsc_IC hsc_env
- rn_env = ic_rn_local_env ictxt
- type_env = ic_type_env ictxt
- bound_names = map idName typed_ids
- new_rn_env = extendLocalRdrEnv rn_env bound_names
- -- Remove any shadowed bindings from the type_env;
- -- they are inaccessible but might, I suppose, cause
- -- a space leak if we leave them there
- shadowed = [ n | name <- bound_names,
- let rdr_name = mkRdrUnqual (nameOccName name),
- Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
- filtered_type_env = delListFromNameEnv type_env shadowed
- new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids)
- new_ic = ictxt { ic_rn_local_env = new_rn_env,
- ic_type_env = new_type_env }
- Linker.extendLinkEnv (zip names hValues) -- ToDo: we must remember to restore the old env after we finish a breakpoint
- return (hsc_env{hsc_IC = new_ic}, names)
+
+ -- 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 = result_id : 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
- globaliseAndTidy :: Id -> Id
- globaliseAndTidy id
- = let tidied_type = tidyTopType$ idType id
- in setIdType (globaliseId VanillaGlobal id) tidied_type
-
- -- | Instantiate the tyVars with GHC.Base.Unknown
- instantiateIdType :: Id -> IO Id
- instantiateIdType id = do
- instantiatedType <- instantiateTyVarsToUnknown hsc_env (idType id)
- return$ setIdType id instantiatedType
+ 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
projects / ghc-hetmet.git / blobdiff