X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FRtClosureInspect.hs;h=f289b14adedc6941c9a76ea00b0073cbb27fbfe9;hb=347780ec5f2a3c77e58ab7c6cd06b7557f44a82c;hp=45c5b0fa27d995c07ba37722b86bf97c2d3be74a;hpb=b5986072833796acb374e22f18cef8ab839a3419;p=ghc-hetmet.git

diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 45c5b0f..f289b14 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -22,6 +22,8 @@ module RtClosureInspect(
      isFullyEvaluated, 
      isPointed,
      isFullyEvaluatedTerm,
+     mapTermType,
+     termTyVars
 --     unsafeDeepSeq, 
  ) where 
 
@@ -66,7 +68,7 @@ import GHC.Word         ( Word32(..), Word64(..) )
 import Control.Monad
 import Data.Maybe
 import Data.Array.Base
-import Data.List        ( partition )
+import Data.List        ( partition, nub )
 import Foreign.Storable
 
 import IO
@@ -284,6 +286,18 @@ idTermFoldM = TermFold {
               fSuspension = (((return.).).). Suspension
                        }
 
+mapTermType f = foldTerm idTermFold {
+          fTerm       = \ty dc hval tt -> Term (f ty) dc hval tt,
+          fSuspension = \ct mb_ty hval n ->
+                          Suspension ct (fmap f mb_ty) hval n }
+
+termTyVars = foldTerm TermFold {
+            fTerm       = \ty _ _ tt   -> 
+                          tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
+            fSuspension = \_ mb_ty _ _ -> 
+                          maybe emptyVarEnv tyVarsOfType mb_ty,
+            fPrim       = \ _ _ -> emptyVarEnv }
+    where concatVarEnv = foldr plusVarEnv emptyVarEnv
 ----------------------------------
 -- Pretty printing of terms
 ----------------------------------
@@ -374,7 +388,7 @@ type TR a = TcM a
 
 runTR :: HscEnv -> TR Term -> IO Term
 runTR hsc_env c = do 
-  mb_term <- initTcPrintErrors hsc_env iNTERACTIVE (c >>= zonkTerm)
+  mb_term <- initTcPrintErrors hsc_env iNTERACTIVE c
   case mb_term of 
     Nothing -> panic "Can't unify"
     Just term -> return term
@@ -472,37 +486,17 @@ instScheme ty | (tvs, rho) <- tcSplitForAllTys ty = liftTcM$ do
    return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
 
 cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
-cvObtainTerm hsc_env force mb_ty a = do
-   -- Obtain the term and tidy the type before returning it
-   term <- cvObtainTerm1 hsc_env force mb_ty a
-   return $ tidyTypes term
-   where 
-         tidyTypes = foldTerm idTermFold {
-            fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt,
-            fSuspension = \ct mb_ty hval n -> 
-                          Suspension ct (fmap tidy mb_ty) hval n
-            }
-         tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv ty) ty  
-         tidyVarEnv ty = mkVarEnv$ 
-                         [ (v, setTyVarName v (tyVarName tv))
-                           | (tv,v) <- zip alphaTyVars vars]
-             where vars = varSetElems$ tyVarsOfType ty
-
-cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
-cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
+cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
    tv <- liftM mkTyVarTy (newVar argTypeKind)
    case mb_ty of
-     Nothing -> go tv tv hval
-     Just ty | isMonomorphic ty -> go ty ty hval
+     Nothing -> go tv tv hval >>= zonkTerm
+     Just ty | isMonomorphic ty -> go ty ty hval >>= zonkTerm
      Just ty -> do 
               (ty',rev_subst) <- instScheme (sigmaType ty)
               addConstraint tv ty'
-              term <- go tv tv hval
+              term <- go tv tv hval >>= zonkTerm
               --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}
+              return$ mapTermType (substTy rev_subst) term
     where 
   go tv ty a = do 
     let monomorphic = not(isTyVarTy tv)   -- This is a convention. The ancestor tests for
@@ -510,6 +504,9 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
     clos <- trIO $ getClosureData a
     case tipe clos of
 -- Thunks we may want to force
+-- NB. this won't attempt to force a BLACKHOLE.  Even with :force, we never
+-- force blackholes, because it would almost certainly result in deadlock,
+-- and showing the '_' is more useful.
       t | isThunk t && force -> seq a $ go tv ty a
 -- We always follow indirections 
       Indirection _ -> go tv ty $! (ptrs clos ! 0)
@@ -565,7 +562,8 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
                            , ptext SLIT("reOrderTerms") $$ (ppr pointed $$ ppr unpointed))
                     head unpointed : reOrderTerms pointed (tail unpointed) tys
 
-isMonomorphic = isEmptyVarSet . tyVarsOfType
+isMonomorphic ty | isForAllTy ty = False
+isMonomorphic ty = (isEmptyVarSet . tyVarsOfType) ty
 
 zonkTerm :: Term -> TcM Term
 zonkTerm = foldTerm idTermFoldM {