- mkNewId :: OccName -> Id -> IO Id
- mkNewId occ id = do
- let uniq = idUnique id
- loc = nameSrcSpan (idName id)
- name = mkInternalName uniq occ loc
- ty = 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)
+ -- We need a fresh Unique for each Id we bind, because the linker
+ -- state is single-threaded and otherwise we'd spam old bindings
+ -- whenever we stop at a breakpoint. The InteractveContext is properly
+ -- saved/restored, but not the linker state. See #1743, test break026.
+ mkNewId :: TvSubst -> OccName -> Id -> Unique -> Id
+ mkNewId tv_subst occ id uniq
+ = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
+ where
+ loc = nameSrcSpan (idName id)
+ name = mkInternalName uniq occ loc
+ ty = substTy tv_subst (idType id)
+
+ newTyVars :: UniqSupply -> TcTyVarSet -> TvSubst
+ -- Similarly, clone the type variables mentioned in the types
+ -- we have here, *and* make them all RuntimeUnk tyars
+ newTyVars us tvs
+ = mkTopTvSubst [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))
+ | (tv, uniq) <- varSetElems tvs `zip` uniqsFromSupply us
+ , let name = setNameUnique (tyVarName tv) uniq ]
+
+rttiEnvironment :: HscEnv -> IO HscEnv
+rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
+ let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
+ incompletelyTypedIds =
+ [id | id <- tmp_ids
+ , not $ noSkolems id
+ , (occNameFS.nameOccName.idName) id /= result_fs]
+ hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
+ return hsc_env'
+ where
+ noSkolems = isEmptyVarSet . tyVarsOfType . idType
+ improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
+ let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
+ Just id = find (\i -> idName i == name) tmp_ids
+ if noSkolems id
+ then return hsc_env
+ else do
+ mb_new_ty <- reconstructType hsc_env 10 id
+ let old_ty = idType id
+ case mb_new_ty of
+ Nothing -> return hsc_env
+ Just new_ty -> do
+ case improveRTTIType hsc_env old_ty new_ty of
+ Nothing -> return $
+ WARN(True, text (":print failed to calculate the "
+ ++ "improvement for a type")) hsc_env
+ Just subst -> do
+ when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $
+ printForUser stderr alwaysQualify $
+ fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
+
+ let ic' = extendInteractiveContext
+ (substInteractiveContext ic subst) []
+ return hsc_env{hsc_IC=ic'}