X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FRtClosureInspect.hs;h=ef25ad5644873f0abfb0afbdb4332e3d9ab52642;hb=2060788524c41ae87ba87276cb59e7cab574fe68;hp=f90b1ca03ce44019da5a5b9884d9073440616a4d;hpb=1c83695b5b9ae3175c18908c1d58aeadb1f225ae;p=ghc-hetmet.git

diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index f90b1ca..ef25ad5 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -54,7 +54,7 @@ import TysWiredIn
 import DynFlags
 import Outputable
 import FastString
-import Panic
+-- import Panic
 
 import Constants        ( wORD_SIZE )
 
@@ -74,11 +74,10 @@ import Data.Ix
 import Data.List
 import qualified Data.Sequence as Seq
 import Data.Monoid
-import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
-import Foreign
+import Data.Sequence (viewl, ViewL(..))
+import Foreign hiding (unsafePerformIO)
 import System.IO.Unsafe
 
-import System.IO
 ---------------------------------------------
 -- * A representation of semi evaluated Terms
 ---------------------------------------------
@@ -166,7 +165,7 @@ data Closure = Closure { tipe         :: ClosureType
 instance Outputable ClosureType where
   ppr = text . show 
 
-#include "../includes/ClosureTypes.h"
+#include "../includes/rts/storage/ClosureTypes.h"
 
 aP_CODE, pAP_CODE :: Int
 aP_CODE = AP
@@ -382,12 +381,12 @@ ppr_termM1 Term{}        = panic "ppr_termM1 - Term"
 ppr_termM1 RefWrap{}     = panic "ppr_termM1 - RefWrap"
 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
 
-pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t} 
+pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
   | Just (tc,_) <- tcSplitTyConApp_maybe ty
   , ASSERT(isNewTyCon tc) True
   , Just new_dc <- tyConSingleDataCon_maybe tc = do 
-         real_term <- y max_prec t
-         return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
+             real_term <- y max_prec t
+             return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)
 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
 
 -------------------------------------------------------
@@ -427,7 +426,7 @@ cPprTermBase y =
                                       . mapM (y (-1))
                                       . subTerms)
   , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
-           (\ p Term{subTerms=[h,t]} -> doList p h t)
+           (\ p t -> doList p t)
   , ifTerm (isTyCon intTyCon    . ty) (coerceShow$ \(a::Int)->a)
   , ifTerm (isTyCon charTyCon   . ty) (coerceShow$ \(a::Char)->a)
   , ifTerm (isTyCon floatTyCon  . ty) (coerceShow$ \(a::Float)->a)
@@ -438,10 +437,6 @@ cPprTermBase y =
                | pred t    = Just `liftM` f prec t
            ifTerm _ _ _ _  = return Nothing
 
-           isIntegerTy ty  = fromMaybe False $ do
-             (tc,_) <- tcSplitTyConApp_maybe ty 
-             return (tyConName tc == integerTyConName)
-
            isTupleTy ty    = fromMaybe False $ do 
              (tc,_) <- tcSplitTyConApp_maybe ty 
              return (isBoxedTupleTyCon tc)
@@ -450,10 +445,14 @@ cPprTermBase y =
              (tc,_) <- tcSplitTyConApp_maybe ty
              return (a_tc == tc)
 
+           isIntegerTy ty = fromMaybe False $ do
+             (tc,_) <- tcSplitTyConApp_maybe ty
+             return (tyConName tc == integerTyConName)
+
            coerceShow f _p = return . text . show . f . unsafeCoerce# . val
 
            --Note pprinting of list terms is not lazy
-           doList p h t = do
+           doList p (Term{subTerms=[h,t]}) = do
                let elems      = h : getListTerms t
                    isConsLast = not(termType(last elems) `coreEqType` termType h)
                print_elems <- mapM (y cons_prec) elems
@@ -469,6 +468,7 @@ cPprTermBase y =
                       getListTerms Term{subTerms=[]}    = []
                       getListTerms t@Suspension{}       = [t]
                       getListTerms t = pprPanic "getListTerms" (ppr t)
+           doList _ _ = panic "doList"
 
 
 repPrim :: TyCon -> [Word] -> String
@@ -570,13 +570,13 @@ liftTcM :: TcM a -> TR a
 liftTcM = id
 
 newVar :: Kind -> TR TcType
-newVar = liftTcM . liftM mkTyVarTy . newBoxyTyVar
+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, _, _)  <- tcInstType return ty
    (tvs',_,ty') <- tcInstType (mapM tcInstTyVar) ty
    return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
 
@@ -591,7 +591,7 @@ addConstraint actual expected = do
     recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
                                     text "with", ppr expected])
               (congruenceNewtypes actual expected >>=
-                           (getLIE . uncurry boxyUnify) >> return ())
+                           (getConstraints . uncurry unifyType) >> return ())
      -- TOMDO: what about the coercion?
      -- we should consider family instances
 
@@ -655,11 +655,13 @@ cvObtainTerm hsc_env max_depth force old_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 -> traceTR (text "Forcing a " <> text (show t)) >>
                                 seq a (go (pred max_depth) my_ty old_ty a)
+-- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE.  So we
+-- treat them like indirections; if the payload is TSO or BLOCKING_QUEUE, we'll end up
+-- showing '_' which is what we want.
+      Blackhole -> do traceTR (text "Following a BLACKHOLE")
+                      appArr (go max_depth my_ty old_ty) (ptrs clos) 0
 -- We always follow indirections
       Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) )
                           go max_depth my_ty old_ty $! (ptrs clos ! 0)
@@ -818,6 +820,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
   go my_ty a = do
     clos <- trIO $ getClosureData a
     case tipe clos of
+      Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO
       Indirection _ -> go my_ty $! (ptrs clos ! 0)
       MutVar _ -> do
          contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
@@ -859,7 +862,7 @@ improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do
     (ty_tvs,  _, _)   <- tcInstType return ty
     (ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty
     (_, _, rtti_ty')  <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty)
-    getLIE(boxyUnify rtti_ty' ty')
+    _ <- getConstraints(unifyType rtti_ty' ty')
     tvs1_contents     <- zonkTcTyVars ty_tvs'
     let subst = (uncurry zipTopTvSubst . unzip)
                  [(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents
@@ -1099,7 +1102,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
                         text " in presence of newtype evidence " <> ppr new_tycon)
                vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
                let ty' = mkTyConApp new_tycon vars
-               liftTcM (boxyUnify ty (repType ty'))
+               _ <- liftTcM (unifyType ty (repType ty'))
         -- assumes that reptype doesn't ^^^^ touch tyconApp args 
                return ty'