X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FRtClosureInspect.hs;h=cb16c1d39d8f32cd2b4f290f6129752fb98b1755;hb=4fc2ca8222ca4625132ad5acf3afeb8293e42a46;hp=649e59dc7a15da766cff365e899a5dc80b9a27e6;hpb=3d5970436af5ab73957278671059e00d1a52c616;p=ghc-hetmet.git

diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 649e59d..cb16c1d 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -31,7 +31,7 @@ module RtClosureInspect(
      termTyVars,
 --     unsafeDeepSeq, 
      cvReconstructType,
-     unifyRTTI, 
+     improveRTTIType,
      sigmaType,
      Closure(..),
      getClosureData,
@@ -55,7 +55,6 @@ import TcType
 import TcMType
 import TcUnify
 import TcEnv
-import Unify
 import DriverPhases
 import TyCon
 import Name
@@ -90,6 +89,7 @@ import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
 import Foreign
 import System.IO.Unsafe
 
+import System.IO
 ---------------------------------------------
 -- * A representation of semi evaluated Terms
 ---------------------------------------------
@@ -377,7 +377,7 @@ ppr_termM1 Prim{value=words, ty=ty} =
     return$ text$ repPrim (tyConAppTyCon ty) words
 ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
-  | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
+  | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit "<function>")
   | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
 ppr_termM1 Term{}        = panic "ppr_termM1 - Term"
 ppr_termM1 RefWrap{}     = panic "ppr_termM1 - RefWrap"
@@ -535,7 +535,7 @@ runTR hsc_env c = do
     Just x  -> return x
 
 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
-runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
+runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False  iNTERACTIVE
 
 traceTR :: SDoc -> TR ()
 traceTR = liftTcM . traceTc
@@ -547,7 +547,7 @@ liftTcM :: TcM a -> TR a
 liftTcM = id
 
 newVar :: Kind -> TR TcType
-newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
+newVar = liftTcM . fmap mkTyVarTy . newBoxyTyVar
 
 -- | Returns the instantiated type scheme ty', and the substitution sigma 
 --   such that sigma(ty') = ty 
@@ -562,7 +562,7 @@ instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
 -- Before unification, congruenceNewtypes needs to
 -- do its magic.
 addConstraint :: TcType -> TcType -> TR ()
-addConstraint t1 t2  = congruenceNewtypes t1 t2 >>= uncurry unifyType 
+addConstraint t1 t2  = congruenceNewtypes t1 t2 >>= uncurry boxyUnify 
 		       >> return () -- TOMDO: what about the coercion?
 				    -- we should consider family instances 
 
@@ -670,11 +670,11 @@ cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
   reOrderTerms _ _ [] = []
   reOrderTerms pointed unpointed (ty:tys) 
    | isPointed ty = ASSERT2(not(null pointed)
-                            , ptext SLIT("reOrderTerms") $$ 
+                            , ptext (sLit "reOrderTerms") $$ 
                                         (ppr pointed $$ ppr unpointed))
                     let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
    | otherwise    = ASSERT2(not(null unpointed)
-                           , ptext SLIT("reOrderTerms") $$ 
+                           , ptext (sLit "reOrderTerms") $$ 
                                        (ppr pointed $$ ppr unpointed))
                     let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
   
@@ -762,26 +762,26 @@ cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
                                      zip [0..] (filter isPointed subTtypes)]
       _ -> return []
 
-{-
- This helper computes the difference between a base type t and the 
- improved rtti_t computed by RTTI
- The main difference between RTTI types and their normal counterparts
- is that the former are _not_ polymorphic, thus polymorphism must
- be stripped. Syntactically, forall's must be stripped.
- We also remove predicates.
--}
-unifyRTTI :: Type -> Type -> TvSubst
-unifyRTTI ty rtti_ty = 
-    case mb_subst of
-      Just subst -> subst
-      Nothing    -> pprPanic "Failed to compute a RTTI substitution" 
-                             (ppr (ty, rtti_ty))
-     -- In addition, we strip newtypes too, since the reconstructed type might
-     --   not have recovered them all
-     -- TODO stripping newtypes shouldn't be necessary, test
-   where mb_subst = tcUnifyTys (const BindMe) 
-                               [rttiView ty]
-                               [rttiView rtti_ty]  
+-- Compute the difference between a base type and the type found by RTTI
+-- 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 -> Type -> Type -> IO (Maybe TvSubst)
+improveRTTIType hsc_env ty rtti_ty = runTR_maybe hsc_env $ do
+    let (_,ty0)     = splitForAllTys ty
+        ty_tvs      = varSetElems $ tyVarsOfType ty0
+    let (_,rtti_ty0)= splitForAllTys rtti_ty
+        rtti_tvs    = varSetElems $ tyVarsOfType rtti_ty0
+    (ty_tvs',_,ty')<- tcInstType (mapM tcInstTyVar) (mkSigmaTy ty_tvs   [] ty0)
+    (_,_,rtti_ty') <- tcInstType (mapM tcInstTyVar) (mkSigmaTy rtti_tvs [] rtti_ty0)
+    boxyUnify rtti_ty' ty'
+    tvs1_contents  <- zonkTcTyVars ty_tvs'
+    let subst = uncurry zipTopTvSubst
+                  (unzip [(tv,ty) | tv <- ty_tvs, ty <- tvs1_contents
+                                  , getTyVar_maybe ty /= Just tv
+                                  , not(isTyVarTy ty)])
+--    liftIO $ hPutStrLn stderr $ showSDocDebug $ text "unify " <+> sep [ppr ty, ppr rtti_ty, equals, ppr subst ]
+    return subst
 
 -- Dealing with newtypes
 {-