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
getRdrNamesInScope :: Session -> IO [RdrName]
getRdrNamesInScope s = withSession s $ \hsc_env -> do
- let env = ic_rn_gbl_env (hsc_IC hsc_env)
- return (concat (map greToRdrNames (globalRdrEnvElts env)))
+ 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]
hsc_env <- readIORef ref
mod_info <- getHomeModuleInfo hsc_env (moduleName (breakInfo_module info))
let breaks = minf_modBreaks (expectJust "handlRunStatus" mod_info)
- let occs = modBreaks_vars breaks ! breakInfo_number info
- (new_hsc_env, names) <- extendEnvironment hsc_env apStack
- (breakInfo_vars info) occs
+ 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
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 idsOffsets occs = do
+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
- Just (ATyCon unknown_tc) <- tcRnLookupName hsc_env unknownTyConName
- let result_name = mkSystemVarName (mkBuiltinUnique 33) FSLIT("_result")
- result_id = Id.mkLocalId result_name (mkTyConApp unknown_tc [])
- let ictxt = hsc_IC hsc_env
- rn_env = ic_rn_local_env ictxt
- type_env = ic_type_env ictxt
- all_new_ids = result_id : new_ids
- bound_names = map idName all_new_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 all_new_ids
- new_ic = ictxt { ic_rn_local_env = new_rn_env,
- ic_type_env = new_type_env }
+
+ -- 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 = new_ic}, result_name:names)
+ return (hsc_env{hsc_IC = ictxt}, result_name:names)
where
mkNewId :: OccName -> Id -> IO Id
mkNewId occ id = do
- ty <- instantiateTyVarsToUnknown hsc_env
let uniq = idUnique id
loc = nameSrcLoc (idName id)
name = mkInternalName uniq occ loc
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