X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FRtClosureInspect.hs;h=0acc830432d67d399daafc7f97fe64bf9fc5c324;hb=834fcf7de73aeb4a3fa4c88dc995ce1b55b78a93;hp=b28981da38941936c098adf8f25b2d3efc42ab4a;hpb=00b6d2567426ec52a113b1d3687e1d61368cafda;p=ghc-hetmet.git

diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index b28981d..0acc830 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -37,12 +37,12 @@ import HscTypes         ( HscEnv )
 
 import DataCon          
 import Type             
-import TcRnMonad        ( TcM, initTcPrintErrors, ioToTcRn, recoverM
-                        , writeMutVar )
+import TcRnMonad        ( TcM, initTcPrintErrors, ioToTcRn, recoverM)
 import TcType
 import TcMType
 import TcUnify
 import TcGadt
+import TcEnv
 import TyCon		
 import Var
 import Name 
@@ -103,6 +103,7 @@ data Term = Term { ty        :: Type
                        , bound_to :: Maybe Name   -- Useful for printing
                        }
 
+isTerm, isSuspension, isPrim :: Term -> Bool
 isTerm Term{} = True
 isTerm   _    = False
 isSuspension Suspension{} = True
@@ -110,6 +111,7 @@ isSuspension      _       = False
 isPrim Prim{} = True
 isPrim   _    = False
 
+termType :: Term -> Maybe Type
 termType t@(Suspension {}) = mb_ty t
 termType t = Just$ ty t
 
@@ -159,9 +161,10 @@ getClosureData a =
            itbl <- peek (Ptr iptr)
            let tipe = readCType (BCI.tipe itbl)
                elems = BCI.ptrs itbl 
-               ptrsList = Array 0 (fromIntegral$ elems) ptrs
+               ptrsList = Array 0 ((fromIntegral elems) - 1) ptrs
                nptrs_data = [W# (indexWordArray# nptrs i)
                               | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
+           ASSERT(fromIntegral elems >= 0) return ()
            ptrsList `seq` 
             return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
 
@@ -178,7 +181,7 @@ readCType i
  | fromIntegral i == pAP_CODE              = PAP
  | otherwise                               = Other (fromIntegral i)
 
-isConstr, isIndirection :: ClosureType -> Bool
+isConstr, isIndirection, isThunk :: ClosureType -> Bool
 isConstr Constr = True
 isConstr    _   = False
 
@@ -262,11 +265,13 @@ idTermFoldM = TermFold {
               fSuspension = (((return.).).). Suspension
                        }
 
+mapTermType :: (Type -> Type) -> Term -> Term
 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 :: Term -> TyVarSet
 termTyVars = foldTerm TermFold {
             fTerm       = \ty _ _ tt   -> 
                           tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
@@ -315,7 +320,7 @@ pprTermM1 _ Suspension{mb_ty=Just ty, bound_to=Just n}
 cPprTerm :: forall m. Monad m => 
            ((Int->Term->m SDoc)->[Int->Term->m (Maybe SDoc)]) -> Term -> m SDoc
 cPprTerm custom = go 0 where
-  go prec t@Term{subTerms=tt, dc=dc} = do
+  go prec t@Term{} = do
     let default_ prec t = Just `liftM` pprTermM go prec t
         mb_customDocs = [pp prec t | pp <- custom go ++ [default_]]
     Just doc <- firstJustM mb_customDocs
@@ -431,6 +436,7 @@ runTR hsc_env c = do
 trIO :: IO a -> TR a 
 trIO = liftTcM . ioToTcRn
 
+liftTcM :: TcM a -> TR a
 liftTcM = id
 
 newVar :: Kind -> TR TcTyVar
@@ -539,14 +545,15 @@ cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
 
 
 -- Fast, breadth-first Type reconstruction
-
+max_depth = 10 :: Int
 cvReconstructType :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Type
 cvReconstructType hsc_env force mb_ty hval = runTR hsc_env $ do
    tv <- liftM mkTyVarTy (newVar argTypeKind)
    case mb_ty of
-     Nothing -> do search (isMonomorphic `fmap` zonkTcType tv) 
-                       (uncurry go) 
-                       [(tv, hval)]  
+     Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
+                          (uncurry go)  
+                          [(tv, hval)]  
+                          max_depth
                    zonkTcType tv  -- TODO untested!
      Just ty | isMonomorphic ty -> return ty
      Just ty -> do 
@@ -555,12 +562,16 @@ cvReconstructType hsc_env force mb_ty hval = runTR hsc_env $ do
               search (isMonomorphic `fmap` zonkTcType tv) 
                      (uncurry go) 
                      [(tv, hval)]
+                     max_depth
               substTy rev_subst `fmap` zonkTcType tv
     where 
 --  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
-  search stop expand []     = return ()
-  search stop expand  (x:xx) = do new <- expand x 
-                                  unlessM stop $ search stop expand (xx ++ new)
+  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 
+    new <- expand x 
+    unlessM stop $ 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)]
@@ -583,10 +594,8 @@ cvReconstructType hsc_env force mb_ty hval = runTR hsc_env $ do
             let myType         = mkFunTys subTtypes tv
             (signatureType,_) <- instScheme(dataConRepType dc) 
             addConstraint myType signatureType
-            return $ map (\(I# i#,t) -> case ptrs clos of 
-                             (Array _ _ ptrs#) -> case indexArray# ptrs# i# of 
-                                                       (# e #) -> (t,e))
-                        (drop extra_args $ zip [0..] subTtypes)
+            return $ [ appArr (\e->(t,e)) (ptrs clos) i
+                       | (i,t) <- drop extra_args $ zip [0..] subTtypes]
       otherwise -> return []