refactoring only

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

diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 2103cb3..4a481f3 100644 (file)
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -30,7 +30,7 @@ module RtClosureInspect(
      termTyVars,
 --     unsafeDeepSeq, 
      cvReconstructType,
      termTyVars,
 --     unsafeDeepSeq, 
      cvReconstructType,

-     computeRTTIsubst, 
+     unifyRTTI, 

      sigmaType,
      Closure(..),
      getClosureData,
      sigmaType,
      Closure(..),
      getClosureData,

@@ -46,23 +46,24 @@ import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
 import HscTypes         ( HscEnv )
 import Linker
 
 import HscTypes         ( HscEnv )
 import Linker
 

-import DataCon          
-import Type             
-import TcRnMonad        ( TcM, initTc, ioToTcRn, 
-                          tryTcErrs)
+import DataCon
+import Type
+import Var
+import TcRnMonad        ( TcM, initTc, ioToTcRn,
+                          tryTcErrs, traceTc)

 import TcType
 import TcMType
 import TcUnify
 import TcGadt
 import TcEnv
 import DriverPhases
 import TcType
 import TcMType
 import TcUnify
 import TcGadt
 import TcEnv
 import DriverPhases

-import TyCon           
-import Name 
+import TyCon
+import Name

 import VarEnv
 import Util
 import VarSet
 
 import VarEnv
 import Util
 import VarSet
 

-import TysPrim         
+import TysPrim

 import PrelNames
 import TysWiredIn
 
 import PrelNames
 import TysWiredIn
 

@@ -140,7 +141,8 @@ isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
 isFullyEvaluatedTerm _                  = False
 
 instance Outputable (Term) where
 isFullyEvaluatedTerm _                  = False
 
 instance Outputable (Term) where

- ppr = head . cPprTerm cPprTermBase
+ ppr t | Just doc <- cPprTerm cPprTermBase t = doc
+       | otherwise = panic "Outputable Term instance"

 
 -------------------------------------------------------------------------
 -- Runtime Closure Datatype and functions for retrieving closure related stuff
 
 -------------------------------------------------------------------------
 -- Runtime Closure Datatype and functions for retrieving closure related stuff

@@ -178,7 +180,15 @@ getClosureData :: a -> IO Closure
 getClosureData a =
    case unpackClosure# a of 
      (# iptr, ptrs, nptrs #) -> do
 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)
            itbl <- peek (Ptr iptr)

+#endif

            let tipe = readCType (BCI.tipe itbl)
                elems = fromIntegral (BCI.ptrs itbl)
                ptrsList = Array 0 (elems - 1) elems ptrs
            let tipe = readCType (BCI.tipe itbl)
                elems = fromIntegral (BCI.ptrs itbl)
                ptrsList = Array 0 (elems - 1) elems ptrs

@@ -314,49 +324,58 @@ termTyVars = foldTerm TermFold {
 -- Pretty printing of terms
 ----------------------------------
 
 -- Pretty printing of terms
 ----------------------------------
 

-app_prec,cons_prec ::Int
-app_prec = 10
+type Precedence        = Int
+type TermPrinter       = Precedence -> Term ->   SDoc
+type TermPrinterM m    = Precedence -> Term -> m SDoc
+
+app_prec,cons_prec, max_prec ::Int
+max_prec  = 10
+app_prec  = max_prec

 cons_prec = 5 -- TODO Extract this info from GHC itself
 
 cons_prec = 5 -- TODO Extract this info from GHC itself
 

-pprTerm :: (Int -> Term -> Maybe SDoc) -> Int -> Term -> SDoc
-pprTerm y p t | Just doc <- pprTermM y p t = doc
+pprTerm :: TermPrinter -> TermPrinter
+pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc

 pprTerm _ _ _ = panic "pprTerm"
 
 pprTerm _ _ _ = panic "pprTerm"
 

-pprTermM, pprNewtypeWrap :: Monad m => 
-                           (Int -> Term -> m SDoc) -> Int -> Term -> m SDoc
-pprTermM y p Term{dc=Left dc_tag, subTerms=tt} = do
+pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
+pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
+
+pprTermM1, ppr_termM1 :: Monad m => Term -> m SDoc
+pprTermM1 t    = pprDeeper `liftM` ppr_termM1 t
+
+ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do

   tt_docs <- mapM (y app_prec) tt
   tt_docs <- mapM (y app_prec) tt

-  return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> sep tt_docs)
+  return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)

   
   

-pprTermM y p Term{dc=Right dc, subTerms=tt} 
+ppr_termM y p Term{dc=Right dc, subTerms=tt} 

 {-  | dataConIsInfix dc, (t1:t2:tt') <- tt  --TODO fixity
 {-  | dataConIsInfix dc, (t1:t2:tt') <- tt  --TODO fixity

-  = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2) 
-    <+> hsep (map (pprTerm1 True) tt) 
+  = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2) 
+    <+> hsep (map (ppr_term1 True) tt) 

 -} -- TODO Printing infix constructors properly
   | null tt   = return$ ppr dc
   | otherwise = do
          tt_docs <- mapM (y app_prec) tt
 -} -- TODO Printing infix constructors properly
   | null tt   = return$ ppr dc
   | otherwise = do
          tt_docs <- mapM (y app_prec) tt

-         return$ cparen (p >= app_prec) (ppr dc <+> sep tt_docs)
+         return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
+
+ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t

 
 

-pprTermM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
+ppr_termM _ _ t = ppr_termM1 t

 
 

-pprTermM _ _ t = pprTermM1 t

 
 

-pprTermM1 :: Monad m => Term -> m SDoc
-pprTermM1 Prim{value=words, ty=ty} = 
+ppr_termM1 Prim{value=words, ty=ty} = 

     return$ text$ repPrim (tyConAppTyCon ty) words
     return$ text$ repPrim (tyConAppTyCon ty) words

-pprTermM1 Term{} = panic "pprTermM1 - unreachable"
-pprTermM1 Suspension{bound_to=Nothing} = return$ char '_'
-pprTermM1 Suspension{mb_ty=Just ty, bound_to=Just n}
+ppr_termM1 Term{} = panic "ppr_termM1 - unreachable"
+ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
+ppr_termM1 Suspension{mb_ty=Just ty, bound_to=Just n}

   | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
   | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty 
   | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
   | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty 

-pprTermM1 _ = panic "pprTermM1"
+ppr_termM1 _ = panic "ppr_termM1"

 
 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t} 
   | Just (tc,_) <- splitNewTyConApp_maybe ty
   , ASSERT(isNewTyCon tc) True
   , Just new_dc <- maybeTyConSingleCon tc = do 
 
 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t} 
   | Just (tc,_) <- splitNewTyConApp_maybe ty
   , ASSERT(isNewTyCon tc) True
   , Just new_dc <- maybeTyConSingleCon tc = do 

-         real_term <- y 10 t
+         real_term <- y max_prec t

          return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
 
          return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
 

@@ -373,17 +392,10 @@ pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
 --  which I didn't. Therefore, this code replicates a lot
 --  of what type classes provide for free.
 
 --  which I didn't. Therefore, this code replicates a lot
 --  of what type classes provide for free.
 

--- Concretely a custom term printer takes an explicit
---  recursion knot, and produces a list of Term Processors,
---  which additionally need a precedence value to
---  either produce a SDoc or fail (and they do this in some monad m).
-
-type Precedence          = Int
-type RecursionKnot m     = Precedence -> Term -> m SDoc
-type CustomTermPrinter m = RecursionKnot m
+type CustomTermPrinter m = TermPrinterM m

                          -> [Precedence -> Term -> (m (Maybe SDoc))]
 
                          -> [Precedence -> Term -> (m (Maybe SDoc))]
 

--- Takes a list of custom printers with a explicit recursion knot and a term, 
+-- | Takes a list of custom printers with a explicit recursion knot and a term, 

 -- and returns the output of the first succesful printer, or the default printer
 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
 cPprTerm printers_ = go 0 where
 -- and returns the output of the first succesful printer, or the default printer
 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
 cPprTerm printers_ = go 0 where

@@ -430,22 +442,23 @@ cPprTermBase y =
 
            coerceShow f _p = return . text . show . f . unsafeCoerce# . val
 
 
            coerceShow f _p = return . text . show . f . unsafeCoerce# . val
 

-           --TODO pprinting of list terms is not lazy
+           --Note pprinting of list terms is not lazy

            doList p h t = do
                let elems      = h : getListTerms t
                    isConsLast = termType(last elems) /= termType h
                print_elems <- mapM (y cons_prec) elems
                return$ if isConsLast
                      then cparen (p >= cons_prec) 
            doList p h t = do
                let elems      = h : getListTerms t
                    isConsLast = termType(last elems) /= termType h
                print_elems <- mapM (y cons_prec) elems
                return$ if isConsLast
                      then cparen (p >= cons_prec) 

-                        . hsep 
+                        . pprDeeperList fsep 

                         . punctuate (space<>colon)
                         $ print_elems
                         . punctuate (space<>colon)
                         $ print_elems

-                     else brackets (hcat$ punctuate comma print_elems)
+                     else brackets (pprDeeperList fcat$
+                                         punctuate comma print_elems)

 
                 where Just a /= Just b = not (a `coreEqType` b)
                       _      /=   _    = True
                       getListTerms Term{subTerms=[h,t]} = h : getListTerms t
 
                 where Just a /= Just b = not (a `coreEqType` b)
                       _      /=   _    = True
                       getListTerms Term{subTerms=[h,t]} = h : getListTerms t

-                      getListTerms Term{subTerms=[]}  = []
+                      getListTerms Term{subTerms=[]}    = []

                       getListTerms t@Suspension{}       = [t]
                       getListTerms t = pprPanic "getListTerms" (ppr t)
 
                       getListTerms t@Suspension{}       = [t]
                       getListTerms t = pprPanic "getListTerms" (ppr t)
 

@@ -515,6 +528,9 @@ runTR hsc_env c = do
 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
 
 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
 

+traceTR :: SDoc -> TR ()
+traceTR = liftTcM . traceTc
+

 trIO :: IO a -> TR a 
 trIO = liftTcM . ioToTcRn
 
 trIO :: IO a -> TR a 
 trIO = liftTcM . ioToTcRn
 

@@ -575,7 +591,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 
 -- 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)
  -- The interesting case
       Constr -> do
         Right dcname <- dataConInfoPtrToName (infoPtr clos)

@@ -637,11 +653,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))
    | 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))
    | 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
   
   expandNewtypes t@Term{ ty=ty, subTerms=tt }
    | Just (tc, args) <- splitNewTyConApp_maybe ty

@@ -678,8 +694,8 @@ cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
               substTy rev_subst `fmap` zonkTcType tv
     where 
 --  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
               substTy rev_subst `fmap` zonkTcType tv
     where 
 --  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()

-  search _ _ _ 0 = fail$ "Failed to reconstruct a type after " ++
-                                show max_depth ++ " steps"
+  search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
+                                int max_depth <> text " steps")

   search stop expand l d =
     case viewl l of 
       EmptyL  -> return ()
   search stop expand l d =
     case viewl l of 
       EmptyL  -> return ()

@@ -724,16 +740,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
      -- 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
-computeRTTIsubst ty rtti_ty = 
+     --  be stripped. Syntactically, forall's must be stripped.
+     -- We also remove predicates.
+unifyRTTI :: Type -> Type -> TvSubst
+unifyRTTI 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
      -- 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
 {-
 
 -- Dealing with newtypes
 {-

@@ -762,10 +782,12 @@ computeRTTIsubst ty rtti_ty =
    Note that it is very tricky to make this 'rewriting'
  work with the unification implemented by TcM, where
  substitutions are 'inlined'. The order in which 
    Note that it is very tricky to make this 'rewriting'
  work with the unification implemented by TcM, where
  substitutions are 'inlined'. The order in which 

- constraints are unified is vital for this (or I am 
- using TcM wrongly).
+ constraints are unified is vital for this.
+   This is a simple form of residuation, the technique of 
+ delaying unification steps until enough information
+ is available.

 -}
 -}

-congruenceNewtypes ::  TcType -> TcType -> TcM (TcType,TcType)
+congruenceNewtypes ::  TcType -> TcType -> TR (TcType,TcType)

 congruenceNewtypes lhs rhs 
  -- TyVar lhs inductive case
     | Just tv <- getTyVar_maybe lhs 
 congruenceNewtypes lhs rhs 
  -- TyVar lhs inductive case
     | Just tv <- getTyVar_maybe lhs 

@@ -783,18 +805,20 @@ congruenceNewtypes lhs rhs
     | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
     , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs 
     , tycon_l /= tycon_r 
     | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
     , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs 
     , tycon_l /= tycon_r 

-    = return (lhs, upgrade tycon_l rhs)
+    = do rhs' <- upgrade tycon_l rhs
+         return (lhs, rhs')

 
     | otherwise = return (lhs,rhs)
 
 
     | otherwise = return (lhs,rhs)
 

-    where upgrade :: TyCon -> Type -> Type
+    where upgrade :: TyCon -> Type -> TR Type

           upgrade new_tycon ty
           upgrade new_tycon ty

-            | not (isNewTyCon new_tycon) = ty 
-            | ty' <- mkTyConApp new_tycon (map mkTyVarTy $ tyConTyVars new_tycon)
-            , Just subst <- tcUnifyTys (const BindMe) [ty] [repType ty']
-            = substTy subst ty'
-          upgrade _ _ = panic "congruenceNewtypes.upgrade"
-        -- assumes that reptype doesn't touch tyconApp args ^^^
+            | not (isNewTyCon new_tycon) = return ty 
+            | otherwise = do 
+               vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
+               let ty' = mkTyConApp new_tycon vars
+               liftTcM (unifyType ty (repType ty'))
+        -- assumes that reptype doesn't ^^^^ touch tyconApp args 
+               return ty'

 
 
 --------------------------------------------------------------------------------
 
 
 --------------------------------------------------------------------------------