+-- -----------------------------------------------------------------------------
+-- 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 "rts_getApStackVal" getApStackVal :: StablePtr a -> Int -> IO (StablePtr b)
+
+getIdValFromApStack :: a -> (Id, Int) -> IO (Id, HValue)
+getIdValFromApStack apStack (identifier, stackDepth) = do
+ -- ToDo: check the type of the identifer and decide whether it is unboxed or not
+ apSptr <- newStablePtr apStack
+ resultSptr <- getApStackVal apSptr (stackDepth - 1)
+ result <- deRefStablePtr resultSptr
+ freeStablePtr apSptr
+ freeStablePtr resultSptr
+ return (identifier, unsafeCoerce# result)
+
+extendEnvironment
+ :: HscEnv
+ -> a -- the AP_STACK object built by the interpreter
+ -> [(Id, Int)] -- free variables and offsets into the AP_STACK
+ -> [OccName] -- names for the variables (from the source code)
+ -> IO (HscEnv, [Name])
+extendEnvironment hsc_env apStack idsOffsets 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 }
+ Linker.extendLinkEnv (zip names hValues)
+ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
+ return (hsc_env{hsc_IC = new_ic}, 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
+ ty = tidyTopType (idType id)
+ new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
+ return new_id
+