Type checking for type synonym families

[ghc-hetmet.git] / compiler / ghci / RtClosureInspect.hs

diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 3ea2ba9..255c8e1 100644 (file)
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -26,6 +26,7 @@ module RtClosureInspect(
      termTyVars,
 --     unsafeDeepSeq, 
      cvReconstructType,
+     computeRTTIsubst, 
      sigmaType
  ) where 
 
@@ -162,8 +163,8 @@ getClosureData a =
      (# iptr, ptrs, nptrs #) -> do
            itbl <- peek (Ptr iptr)
            let tipe = readCType (BCI.tipe itbl)
-               elems = BCI.ptrs itbl 
-               ptrsList = Array 0 ((fromIntegral elems) - 1) ptrs
+               elems = fromIntegral (BCI.ptrs itbl)
+               ptrsList = Array 0 (elems - 1) elems ptrs
                nptrs_data = [W# (indexWordArray# nptrs i)
                               | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
            ASSERT(fromIntegral elems >= 0) return ()
@@ -205,9 +206,9 @@ isFullyEvaluated a = do
     otherwise -> return False
   where amapM f = sequence . amap' f
 
-amap' f (Array i0 i arr#) = map (\(I# i#) -> case indexArray# arr# i# of
-                                   (# e #) -> f e)
-                                [0 .. i - i0]
+amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
+    where g (I# i#) = case indexArray# arr# i# of
+                          (# e #) -> f e
 
 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
 {-
@@ -234,7 +235,7 @@ extractUnboxed tt clos = go tt (nonPtrs clos)
            | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
          go [] _ = []
          go (t:tt) xx 
-           | (x, rest) <- splitAt (sizeofType t `div` wORD_SIZE) xx 
+           | (x, rest) <- splitAt ((sizeofType t + wORD_SIZE - 1) `div` wORD_SIZE) xx 
            = x : go tt rest
 
 sizeofTyCon = sizeofPrimRep . tyConPrimRep
@@ -467,6 +468,8 @@ instScheme ty | (tvs, rho) <- tcSplitForAllTys ty = liftTcM$ do
 -- do its magic.
 addConstraint :: TcType -> TcType -> TR ()
 addConstraint t1 t2  = congruenceNewtypes t1 t2 >>= uncurry unifyType 
+                      >> return () -- TOMDO: what about the coercion?
+                                   -- we should consider family instances 
 
 
 
@@ -582,7 +585,7 @@ cvReconstructType hsc_env force mb_ty hval = runTR_maybe hsc_env $ do
               (ty',rev_subst) <- instScheme (sigmaType ty) 
               addConstraint tv ty'
               search (isMonomorphic `fmap` zonkTcType tv) 
-                     (uncurry go) 
+                     (\(ty,a) -> go ty a) 
                      [(tv, hval)]
                      max_depth
               substTy rev_subst `fmap` zonkTcType tv
@@ -591,9 +594,9 @@ cvReconstructType hsc_env force mb_ty hval = runTR_maybe hsc_env $ do
   search stop expand [] depth  = return ()
   search stop expand x 0 = fail$ "Failed to reconstruct a type after " ++
                                 show max_depth ++ " steps"
-  search stop expand (x:xx) d  = do 
+  search stop expand (x:xx) d  = unlessM stop $ do 
     new <- expand x 
-    unlessM stop $ search stop expand (xx ++ new) $! (pred d)
+    search stop expand (xx ++ new) $! (pred d)
 
    -- returns unification tasks,since we are going to want a breadth-first search
   go :: Type -> HValue -> TR [(Type, HValue)]
@@ -602,19 +605,20 @@ cvReconstructType hsc_env force mb_ty hval = runTR_maybe hsc_env $ do
     case tipe clos of
       Indirection _ -> go tv $! (ptrs clos ! 0)
       Constr -> do
-        mb_dcname <- dataConInfoPtrToName (infoPtr clos)
-        case mb_dcname of
-          Left tag -> do 
+        Right dcname <- dataConInfoPtrToName (infoPtr clos)
+        (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
+        case mb_dc of
+          Nothing-> do 
+                     --  TODO: Check this case
             vars     <- replicateM (length$ elems$ ptrs clos) 
                                    (newVar (liftedTypeKind))
             subTerms <- sequence [ appArr (go tv) (ptrs clos) i 
                                    | (i, tv) <- zip [0..] vars]    
             forM [0..length (elems $ ptrs clos)] $ \i -> do
-                        tv <- newVar openTypeKind 
+                        tv <- newVar liftedTypeKind 
                         return$ appArr (\e->(tv,e)) (ptrs clos) i
 
-          Right name -> do 
-            dc <- tcLookupDataCon name
+          Just dc -> do 
             let extra_args = length(dataConRepArgTys dc) - 
                              length(dataConOrigArgTys dc)
             subTtypes <- mapMif (not . isMonomorphic)
@@ -629,6 +633,19 @@ cvReconstructType hsc_env force mb_ty hval = runTR_maybe hsc_env $ do
                        | (i,t) <- drop extra_args $ zip [0..] subTtypes]
       otherwise -> 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
+computeRTTIsubst 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
+
 
 -- Dealing with newtypes
 {-
@@ -712,9 +729,10 @@ mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
 unlessM condM acc = condM >>= \c -> unless c acc
 
 -- Strict application of f at index i
-appArr f a@(Array _ _ ptrs#) i@(I# i#) = ASSERT (i < length(elems a))
-                                  case indexArray# ptrs# i# of 
-                                       (# e #) -> f e
+appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
+ = ASSERT (i < length(elems a))
+   case indexArray# ptrs# i# of
+       (# e #) -> f e
 
 zonkTerm :: Term -> TcM Term
 zonkTerm = foldTerm idTermFoldM {