From 71e037d119b8e7d05884cc149ac851243ee62bd4 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Wed, 25 Apr 2007 15:42:35 +0000 Subject: [PATCH] Tidy types of free vars at a breakpoint Also share the code that extends the InteractiveContext between tcRnStmt and GHC.extendEnvironment. --- compiler/main/GHC.hs | 33 +++++++++++++++------------------ compiler/main/HscTypes.lhs | 25 +++++++++++++++++++++++-- compiler/typecheck/TcRnDriver.lhs | 14 ++------------ 3 files changed, 40 insertions(+), 32 deletions(-) diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index c5e6fa0..a8c435a 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -2337,29 +2337,26 @@ extendEnvironment hsc_env apStack span idsOffsets result_ty occs = do (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 id_tys - - let ictxt = hsc_IC hsc_env - type_env = ic_type_env ictxt - bound_names = map idName new_ids - -- Remove any shadowed bindings from the type_env; - -- they are inaccessible but might, I suppose, cause - -- a space leak if we leave them there - old_bound_names = map idName (typeEnvIds (ic_type_env ictxt)) ; - shadowed = [ n | name <- bound_names, - n <- old_bound_names, - nameOccName name == nameOccName n ] ; - filtered_type_env = delListFromNameEnv type_env shadowed - new_type_env = extendTypeEnvWithIds filtered_type_env new_ids - old_tyvars = ic_tyvars ictxt - new_ic = ictxt { ic_type_env = new_type_env, - ic_tyvars = old_tyvars `unionVarSet` new_tyvars } + 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 diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 04f2b7c..78dd841 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -27,7 +27,7 @@ module HscTypes ( lookupIfaceByModule, emptyModIface, InteractiveContext(..), emptyInteractiveContext, - icPrintUnqual, mkPrintUnqualified, + icPrintUnqual, mkPrintUnqualified, extendInteractiveContext, ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache, emptyIfaceDepCache, @@ -86,7 +86,7 @@ import FamInstEnv ( FamInstEnv, FamInst ) import Rules ( RuleBase ) import CoreSyn ( CoreBind ) import VarSet -import Id ( Id, isImplicitId ) +import Id import Type ( TyThing(..) ) import Class ( Class, classSelIds, classATs, classTyCon ) @@ -639,6 +639,27 @@ emptyInteractiveContext icPrintUnqual :: InteractiveContext -> PrintUnqualified icPrintUnqual ictxt = mkPrintUnqualified (ic_rn_gbl_env ictxt) + + +extendInteractiveContext + :: InteractiveContext + -> [Id] + -> TyVarSet + -> InteractiveContext +extendInteractiveContext ictxt ids tyvars + = ictxt { ic_type_env = extendTypeEnvWithIds filtered_type_env ids, + 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} %************************************************************************ diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 08ea437..07a48ae 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -62,6 +62,7 @@ import CoreSyn import ErrUtils import Id import Var +import VarSet import Module import UniqFM import Name @@ -884,9 +885,6 @@ tcRnStmt hsc_env ictxt rdr_stmt -- up to have tidy types global_ids = map globaliseAndTidy zonked_ids ; - -- Update the interactive context - type_env = ic_type_env ictxt ; - bound_names = map idName global_ids ; {- --------------------------------------------- @@ -908,15 +906,7 @@ tcRnStmt hsc_env ictxt rdr_stmt -------------------------------------------------- -} - old_bound_names = map idName (typeEnvIds (ic_type_env ictxt)) ; - shadowed = [ n | name <- bound_names, - n <- old_bound_names, - nameOccName name == nameOccName n ] ; - - filtered_type_env = delListFromNameEnv type_env shadowed ; - - new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ; - new_ic = ictxt { ic_type_env = new_type_env } + new_ic = extendInteractiveContext ictxt global_ids emptyVarSet ; } ; dumpOptTcRn Opt_D_dump_tc -- 1.7.10.4