X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FRtClosureInspect.hs;h=cafa527d216796e0962e9b637473dbc768f3f94a;hb=7605f65c7665bf1f58438d4eaf0ce9d56878a1c0;hp=3ea2ba9204c672be2cef424dea014e939c6a6912;hpb=876db7eda26b37f988bda8f6da8616b03aa5f810;p=ghc-hetmet.git

diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 3ea2ba9..cafa527 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -8,7 +8,7 @@
 
 module RtClosureInspect(
   
-     cvObtainTerm,       -- :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
+     cvObtainTerm,      -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
 
      Term(..),
      pprTerm, 
@@ -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,24 +468,28 @@ 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 
 
 -- Type & Term reconstruction 
-cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
-cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
+cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
+cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
    tv <- newVar argTypeKind
    case mb_ty of
-     Nothing -> go tv tv hval >>= zonkTerm
-     Just ty | isMonomorphic ty -> go ty ty hval >>= zonkTerm
+     Nothing -> go bound tv tv hval >>= zonkTerm
+     Just ty | isMonomorphic ty -> go bound ty ty hval >>= zonkTerm
      Just ty -> do 
               (ty',rev_subst) <- instScheme (sigmaType ty)
               addConstraint tv ty'
-              term <- go tv tv hval >>= zonkTerm
+              term <- go bound tv tv hval >>= zonkTerm
               --restore original Tyvars
               return$ mapTermType (substTy rev_subst) term
     where 
-  go tv ty a = do 
+  go bound _ _ _ | seq bound False = undefined
+  go 0 tv ty a = do
+    clos <- trIO $ getClosureData a
+    return (Suspension (tipe clos) (Just tv) a Nothing)
+  go bound tv ty a = do 
     let monomorphic = not(isTyVarTy tv)   
     -- This ^^^ is a convention. The ancestor tests for
     -- monomorphism and passes a type instead of a tv
@@ -494,9 +499,9 @@ cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
 -- 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
+      t | isThunk t && force -> seq a $ go (pred bound) tv ty a
 -- We always follow indirections 
-      Indirection _ -> go tv ty $! (ptrs clos ! 0)
+      Indirection _ -> go (pred bound) tv ty $! (ptrs clos ! 0)
  -- The interesting case
       Constr -> do
         Right dcname <- dataConInfoPtrToName (infoPtr clos)
@@ -510,7 +515,7 @@ cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
                        let tag = showSDoc (ppr dcname)
                        vars     <- replicateM (length$ elems$ ptrs clos) 
                                               (newVar (liftedTypeKind))
-                       subTerms <- sequence [appArr (go tv tv) (ptrs clos) i 
+                       subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i 
                                               | (i, tv) <- zip [0..] vars]
                        return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
           Just dc -> do 
@@ -533,7 +538,7 @@ cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
                   addConstraint myType signatureType
             subTermsP <- sequence $ drop extra_args 
                                  -- ^^^  all extra arguments are pointed
-                  [ appArr (go tv t) (ptrs clos) i
+                  [ appArr (go (pred bound) tv t) (ptrs clos) i
                    | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
             let unboxeds   = extractUnboxed subTtypesNP clos
                 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)      
@@ -541,9 +546,10 @@ cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
                                 (drop extra_args subTtypes)
             return (Term tv (Right dc) a subTerms)
 -- The otherwise case: can be a Thunk,AP,PAP,etc.
-      otherwise -> 
-         return (Suspension (tipe clos) (Just tv) a Nothing)
+      tipe_clos -> 
+         return (Suspension tipe_clos (Just tv) a Nothing)
 
+--  matchSubTypes dc ty | pprTrace "matchSubtypes" (ppr dc <+> ppr ty) False = undefined
   matchSubTypes dc ty
     | Just (_,ty_args) <- splitTyConApp_maybe (repType ty) 
 --     assumption:             ^^^ looks through newtypes 
@@ -582,7 +588,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 +597,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 +608,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 +636,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 +732,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 {