Fix a couple of issues with :print

      
      - Ticket #1995: Unsoundness with newtypes
      - Ticket #2475: "Can't unify" error when stopped at an exception
      
      In addition this patch adds the following:
      
      - Unfailingness: RTTI cannot panic anymore. 
        In case of failure, it recovers gracefully by returning the "I know nothing" type
      - A -ddump-rtti flag

compiler/ghci/Debugger.hs

@@ -53,13 +53,15 @@ pprintClosureCommand bindThings force str = do
   let ids = [id | AnId id <- tythings]
 
   -- Obtain the terms and the recovered type information
-  (terms, substs) <- unzip `liftM` mapM go ids
-  
+  (terms, substs0) <- unzip `liftM` mapM go ids
+
   -- Apply the substitutions obtained after recovering the types
   modifySession $ \hsc_env ->
-         hsc_env{hsc_IC = foldr (flip substInteractiveContext)
-                                (hsc_IC hsc_env)
-                                (map skolemiseSubst substs)}
+    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'}
   -- Finally, print the Terms
   unqual  <- GHC.getPrintUnqual
   docterms <- mapM showTerm terms
@@ -68,13 +70,12 @@ pprintClosureCommand bindThings force str = do
                     ids
                     docterms)
  where
-
    -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
    go :: GhcMonad m => Id -> m (Term, TvSubst)
    go id = do
-       term_    <- GHC.obtainTerm force id
+       term_    <- GHC.obtainTermFromId maxBound force id
        term     <- tidyTermTyVars term_
-       term'    <- if bindThings && 
+       term'    <- if bindThings &&
                       False == isUnliftedTypeKind (termType term)
                      then bindSuspensions term
                      else return term
@@ -84,6 +85,11 @@ pprintClosureCommand bindThings force str = do
        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)
 
    tidyTermTyVars :: GhcMonad m => Term -> m Term
@@ -110,11 +116,10 @@ bindSuspensions t = do
       availNames_var  <- liftIO $ newIORef availNames
       (t', stuff)     <- liftIO $ foldTerm (nameSuspensionsAndGetInfos availNames_var) t
       let (names, tys, hvals) = unzip3 stuff
-      let tys' = map (fst.skolemiseTy) tys
+          (tys', skol_vars)   = unzip $ map skolemiseTy tys
       let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
                 | (name,ty) <- zip names tys']
-          new_tyvars   = tyVarsOfTypes tys'
-          new_ic       = extendInteractiveContext ictxt ids new_tyvars
+          new_ic = extendInteractiveContext ictxt ids (unionVarSets skol_vars)
       liftIO $ extendLinkEnv (zip names hvals)
       modifySession $ \_ -> hsc_env {hsc_IC = new_ic }
       return t'
@@ -194,7 +199,7 @@ showTerm term = do
     name <- newGrimName userName
     let ictxt    = hsc_IC hsc_env
         tmp_ids  = ic_tmp_ids ictxt
-        id       = mkGlobalId VanillaGlobal name (sigmaType ty) vanillaIdInfo
+        id       = mkGlobalId VanillaGlobal name ty vanillaIdInfo
         new_ic   = ictxt { ic_tmp_ids = id : tmp_ids }
     return (hsc_env {hsc_IC = new_ic }, name)
 
@@ -215,9 +220,17 @@ pprTypeAndContents ids = do
   if pcontents 
     then do
       let depthBound = 100
-      terms      <- mapM (GHC.obtainTermB depthBound False) ids
+      terms      <- mapM (GHC.obtainTermFromId depthBound False) ids
       docs_terms <- mapM showTerm terms
       return $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
                              (map (pprTyThing pefas . AnId) ids)
                              docs_terms
     else return $  vcat $ map (pprTyThing pefas . AnId) ids
+
+--------------------------------------------------------------
+-- Utils 
+
+traceOptIf :: GhcMonad m => DynFlag -> SDoc -> m ()
+traceOptIf flag doc = do
+  dflags <- GHC.getSessionDynFlags
+  when (dopt flag dflags) $ liftIO $ printForUser stderr alwaysQualify doc

compiler/main/DynFlags.hs

@@ -145,6 +145,7 @@ data DynFlag
    | Opt_D_dump_BCOs
    | Opt_D_dump_vect
    | Opt_D_dump_hpc
+   | Opt_D_dump_rtti
    | Opt_D_source_stats
    | Opt_D_verbose_core2core
    | Opt_D_verbose_stg2stg
@@ -1357,6 +1358,8 @@ dynamic_flags = [
          Supported
   , Flag "ddump-hi-diffs"          (setDumpFlag Opt_D_dump_hi_diffs)
          Supported
+  , Flag "ddump-rtti"      	   (setDumpFlag Opt_D_dump_rtti)
+         Supported
 
   , Flag "dcore-lint"              (NoArg (setDynFlag Opt_DoCoreLinting))
          Supported

compiler/main/GHC.hs

@@ -106,7 +106,7 @@ module GHC (
         isModuleInterpreted,
 	InteractiveEval.compileExpr, HValue, dynCompileExpr,
 	lookupName,
-        GHC.obtainTerm, GHC.obtainTerm1, GHC.obtainTermB, reconstructType,
+        GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
         modInfoModBreaks,
         ModBreaks(..), BreakIndex,
         BreakInfo(breakInfo_number, breakInfo_module),
@@ -2555,18 +2555,14 @@ getHistorySpan :: GhcMonad m => History -> m SrcSpan
 getHistorySpan h = withSession $ \hsc_env ->
                           return$ InteractiveEval.getHistorySpan hsc_env h
 
-obtainTerm :: GhcMonad m => Bool -> Id -> m Term
-obtainTerm force id = withSession $ \hsc_env ->
-                        liftIO $ InteractiveEval.obtainTerm hsc_env force id
-
-obtainTerm1 :: GhcMonad m => Bool -> Maybe Type -> a -> m Term
-obtainTerm1 force mb_ty a =
+obtainTermFromVal :: GhcMonad m => Int ->  Bool -> Type -> a -> m Term
+obtainTermFromVal bound force ty a =
     withSession $ \hsc_env ->
-      liftIO $ InteractiveEval.obtainTerm1 hsc_env force mb_ty a
+      liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
 
-obtainTermB :: GhcMonad m => Int -> Bool -> Id -> m Term
-obtainTermB bound force id =
+obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
+obtainTermFromId bound force id =
     withSession $ \hsc_env ->
-      liftIO $ InteractiveEval.obtainTermB hsc_env bound force id
+      liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
 
 #endif

compiler/main/HscTypes.lhs

@@ -1089,11 +1089,11 @@ extendInteractiveContext
         -> TyVarSet
         -> InteractiveContext
 extendInteractiveContext ictxt ids tyvars
-  = ictxt { ic_tmp_ids =  ic_tmp_ids 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

compiler/main/InteractiveEval.hs

@@ -30,7 +30,7 @@ module InteractiveEval (
         isModuleInterpreted,
 	compileExpr, dynCompileExpr,
 	lookupName,
-        Term(..), obtainTerm, obtainTerm1, obtainTermB, reconstructType,
+        Term(..), obtainTermFromId, obtainTermFromVal, reconstructType,
         skolemiseSubst, skolemiseTy
 #endif
         ) where
@@ -83,6 +83,7 @@ import Exception
 import Control.Concurrent
 import Data.List (sortBy)
 import Foreign.StablePtr
+import System.IO
 
 -- -----------------------------------------------------------------------------
 -- running a statement interactively
@@ -637,26 +638,46 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
    let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
        incompletelyTypedIds = 
            [id | id <- tmp_ids
-               , not $ null [v | v <- varSetElems$ tyVarsOfType (idType id)
-                              , isSkolemTyVar v]
+               , not $ noSkolems id
                , (occNameFS.nameOccName.idName) id /= result_fs]
-   tys <- reconstructType hsc_env 10 `mapM` incompletelyTypedIds
-          -- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds)
-   
-   improvs <- sequence [improveRTTIType hsc_env ty ty'
-                 | (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys]
-   let ic' = foldr (\mb_subst ic' ->
-                        maybe (WARN(True, text ("RTTI failed to calculate the "
-                                           ++  "improvement for a type")) ic')
-                              (substInteractiveContext ic' . skolemiseSubst)
-                              mb_subst)
-                   ic
-                   improvs
-   return hsc_env{hsc_IC=ic'}
-
-skolemiseSubst :: TvSubst -> TvSubst
-skolemiseSubst subst = subst `setTvSubstEnv` 
-                        mapVarEnv (fst.skolemiseTy) (getTvSubstEnv subst)
+   hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
+   return hsc_env'
+    where
+     noSkolems = null . filter isSkolemTyVar . varSetElems . 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
+              mb_subst <- improveRTTIType hsc_env old_ty new_ty
+              case mb_subst 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 (subst', skols) = skolemiseSubst subst
+                     ic' = extendInteractiveContext
+                               (substInteractiveContext ic subst') [] skols
+                 return hsc_env{hsc_IC=ic'}
+
+skolemiseSubst :: TvSubst -> (TvSubst, TyVarSet)
+skolemiseSubst subst = let
+    varenv               = getTvSubstEnv subst
+    all_together         = mapVarEnv skolemiseTy varenv
+    (varenv', skol_vars) = ( mapVarEnv fst all_together
+                           , map snd (varEnvElts all_together))
+    in (subst `setTvSubstEnv` varenv', unionVarSets skol_vars)
+                        
 
 skolemiseTy :: Type -> (Type, TyVarSet)
 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
@@ -969,23 +990,20 @@ isModuleInterpreted mod_summary = withSession $ \hsc_env ->
 ----------------------------------------------------------------------------
 -- RTTI primitives
 
-obtainTerm1 :: HscEnv -> Bool -> Maybe Type -> a -> IO Term
-obtainTerm1 hsc_env force mb_ty x = 
-              cvObtainTerm hsc_env maxBound force mb_ty (unsafeCoerce# x)
+obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
+obtainTermFromVal hsc_env bound force ty x =
+              cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
 
-obtainTermB :: HscEnv -> Int -> Bool -> Id -> IO Term
-obtainTermB hsc_env bound force id =  do
-              hv <- Linker.getHValue hsc_env (varName id) 
-              cvObtainTerm hsc_env bound force (Just$ idType id) hv
-
-obtainTerm :: HscEnv -> Bool -> Id -> IO Term
-obtainTerm hsc_env force id =  do
-              hv <- Linker.getHValue hsc_env (varName id) 
-              cvObtainTerm hsc_env maxBound force (Just$ idType id) hv
+obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
+obtainTermFromId hsc_env bound force id =  do
+              hv <- Linker.getHValue hsc_env (varName id)
+              cvObtainTerm hsc_env bound force (idType id) hv
 
 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
 reconstructType hsc_env bound id = do
               hv <- Linker.getHValue hsc_env (varName id) 
-              cvReconstructType hsc_env bound (Just$ idType id) hv
+              cvReconstructType hsc_env bound (idType id) hv
+
 #endif /* GHCI */
+