X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FRtClosureInspect.hs;h=d772eb3e5db9933765b9ff00d45290b9cca20168;hb=40739684494d88dde2efad64f15be2acbcc884a2;hp=10dbb163532cb2d4ce11b2b787c56cba4966208b;hpb=a07a463449d54855f19c160ed0f0a3853663db5f;p=ghc-hetmet.git

diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 10dbb16..d772eb3 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -179,7 +179,15 @@ getClosureData :: a -> IO Closure
 getClosureData a =
    case unpackClosure# a of 
      (# iptr, ptrs, nptrs #) -> do
+#ifndef GHCI_TABLES_NEXT_TO_CODE
+           -- the info pointer we get back from unpackClosure# is to the
+           -- beginning of the standard info table, but the Storable instance
+           -- for info tables takes into account the extra entry pointer
+           -- when !tablesNextToCode, so we must adjust here:
+           itbl <- peek (Ptr iptr `plusPtr` negate wORD_SIZE)
+#else
            itbl <- peek (Ptr iptr)
+#endif
            let tipe = readCType (BCI.tipe itbl)
                elems = fromIntegral (BCI.ptrs itbl)
                ptrsList = Array 0 (elems - 1) elems ptrs
@@ -579,7 +587,7 @@ cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
 -- and showing the '_' is more useful.
       t | isThunk t && force -> seq a $ go (pred bound) tv ty a
 -- We always follow indirections 
-      Indirection _ -> go (pred bound) tv ty $! (ptrs clos ! 0)
+      Indirection _ -> go bound tv ty $! (ptrs clos ! 0)
  -- The interesting case
       Constr -> do
         Right dcname <- dataConInfoPtrToName (infoPtr clos)
@@ -641,11 +649,11 @@ cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
    | isPointed ty = ASSERT2(not(null pointed)
                             , ptext SLIT("reOrderTerms") $$ 
                                         (ppr pointed $$ ppr unpointed))
-                    head pointed : reOrderTerms (tail pointed) unpointed tys
+                    let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
    | otherwise    = ASSERT2(not(null unpointed)
                            , ptext SLIT("reOrderTerms") $$ 
                                        (ppr pointed $$ ppr unpointed))
-                    head unpointed : reOrderTerms pointed (tail unpointed) tys
+                    let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
   
   expandNewtypes t@Term{ ty=ty, subTerms=tt }
    | Just (tc, args) <- splitNewTyConApp_maybe ty
@@ -728,16 +736,20 @@ cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
      -- 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
-computeRTTIsubst :: Type -> Type -> Maybe TvSubst
+     --  be stripped. Syntactically, forall's must be stripped.
+     -- We also remove predicates.
+computeRTTIsubst :: Type -> Type -> TvSubst
 computeRTTIsubst 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
-           tcUnifyTys (const BindMe) 
-                      [repType' $ dropForAlls$ ty]
-                      [repType' $ rtti_ty]  
--- TODO stripping newtypes shouldn't be necessary, test
-
+     -- TODO stripping newtypes shouldn't be necessary, test
+   where mb_subst = tcUnifyTys (const BindMe) 
+                               [rttiView ty]
+                               [rttiView rtti_ty]  
 
 -- Dealing with newtypes
 {-