We no longer instantiate tyvars to Unknown types in the :print mechanism

Instead, we keep the original tyvars.
The plan is to exploit type relationships among closures to recover more types.

compiler/ghci/Debugger.hs

@@ -62,12 +62,11 @@ pprintClosureCommand bindThings force str = do
   mb_new_ids <- mapM (io . go cms) (catMaybes mb_ids)
   io$ updateIds cms (catMaybes mb_new_ids)
  where 
-   -- Find the Id, clean up 'Unknowns' in the idType
+   -- Find the Id
    cleanUp :: Session -> [Name] -> String -> IO (Maybe Id)
    cleanUp cms newNames str = do
      tythings <- GHC.parseName cms str >>= mapM (GHC.lookupName cms)
-     return$ listToMaybe (map (stripUnknowns newNames) 
-                              [ i | Just (AnId i) <- tythings]) 
+     return$ listToMaybe [ i | Just (AnId i) <- tythings]
 
    -- Do the obtainTerm--bindSuspensions-refineIdType dance
    -- Warning! This function got a good deal of side-effects
@@ -83,10 +82,8 @@ pprintClosureCommand bindThings force str = do
                showDocWith LeftMode (doc (mkErrStyle unqual))
        (putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm)
      -- Before leaving, we compare the type obtained to see if it's more specific
-     -- Note how we need the Unknown-clear type returned by obtainTerm
        let Just reconstructedType = termType term  
-       new_type  <- instantiateTyVarsToUnknown cms 
-                    (mostSpecificType (idType id) reconstructedType)
+           new_type = mostSpecificType (idType id) reconstructedType
        return . Just $ setIdType id new_type
 
    updateIds :: Session -> [Id] -> IO ()
@@ -129,9 +126,8 @@ bindSuspensions cms@(Session ref) t = do
       availNames_var  <- newIORef availNames
       (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
       let (names, tys, hvals) = unzip3 stuff
-      concrete_tys    <- mapM (instantiateTyVarsToUnknown cms) tys
       let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
-                  | (name,ty) <- zip names concrete_tys]
+                  | (name,ty) <- zip names tys]
           new_type_env = extendTypeEnvWithIds type_env ids 
           new_rn_env   = extendLocalRdrEnv rn_env names
           new_ic       = ictxt { ic_rn_local_env = new_rn_env, 
@@ -208,45 +204,3 @@ newGrimName cms userName  = do
         occname = mkOccName varName userName
         name    = mkInternalName unique occname noSrcLoc
     return name
-
--- | The inverse function. Strip the GHC.Base.Unknowns in the type of the id, they correspond to tyvars. The caller must provide an infinite list of fresh names
-stripUnknowns :: [Name] -> Id -> Id
-stripUnknowns names id = setIdType id . fst . go names . idType 
-                           $ id
- where 
-   go tyvarsNames@(v:vv) ty 
-    | Just (ty1,ty2) <- splitFunTy_maybe ty = let
-               (ty1',vv') = go tyvarsNames ty1
-               (ty2',vv'')= go vv' ty2
-               in (mkFunTy ty1' ty2', vv'')
-    | Just (ty1,ty2) <- splitAppTy_maybe ty = let
-               (ty1',vv') = go tyvarsNames ty1
-               (ty2',vv'')= go vv' ty2
-               in (mkAppTy ty1' ty2', vv'')
-    | Just (tycon, args) <- splitTyConApp_maybe ty 
-    , Just (tycon', vv') <- (fixTycon tycon tyvarsNames)
-    , (args',vv'') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg 
-                                             in (arg':aa,vv'))
-                            ([],vv') args
-    = (mkAppTys tycon' args',vv'')
-    | Just (tycon, args) <- splitTyConApp_maybe ty
-    , (args',vv') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg 
-                                            in (arg':aa,vv'))
-                           ([],tyvarsNames) args
-    = (mkTyConApp tycon args',vv')
-    | otherwise = (ty, tyvarsNames)
-    where  fixTycon tycon (v:vv) = do
-               k <- lookup (tyConName tycon) kinds
-               return (mkTyVarTy$ mkTyVar v k, vv)
-           kinds = [ (unknownTyConName, liftedTypeKind)
-                   , (unknown1TyConName, kind1)
-                   , (unknown2TyConName, kind2)
-                   , (unknown3TyConName, kind3)]
-           kind1 = mkArrowKind liftedTypeKind liftedTypeKind
-           kind2 = mkArrowKind kind1 liftedTypeKind
-           kind3 = mkArrowKind kind2 liftedTypeKind
-
-instantiateTyVarsToUnknown :: Session -> Type -> IO Type
-instantiateTyVarsToUnknown (Session ref) ty
-  = do hsc_env <- readIORef ref
-       DebuggerTys.instantiateTyVarsToUnknown hsc_env ty

compiler/ghci/DebuggerTys.hs

------------------------------------------------------------------------------
---
--- GHCi Interactive debugging commands 
---
--- Pepe Iborra (supported by Google SoC) 2006
---
------------------------------------------------------------------------------
-
-module DebuggerTys (instantiateTyVarsToUnknown) where
-
-import HscTypes
-import Type
-import TcRnDriver
-import Var
-import PrelNames
-import TyCon
-import DataCon
-
-import Control.Monad
-
-----------------------------------------------------------------------------
--- | Replace all the tyvars in a Term with the opaque type GHC.Base.Unknown
-----------------------------------------------------------------------------
-instantiateTyVarsToUnknown :: HscEnv -> Type -> IO Type
-instantiateTyVarsToUnknown hsc_env ty
--- We have a GADT, so just fix its tyvars
-    | Just (tycon, args) <- splitTyConApp_maybe ty
-    , tycon /= funTyCon
-    , isGADT tycon
-    = mapM fixTyVars args >>= return . mkTyConApp tycon
--- We have a regular TyCon, so map recursively to its args
-    | Just (tycon, args) <- splitTyConApp_maybe ty
-    , tycon /= funTyCon
-    = do unknownTyVar <- unknownTV
-         args' <- mapM (instantiateTyVarsToUnknown hsc_env) args
-         return$ mkTyConApp tycon args'
--- we have a tyvar of kind *
-    | Just tyvar <- getTyVar_maybe ty
-    , ([],_) <- splitKindFunTys (tyVarKind tyvar) 
-    = unknownTV
--- we have a higher kind tyvar, so insert an unknown of the appropriate kind
-    | Just tyvar <- getTyVar_maybe ty
-    , (args,_) <- splitKindFunTys (tyVarKind tyvar)
-    = liftM mkTyConTy $ unknownTC !! length args
--- Base case
-    | otherwise    = return ty 
-
- where unknownTV = do 
-         Just (ATyCon unknown_tc) <- tcRnLookupName hsc_env unknownTyConName
-         return$ mkTyConTy unknown_tc
-       unknownTC = [undefined, unknownTC1, unknownTC2, unknownTC3]
-       unknownTC1 = do 
-         Just (ATyCon unknown_tc) <- tcRnLookupName hsc_env unknown1TyConName
-         return unknown_tc
-       unknownTC2 = do 
-         Just (ATyCon unknown_tc) <- tcRnLookupName hsc_env unknown2TyConName
-         return unknown_tc
-       unknownTC3 = do 
-         Just (ATyCon unknown_tc) <- tcRnLookupName hsc_env unknown3TyConName
-         return unknown_tc
---       isGADT ty | pprTrace' "isGADT" (ppr ty <> colon <> ppr(isGadtSyntaxTyCon ty)) False = undefined
-       isGADT tc | Just dcs <- tyConDataCons_maybe tc = any (not . null . dataConEqSpec) dcs
-                 | otherwise = False
-       fixTyVars ty 
-           | Just (tycon, args) <- splitTyConApp_maybe ty
-           = mapM fixTyVars args >>= return . mkTyConApp tycon
--- Fix the tyvar so that the interactive environment doesn't choke on it TODO 
-           | Just tv <- getTyVar_maybe ty = return ty --TODO
-           | otherwise = return ty
-

compiler/ghci/RtClosureInspect.hs

@@ -464,10 +464,12 @@ newVar = liftTcM . newFlexiTyVar
 
 liftTcM = id
 
-instScheme :: Type -> TR TcType
-instScheme ty = liftTcM$ liftM trd (tcInstType (liftM fst3 . tcInstTyVars) ty)
-    where fst3 (x,y,z) = x
-          trd  (x,y,z) = z
+-- | Returns the instantiated type scheme ty', and the substitution sigma 
+--   such that sigma(ty') = ty 
+instScheme :: Type -> TR (TcType, TvSubst)
+instScheme ty | (tvs, rho) <- tcSplitForAllTys ty = liftTcM$ do
+   (tvs',theta,ty') <- tcInstType (mapM tcInstTyVar) ty
+   return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
 
 cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
 cvObtainTerm hsc_env force mb_ty a = do
@@ -488,14 +490,19 @@ cvObtainTerm hsc_env force mb_ty a = do
 
 cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
 cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
-   tv <- case (isMonomorphic `fmap` mb_ty) of
-          Just True -> return (fromJust mb_ty)
-          _         -> do
-            tv_ <- liftM mkTyVarTy (newVar argTypeKind)
-            when (isJust mb_ty) $ 
-                 instScheme (sigmaType$ fromJust mb_ty) >>= addConstraint tv_
-            return tv_
-   go tv (fromMaybe tv mb_ty) hval
+   tv <- liftM mkTyVarTy (newVar argTypeKind)
+   case mb_ty of
+     Nothing -> go tv tv hval
+     Just ty | isMonomorphic ty -> go ty ty hval
+     Just ty -> do 
+              (ty',rev_subst) <- instScheme (sigmaType$ fromJust mb_ty)
+              addConstraint tv ty'
+              term <- go tv tv hval
+              --restore original Tyvars
+              return$ flip foldTerm term idTermFold {
+                fTerm = \ty dc hval tt -> Term (substTy rev_subst ty) dc hval tt,
+                fSuspension = \ct mb_ty hval n -> 
+                          Suspension ct (substTy rev_subst `fmap` mb_ty) hval n}
     where 
   go tv ty a = do 
     let monomorphic = not(isTyVarTy tv)   -- This is a convention. The ancestor tests for
@@ -522,7 +529,7 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
             --     right here, _before_ the subterms are RTTI reconstructed.
             when (not monomorphic) $ do
                   let myType = mkFunTys (reOrderTerms subTermTvs subTtypesNP subTtypes) tv
-                  instScheme(dataConRepType dc) >>= addConstraint myType 
+                  instScheme(dataConRepType dc) >>= addConstraint myType . fst
             subTermsP <- sequence $ drop extra_args -- all extra arguments are pointed
                   [ appArr (go tv t) (ptrs clos) i
                    | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]

compiler/main/GHC.hs

@@ -2310,7 +2310,7 @@ extendEnvironment hsc_env apStack idsOffsets = do
    let (ids, hValues) = unzip idsVals 
    let names = map idName ids
    let global_ids = map globaliseAndTidy ids
-   typed_ids  <- mapM instantiateIdType global_ids
+   typed_ids  <- return global_ids -- mapM instantiateIdType global_ids
    let ictxt = hsc_IC hsc_env
        rn_env   = ic_rn_local_env ictxt
        type_env = ic_type_env ictxt
@@ -2334,12 +2334,6 @@ extendEnvironment hsc_env apStack idsOffsets = do
       = let tidied_type = tidyTopType$ idType id
         in setIdType (globaliseId VanillaGlobal id) tidied_type
 
-   -- | Instantiate the tyVars with GHC.Base.Unknown
-   instantiateIdType :: Id -> IO Id
-   instantiateIdType id = do
-      instantiatedType <- instantiateTyVarsToUnknown hsc_env (idType id)
-      return$ setIdType id instantiatedType
-
 -----------------------------------------------------------------------------
 -- show a module and it's source/object filenames