Clean up the debugger code

In particular there is much less fiddly skolemisation now
Things are not *quite* right (break001 and 006 still fail), 
but they are *much* better than before.

compiler/ghci/Debugger.hs

@@ -52,15 +52,12 @@ pprintClosureCommand bindThings force str = do
   let ids = [id | AnId id <- tythings]
 
   -- Obtain the terms and the recovered type information
-  (terms, substs0) <- unzip `liftM` mapM go ids
+  (subst, terms) <- mapAccumLM go emptyTvSubst ids
 
   -- Apply the substitutions obtained after recovering the types
   modifySession $ \hsc_env ->
-    let (substs, skol_vars) = unzip$ map skolemiseSubst substs0
-        hsc_ic' = foldr (flip substInteractiveContext)
-                        (extendInteractiveContext (hsc_IC hsc_env) [] (unionVarSets skol_vars))
-                        substs
-     in hsc_env{hsc_IC = hsc_ic'}
+    hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst}
+
   -- Finally, print the Terms
   unqual  <- GHC.getPrintUnqual
   docterms <- mapM showTerm terms
@@ -70,9 +67,10 @@ pprintClosureCommand bindThings force str = do
                     docterms)
  where
    -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
-   go :: GhcMonad m => Id -> m (Term, TvSubst)
-   go id = do
-       term_    <- GHC.obtainTermFromId maxBound force id
+   go :: GhcMonad m => TvSubst -> Id -> m (TvSubst, Term)
+   go subst id = do
+       let id' = id `setIdType` substTy subst (idType id) 
+       term_    <- GHC.obtainTermFromId maxBound force id'
        term     <- tidyTermTyVars term_
        term'    <- if bindThings &&
                       False == isUnliftedTypeKind (termType term)
@@ -82,19 +80,18 @@ pprintClosureCommand bindThings force str = do
      --  Then, we extract a substitution,
      --  mapping the old tyvars to the reconstructed types.
        let reconstructed_type = termType term
-       mb_subst <- withSession $ \hsc_env ->
-                     liftIO $ improveRTTIType hsc_env (idType id) (reconstructed_type)
-       maybe (return ())
-             (\subst -> traceOptIf Opt_D_dump_rtti
-                   (fsep $ [text "RTTI Improvement for", ppr id,
-                           text "is the substitution:" , ppr subst]))
-             mb_subst
-       return (term', fromMaybe emptyTvSubst mb_subst)
+       hsc_env <- getSession
+       case (improveRTTIType hsc_env (idType id) (reconstructed_type)) of
+         Nothing     -> return (subst, term')
+         Just subst' -> do { traceOptIf Opt_D_dump_rtti
+                               (fsep $ [text "RTTI Improvement for", ppr id,
+                                text "is the substitution:" , ppr subst'])
+                           ; return (subst `unionTvSubst` subst', term')}
 
    tidyTermTyVars :: GhcMonad m => Term -> m Term
    tidyTermTyVars t =
      withSession $ \hsc_env -> do
-     let env_tvs      = ic_tyvars (hsc_IC hsc_env)
+     let env_tvs      = tyVarsOfTypes (map idType (ic_tmp_ids (hsc_IC hsc_env)))
          my_tvs       = termTyVars t
          tvs          = env_tvs `minusVarSet` my_tvs
          tyvarOccName = nameOccName . tyVarName
@@ -115,10 +112,9 @@ bindSuspensions t = do
       availNames_var  <- liftIO $ newIORef availNames
       (t', stuff)     <- liftIO $ foldTerm (nameSuspensionsAndGetInfos availNames_var) t
       let (names, tys, hvals) = unzip3 stuff
-          (tys', skol_vars)   = unzip $ map skolemiseTy tys
       let ids = [ mkVanillaGlobal name ty 
-                | (name,ty) <- zip names tys']
-          new_ic = extendInteractiveContext ictxt ids (unionVarSets skol_vars)
+                | (name,ty) <- zip names tys]
+          new_ic = extendInteractiveContext ictxt ids
       liftIO $ extendLinkEnv (zip names hvals)
       modifySession $ \_ -> hsc_env {hsc_IC = new_ic }
       return t'

compiler/ghci/RtClosureInspect.hs

@@ -20,9 +20,7 @@ module RtClosureInspect(
 
 --     unsafeDeepSeq,
 
-     Closure(..), getClosureData, ClosureType(..), isConstr, isIndirection,
-
-     sigmaType
+     Closure(..), getClosureData, ClosureType(..), isConstr, isIndirection
  ) where
 
 #include "HsVersions.h"
@@ -34,6 +32,7 @@ import Linker
 
 import DataCon
 import Type
+import qualified Unify as U
 import TypeRep         -- I know I know, this is cheating
 import Var
 import TcRnMonad
@@ -572,13 +571,29 @@ liftTcM = id
 newVar :: Kind -> TR TcType
 newVar = liftTcM . newFlexiTyVarTy
 
--- | Returns the instantiated type scheme ty', and the substitution sigma 
---   such that sigma(ty') = ty 
-instScheme :: Type -> TR (TcType, TvSubst)
-instScheme ty = liftTcM$ do
-   (tvs, _, _)  <- tcInstType return ty
-   (tvs',_,ty') <- tcInstType (mapM tcInstTyVar) ty
-   return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
+type RttiInstantiation = [(TyVar, TcTyVar)]
+   -- Assoicates the debugger-world type variables (which are skolems)
+   -- to typechecker-world meta type variables (which are mutable,
+   -- and may be refined)
+
+-- | Returns the instantiated type scheme ty', and the 
+--   mapping from old to new (instantiated) type variables
+instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation)
+instScheme (tvs, ty) 
+  = liftTcM $ do { (tvs', _, subst) <- tcInstTyVars tvs
+                 ; return (substTy subst ty, tvs `zip` tvs') }
+
+applyRevSubst :: RttiInstantiation -> TR ()
+-- Apply the *reverse* substitution in-place to any un-filled-in
+-- meta tyvars.  This recovers the original debugger-world variable
+-- unless it has been refined by new information from the heap
+applyRevSubst pairs = liftTcM (mapM_ do_pair pairs)
+  where
+    do_pair (rtti_tv, tc_tv)
+      = do { tc_ty <- zonkTcTyVar tc_tv
+           ; case tcGetTyVar_maybe tc_ty of
+               Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv)
+               _                        -> return () }
 
 -- Adds a constraint of the form t1 == t2
 -- t1 is expected to come from walking the heap
@@ -589,9 +604,10 @@ addConstraint :: TcType -> TcType -> TR ()
 addConstraint actual expected = do
     traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected])
     recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
-                                    text "with", ppr expected])
-              (congruenceNewtypes actual expected >>=
-                           (captureConstraints . uncurry unifyType) >> return ())
+                                    text "with", ppr expected]) $
+      do { (ty1, ty2) <- congruenceNewtypes actual expected
+         ; _  <- captureConstraints $ unifyType ty1 ty2
+         ; return () }
      -- TOMDO: what about the coercion?
      -- we should consider family instances
 
@@ -603,30 +619,32 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
   -- we quantify existential tyvars as universal,
   -- as this is needed to be able to manipulate
   -- them properly
-   let sigma_old_ty = sigmaType old_ty
+   let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty
+       sigma_old_ty = mkForAllTys old_tvs old_tau
    traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)
    term <-
-     if isMonomorphic sigma_old_ty
+     if null old_tvs
       then do
-        new_ty <- go max_depth sigma_old_ty sigma_old_ty hval >>= zonkTerm
-        return $ fixFunDictionaries $ expandNewtypes new_ty
+        term  <- go max_depth sigma_old_ty sigma_old_ty hval
+        term' <- zonkTerm term
+        return $ fixFunDictionaries $ expandNewtypes term'
       else do
-              (old_ty', rev_subst) <- instScheme sigma_old_ty
+              (old_ty', rev_subst) <- instScheme quant_old_ty
               my_ty <- newVar argTypeKind
-              when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
+              when (check1 quant_old_ty) (traceTR (text "check1 passed") >>
                                           addConstraint my_ty old_ty')
               term  <- go max_depth my_ty sigma_old_ty hval
-              zterm <- zonkTerm term
-              let new_ty = termType zterm
-              if isMonomorphic new_ty || check2 (sigmaType new_ty) sigma_old_ty
+              new_ty <- zonkTcType (termType term)
+              if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty
                  then do
                       traceTR (text "check2 passed")
-                      addConstraint (termType term) old_ty'
+                      addConstraint new_ty old_ty'
+                      applyRevSubst rev_subst
                       zterm' <- zonkTerm term
-                      return ((fixFunDictionaries . expandNewtypes . mapTermType (substTy rev_subst)) zterm')
+                      return ((fixFunDictionaries . expandNewtypes) zterm')
                  else do
                       traceTR (text "check2 failed" <+> parens
-                                       (ppr zterm <+> text "::" <+> ppr new_ty))
+                                       (ppr term <+> text "::" <+> ppr new_ty))
                       -- we have unsound types. Replace constructor types in
                       -- subterms with tyvars
                       zterm' <- mapTermTypeM
@@ -634,7 +652,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
                                            Just (tc, _:_) | tc /= funTyCon
                                                -> newVar argTypeKind
                                            _   -> return ty)
-                                 zterm
+                                 term
                       zonkTerm zterm'
    traceTR (text "Term reconstruction completed." $$
             text "Term obtained: " <> ppr term $$
@@ -676,7 +694,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
          contents_tv <- newVar liftedTypeKind
          contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
          ASSERT(isUnliftedTypeKind $ typeKind my_ty) return ()
-         (mutvar_ty,_) <- instScheme $ sigmaType $ mkFunTy 
+         (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy 
                             contents_ty (mkTyConApp tycon [world,contents_ty])
          addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
          x <- go (pred max_depth) contents_tv contents_ty contents
@@ -780,9 +798,9 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
 cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type)
 cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
    traceTR (text "RTTI started with initial type " <> ppr old_ty)
-   let sigma_old_ty = sigmaType old_ty
+   let sigma_old_ty@(old_tvs, _) = quantifyType old_ty
    new_ty <-
-       if isMonomorphic sigma_old_ty
+       if null old_tvs
         then return old_ty
         else do
           (old_ty', rev_subst) <- instScheme sigma_old_ty
@@ -794,12 +812,12 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
                  (Seq.singleton (my_ty, hval))
                  max_depth
           new_ty <- zonkTcType my_ty
-          if isMonomorphic new_ty || check2 (sigmaType new_ty) sigma_old_ty
+          if isMonomorphic new_ty || check2 (quantifyType new_ty) sigma_old_ty
             then do
-                 traceTR (text "check2 passed")
+                 traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty)
                  addConstraint my_ty old_ty'
-                 new_ty' <- zonkTcType my_ty
-                 return (substTy rev_subst new_ty')
+                 applyRevSubst rev_subst
+                 zonkRttiType new_ty
             else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >>
                  return old_ty
    traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
@@ -846,7 +864,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
             -- It is vital for newtype reconstruction that the unification step
             -- is done right here, _before_ the subterms are RTTI reconstructed
             let myType         = mkFunTys subTtypes my_ty
-            (signatureType,_) <- instScheme(mydataConType dc)
+            (signatureType,_) <- instScheme (mydataConType dc)
             addConstraint myType signatureType
             return $ [ appArr (\e->(t,e)) (ptrs clos) i
                        | (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)]
@@ -856,36 +874,23 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
 -- improveType <base_type> <rtti_type>
 -- The types can contain skolem type variables, which need to be treated as normal vars.
 -- In particular, we want them to unify with things.
-improveRTTIType :: HscEnv -> RttiType -> RttiType -> IO (Maybe TvSubst)
-improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do
-    traceTR (text "improveRttiType" <+> fsep [ppr _ty, ppr rtti_ty])
-    (ty_tvs,  _, _)   <- tcInstType return ty
-    (ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty
-    (_, _, rtti_ty')  <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty)
-    _ <- captureConstraints (unifyType rtti_ty' ty')
-    tvs1_contents     <- zonkTcTyVars ty_tvs'
-    let subst = (uncurry zipTopTvSubst . unzip)
-                 [(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents
-                          , getTyVar_maybe ty /= Just tv
-                          --, not(isTyVarTy ty)
-                          ]
-    return subst
- where ty = sigmaType _ty
+improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TvSubst
+improveRTTIType _ base_ty new_ty
+  = U.tcUnifyTys (const U.BindMe) [base_ty] [new_ty]
 
 myDataConInstArgTys :: DataCon -> [Type] -> [Type]
 myDataConInstArgTys dc args
     | null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args
     | otherwise = dataConRepArgTys dc
 
-mydataConType :: DataCon -> Type
+mydataConType :: DataCon -> QuantifiedType
 -- ^ Custom version of DataCon.dataConUserType where we
 --    - remove the equality constraints
 --    - use the representation types for arguments, including dictionaries
 --    - keep the original result type
 mydataConType  dc
-  = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
-    mkFunTys arg_tys $
-    res_ty
+  = ( (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
+    , mkFunTys arg_tys res_ty )
   where univ_tvs   = dataConUnivTyVars dc
         ex_tvs     = dataConExTyVars dc
         eq_spec    = dataConEqSpec dc
@@ -1017,24 +1022,21 @@ If that is not the case, then we consider two conditions.
 
 -}
 
-check1 :: Type -> Bool
-check1 ty | (tvs, _, _) <- tcSplitSigmaTy ty = not $ any isHigherKind (map tyVarKind tvs)
+check1 :: QuantifiedType -> Bool
+check1 (tvs, _) = not $ any isHigherKind (map tyVarKind tvs)
  where
    isHigherKind = not . null . fst . splitKindFunTys
 
-check2 :: Type -> Type -> Bool
-check2 sigma_rtti_ty sigma_old_ty
+check2 :: QuantifiedType -> QuantifiedType -> Bool
+check2 (_, rtti_ty) (_, old_ty)
   | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty
   = case () of
       _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty
-        -> and$ zipWith check2 rttis olds
+        -> and$ zipWith check2 (map quantifyType rttis) (map quantifyType olds)
       _ | Just _ <- splitAppTy_maybe old_ty
         -> isMonomorphicOnNonPhantomArgs rtti_ty
       _ -> True
   | otherwise = True
-  where (_, _ , rtti_ty) = tcSplitSigmaTy sigma_rtti_ty
-        (_, _ , old_ty)  = tcSplitSigmaTy sigma_old_ty
-
 
 -- Dealing with newtypes
 --------------------------
@@ -1072,6 +1074,8 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
    go l r
  -- TyVar lhs inductive case
     | Just tv <- getTyVar_maybe l
+    , isTcTyVar tv
+    , isMetaTyVar tv
     = recoverTR (return r) $ do
          Indirect ty_v <- readMetaTyVar tv
          traceTR $ fsep [text "(congruence) Following indirect tyvar:",
@@ -1108,17 +1112,26 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
 
 
 zonkTerm :: Term -> TcM Term
-zonkTerm = foldTermM TermFoldM{
-              fTermM = \ty dc v tt -> zonkTcType ty    >>= \ty' ->
-                                      return (Term ty' dc v tt)
-             ,fSuspensionM = \ct ty v b -> zonkTcType ty >>= \ty ->
-                                           return (Suspension ct ty v b)
-             ,fNewtypeWrapM= \ty dc t -> zonkTcType ty >>= \ty' ->
-                                         return$ NewtypeWrap ty' dc t
-             ,fRefWrapM    = \ty t ->
-                               return RefWrap `ap` zonkTcType ty `ap` return t
-             ,fPrimM       = (return.) . Prim
-             }
+zonkTerm = foldTermM (TermFoldM
+             { fTermM = \ty dc v tt -> zonkRttiType ty    >>= \ty' ->
+                                       return (Term ty' dc v tt)
+             , fSuspensionM  = \ct ty v b -> zonkRttiType ty >>= \ty ->
+                                             return (Suspension ct ty v b)
+             , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' ->
+                                           return$ NewtypeWrap ty' dc t
+             , fRefWrapM     = \ty t -> return RefWrap  `ap` 
+                                        zonkRttiType ty `ap` return t
+             , fPrimM        = (return.) . Prim })
+
+zonkRttiType :: TcType -> TcM Type
+-- Zonk the type, replacing any unbound Meta tyvars
+-- by skolems, safely out of Meta-tyvar-land
+zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta) 
+  where
+    zonk_unbound_meta tv 
+      = ASSERT( isTcTyVar tv )
+        do { tv' <- skolemiseUnboundMetaTyVar RuntimeUnkSkol tv
+           ; return (mkTyVarTy tv') }
 
 --------------------------------------------------------------------------------
 -- Restore Class predicates out of a representation type
@@ -1137,7 +1150,7 @@ dictsView ty = ty
 -- Use only for RTTI types
 isMonomorphic :: RttiType -> Bool
 isMonomorphic ty = noExistentials && noUniversals
- where (tvs, _, ty')     = tcSplitSigmaTy ty
+ where (tvs, _, ty')  = tcSplitSigmaTy ty
        noExistentials = isEmptyVarSet (tyVarsOfType ty')
        noUniversals   = null tvs
 
@@ -1161,11 +1174,11 @@ tyConPhantomTyVars tc
   = tyConTyVars tc \\ dc_vars
 tyConPhantomTyVars _ = []
 
--- Is this defined elsewhere?
--- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
-sigmaType :: Type -> Type
-sigmaType ty = mkSigmaTy (varSetElems$ tyVarsOfType ty) [] ty
+type QuantifiedType = ([TyVar], Type)   -- Make the free type variables explicit
 
+quantifyType :: Type -> QuantifiedType
+-- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
+quantifyType ty = (varSetElems (tyVarsOfType ty), ty)
 
 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
 mapMif pred f xx = sequence $ mapMif_ pred f xx

compiler/main/HscMain.lhs

@@ -46,9 +46,10 @@ import CorePrep		( corePrepExpr )
 import Desugar          ( deSugarExpr )
 import SimplCore        ( simplifyExpr )
 import TcRnDriver	( tcRnStmt, tcRnExpr, tcRnType ) 
-import Type		( Type )
+import Type		( Type, tyVarsOfTypes )
 import PrelNames	( iNTERACTIVE )
 import {- Kind parts of -} Type		( Kind )
+import Id      	     	( idType )
 import CoreLint		( lintUnfolding )
 import DsMeta		( templateHaskellNames )
 import SrcLoc		( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan, noSrcSpan, unLoc )
@@ -1046,7 +1047,7 @@ compileExpr hsc_env srcspan ds_expr
 		-- ToDo: improve SrcLoc
 	; if lint_on then 
                 let ictxt = hsc_IC hsc_env
-                    tyvars = varSetElems (ic_tyvars ictxt)
+                    tyvars = varSetElems (tyVarsOfTypes (map idType (ic_tmp_ids ictxt)))
                 in
 		case lintUnfolding noSrcLoc tyvars prepd_expr of
 		   Just err -> pprPanic "compileExpr" err

compiler/main/HscTypes.lhs

@@ -123,7 +123,6 @@ import FamInstEnv	( FamInstEnv, FamInst )
 import Rules		( RuleBase )
 import CoreSyn		( CoreBind )
 import VarEnv
-import VarSet
 import Var
 import Id
 import Type		
@@ -1132,15 +1131,9 @@ data InteractiveContext
 	ic_rn_gbl_env :: GlobalRdrEnv,	-- ^ The contexts' cached 'GlobalRdrEnv', built from
 					-- 'ic_toplev_scope' and 'ic_exports'
 
-	ic_tmp_ids :: [Id],             -- ^ Names bound during interaction with the user.
+	ic_tmp_ids :: [Id]              -- ^ Names bound during interaction with the user.
                                         -- Later Ids shadow earlier ones with the same OccName.
 
-        ic_tyvars :: TyVarSet           -- ^ Skolem type variables free in
-                                        -- 'ic_tmp_ids'.  These arise at
-                                        -- breakpoints in a polymorphic 
-                                        -- context, where we have only partial
-                                        -- type information.
-
 #ifdef GHCI
         , ic_resume :: [Resume]         -- ^ The stack of breakpoint contexts
 #endif
@@ -1154,8 +1147,7 @@ emptyInteractiveContext
   = InteractiveContext { ic_toplev_scope = [],
 			 ic_exports = [],
 			 ic_rn_gbl_env = emptyGlobalRdrEnv,
-			 ic_tmp_ids = [],
-                         ic_tyvars = emptyVarSet
+			 ic_tmp_ids = []
 #ifdef GHCI
                          , ic_resume = []
 #endif
@@ -1169,29 +1161,20 @@ icPrintUnqual dflags ictxt = mkPrintUnqualified dflags (ic_rn_gbl_env ictxt)
 extendInteractiveContext
         :: InteractiveContext
         -> [Id]
-        -> TyVarSet
         -> InteractiveContext
-extendInteractiveContext ictxt ids tyvars
-  = ictxt { ic_tmp_ids =  snub((ic_tmp_ids ictxt \\ ids) ++ ids),
+extendInteractiveContext ictxt ids
+  = ictxt { ic_tmp_ids =  snub ((ic_tmp_ids ictxt \\ ids) ++ ids)
                           -- NB. must be this way around, because we want
                           -- new ids to shadow existing bindings.
-            ic_tyvars   = ic_tyvars ictxt `unionVarSet` tyvars }
+          }
     where snub = map head . group . sort
 
 substInteractiveContext :: InteractiveContext -> TvSubst -> InteractiveContext
 substInteractiveContext ictxt subst | isEmptyTvSubst subst = ictxt
-substInteractiveContext ictxt@InteractiveContext{ic_tmp_ids=ids} subst =
-   let ids'     = map (\id -> id `setIdType` substTy subst (idType id)) ids
-       subst_dom= varEnvKeys$ getTvSubstEnv subst
-       subst_ran= varEnvElts$ getTvSubstEnv subst
-       new_tvs  = [ tv | Just tv <- map getTyVar_maybe subst_ran]  
-       ic_tyvars'= (`delVarSetListByKey` subst_dom) 
-                 . (`extendVarSetList`   new_tvs)
-                   $ ic_tyvars ictxt
-    in ictxt { ic_tmp_ids = ids'
-             , ic_tyvars   = ic_tyvars' }
-
-          where delVarSetListByKey = foldl' delVarSetByKey
+substInteractiveContext ictxt@InteractiveContext{ic_tmp_ids=ids} subst 
+  = ictxt { ic_tmp_ids = map subst_ty ids }
+  where
+   subst_ty id = id `setIdType` substTy subst (idType id)
 \end{code}
 
 %************************************************************************

compiler/main/InteractiveEval.hs

@@ -29,8 +29,7 @@ module InteractiveEval (
 	showModule,
         isModuleInterpreted,
 	compileExpr, dynCompileExpr,
-        Term(..), obtainTermFromId, obtainTermFromVal, reconstructType,
-        skolemiseSubst, skolemiseTy
+        Term(..), obtainTermFromId, obtainTermFromVal, reconstructType
 #endif
         ) where
 
@@ -110,7 +109,7 @@ data Resume
        resumeThreadId  :: ThreadId,     -- thread running the computation
        resumeBreakMVar :: MVar (),   
        resumeStatMVar  :: MVar Status,
-       resumeBindings  :: ([Id], TyVarSet),
+       resumeBindings  :: [Id],
        resumeFinalIds  :: [Id],         -- [Id] to bind on completion
        resumeApStack   :: HValue,       -- The object from which we can get
                                         -- value of the free variables.
@@ -223,7 +222,7 @@ runStmt expr step =
                 liftIO $ sandboxIO dflags' statusMVar thing_to_run
               
         let ic = hsc_IC hsc_env
-            bindings = (ic_tmp_ids ic, ic_tyvars ic)
+            bindings = ic_tmp_ids ic
 
         case step of
           RunAndLogSteps ->
@@ -261,7 +260,7 @@ emptyHistory :: BoundedList History
 emptyHistory = nilBL 50 -- keep a log of length 50
 
 handleRunStatus :: GhcMonad m =>
-                   String-> ([Id], TyVarSet) -> [Id]
+                   String-> [Id] -> [Id]
                 -> MVar () -> MVar Status -> Status -> BoundedList History
                 -> m RunResult
 handleRunStatus expr bindings final_ids breakMVar statusMVar status
@@ -275,9 +274,12 @@ handleRunStatus expr bindings final_ids breakMVar statusMVar status
         (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack
                                                                mb_info
         let
-            resume = Resume expr tid breakMVar statusMVar 
-                              bindings final_ids apStack mb_info span 
-                              (toListBL history) 0
+            resume = Resume { resumeStmt = expr, resumeThreadId = tid
+                            , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar 
+                            , resumeBindings = bindings, resumeFinalIds = final_ids
+                            , resumeApStack = apStack, resumeBreakInfo = mb_info 
+                            , resumeSpan = span, resumeHistory = toListBL history
+                            , resumeHistoryIx = 0 }
             hsc_env2 = pushResume hsc_env1 resume
         --
         modifySession (\_ -> hsc_env2)
@@ -287,9 +289,7 @@ handleRunStatus expr bindings final_ids breakMVar statusMVar status
 	    Left e -> return (RunException e)
 	    Right hvals -> do
                 hsc_env <- getSession
-                let final_ic = extendInteractiveContext (hsc_IC hsc_env)
-                                        final_ids emptyVarSet
-                        -- the bound Ids never have any free TyVars
+                let final_ic = extendInteractiveContext (hsc_IC hsc_env) final_ids 
                     final_names = map idName final_ids
                 liftIO $ Linker.extendLinkEnv (zip final_names hvals)
                 hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
@@ -297,7 +297,7 @@ handleRunStatus expr bindings final_ids breakMVar statusMVar status
                 return (RunOk final_names)
 
 traceRunStatus :: GhcMonad m =>
-                  String -> ([Id], TyVarSet) -> [Id]
+                  String -> [Id] -> [Id]
                -> MVar () -> MVar Status -> Status -> BoundedList History
                -> m RunResult
 traceRunStatus expr bindings final_ids
@@ -457,9 +457,8 @@ resume canLogSpan step
         -- unbind the temporary locals by restoring the TypeEnv from
         -- before the breakpoint, and drop this Resume from the
         -- InteractiveContext.
-        let (resume_tmp_ids, resume_tyvars) = resumeBindings r
+        let resume_tmp_ids = resumeBindings r
             ic' = ic { ic_tmp_ids  = resume_tmp_ids,
-                       ic_tyvars   = resume_tyvars,
                        ic_resume   = rs }
         modifySession (\_ -> hsc_env{ hsc_IC = ic' })
         
@@ -471,8 +470,11 @@ resume canLogSpan step
         
         when (isStep step) $ liftIO setStepFlag
         case r of 
-          Resume expr tid breakMVar statusMVar bindings 
-              final_ids apStack info span hist _ -> do
+          Resume { resumeStmt = expr, resumeThreadId = tid
+                 , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
+                 , resumeBindings = bindings, resumeFinalIds = final_ids
+                 , resumeApStack = apStack, resumeBreakInfo = info, resumeSpan = span
+                 , resumeHistory = hist } -> do
                withVirtualCWD $ do
                 withBreakAction (isStep step) (hsc_dflags hsc_env) 
                                         breakMVar statusMVar $ do
@@ -563,10 +565,9 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do
        e_name    = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
        e_tyvar   = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
        exn_id    = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
-       new_tyvars = unitVarSet e_tyvar
 
        ictxt0 = hsc_IC hsc_env
-       ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars
+       ictxt1 = extendInteractiveContext ictxt0 [exn_id]
 
        span = mkGeneralSrcSpan (fsLit "<exception thrown>")
    --
@@ -616,9 +617,6 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
        result_id   = Id.mkVanillaGlobal 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).
    --
@@ -627,12 +625,11 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
 
        all_ids | result_ok = result_id : new_ids
                | otherwise = new_ids
-       (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
+       id_tys = map idType all_ids
        (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
-       new_tyvars = unionVarSets tyvarss             
        final_ids = zipWith setIdType all_ids tidy_tys
        ictxt0 = hsc_IC hsc_env
-       ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
+       ictxt1 = extendInteractiveContext ictxt0 final_ids