Rename maybeTyConSingleCon to tyConSingleDataCon_maybe
[ghc-hetmet.git] / compiler / ghci / RtClosureInspect.hs
index de672a1..509eb99 100644 (file)
@@ -31,7 +31,7 @@ module RtClosureInspect(
      termTyVars,
 --     unsafeDeepSeq, 
      cvReconstructType,
-     unifyRTTI, 
+     improveRTTIType,
      sigmaType,
      Closure(..),
      getClosureData,
@@ -50,12 +50,10 @@ import Linker
 import DataCon
 import Type
 import Var
-import TcRnMonad        ( TcM, initTc, ioToTcRn,
-                          tryTcErrs, traceTc)
+import TcRnMonad
 import TcType
 import TcMType
 import TcUnify
-import TcGadt
 import TcEnv
 import DriverPhases
 import TyCon
@@ -68,13 +66,15 @@ import TysPrim
 import PrelNames
 import TysWiredIn
 
-import Constants
 import Outputable
+import FastString
 import Panic
 
+import Constants        ( wORD_SIZE )
+
 import GHC.Arr          ( Array(..) )
 import GHC.Exts
-import GHC.IOBase
+import GHC.IOBase ( IO(IO) )
 
 import Control.Monad
 import Data.Maybe
@@ -87,25 +87,19 @@ import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
 import Foreign
 import System.IO.Unsafe
 
+import System.IO
 ---------------------------------------------
 -- * A representation of semi evaluated Terms
 ---------------------------------------------
 {-
-  A few examples in this representation:
-
-  > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
 
-  > (('a',_,_),_,('b',_,_)) = 
-      Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
-          [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
-          , Suspension
-          , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
 -}
 
 data Term = Term { ty        :: Type 
                  , dc        :: Either String DataCon
-                               -- Empty if the datacon aint exported by the .hi
-                               -- (private constructors in -O0 libraries)
+                               -- Carries a text representation if the datacon is
+                               -- not exported by the .hi file, which is the case 
+                               -- for private constructors in -O0 compiled libraries
                  , val       :: HValue 
                  , subTerms  :: [Term] }
 
@@ -184,15 +178,17 @@ 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 iptr'
+                | ghciTablesNextToCode =
+                   Ptr iptr
+                | otherwise =
+                   -- 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
+                   -- !ghciTablesNextToCode, so we must adjust here:
+                   Ptr iptr `plusPtr` negate wORD_SIZE
+           itbl <- peek iptr'
            let tipe = readCType (BCI.tipe itbl)
                elems = fromIntegral (BCI.ptrs itbl)
                ptrsList = Array 0 (elems - 1) elems ptrs
@@ -222,7 +218,6 @@ isConstr Constr = True
 isConstr    _   = False
 
 isIndirection (Indirection _) = True
---isIndirection ThunkSelector = True
 isIndirection _ = False
 
 isThunk (Thunk _)     = True
@@ -269,11 +264,11 @@ extractUnboxed tt clos = go tt (nonPtrs clos)
            | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
          go [] _ = []
          go (t:tt) xx 
-           | (x, rest) <- splitAt ((sizeofType t + wORD_SIZE - 1) `div` wORD_SIZE) xx 
+           | (x, rest) <- splitAt (sizeofType t) xx
            = x : go tt rest
 
-sizeofTyCon :: TyCon -> Int
-sizeofTyCon = sizeofPrimRep . tyConPrimRep
+sizeofTyCon :: TyCon -> Int -- in *words*
+sizeofTyCon = primRepSizeW . tyConPrimRep
 
 -----------------------------------
 -- * Traversals for Terms
@@ -382,7 +377,7 @@ ppr_termM1 Prim{value=words, ty=ty} =
     return$ text$ repPrim (tyConAppTyCon ty) words
 ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
-  | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
+  | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit "<function>")
   | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
 ppr_termM1 Term{}        = panic "ppr_termM1 - Term"
 ppr_termM1 RefWrap{}     = panic "ppr_termM1 - RefWrap"
@@ -391,7 +386,7 @@ ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t} 
   | Just (tc,_) <- splitNewTyConApp_maybe ty
   , ASSERT(isNewTyCon tc) True
-  , Just new_dc <- maybeTyConSingleCon tc = do 
+  , Just new_dc <- tyConSingleDataCon_maybe tc = do 
          real_term <- y max_prec t
          return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
@@ -540,19 +535,19 @@ runTR hsc_env c = do
     Just x  -> return x
 
 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
-runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
+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 = liftTcM . liftIO
 
 liftTcM :: TcM a -> TR a
 liftTcM = id
 
 newVar :: Kind -> TR TcType
-newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
+newVar = liftTcM . fmap mkTyVarTy . newBoxyTyVar
 
 -- | Returns the instantiated type scheme ty', and the substitution sigma 
 --   such that sigma(ty') = ty 
@@ -567,7 +562,7 @@ instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
 -- Before unification, congruenceNewtypes needs to
 -- do its magic.
 addConstraint :: TcType -> TcType -> TR ()
-addConstraint t1 t2  = congruenceNewtypes t1 t2 >>= uncurry unifyType 
+addConstraint t1 t2  = congruenceNewtypes t1 t2 >>= uncurry boxyUnify 
                       >> return () -- TOMDO: what about the coercion?
                                    -- we should consider family instances 
 
@@ -651,7 +646,7 @@ cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
                   (signatureType,_) <- instScheme(dataConRepType dc) 
                   addConstraint myType signatureType
             subTermsP <- sequence $ drop extra_args 
-                                 -- ^^^  all extra arguments are pointed
+                                -- \^^^  all extra arguments are pointed
                   [ appArr (go (pred bound) tv t) (ptrs clos) i
                    | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
             let unboxeds   = extractUnboxed subTtypesNP clos
@@ -675,11 +670,11 @@ cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
   reOrderTerms _ _ [] = []
   reOrderTerms pointed unpointed (ty:tys) 
    | isPointed ty = ASSERT2(not(null pointed)
-                            , ptext SLIT("reOrderTerms") $$ 
+                            , ptext (sLit "reOrderTerms") $$ 
                                         (ppr pointed $$ ppr unpointed))
                     let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
    | otherwise    = ASSERT2(not(null unpointed)
-                           , ptext SLIT("reOrderTerms") $$ 
+                           , ptext (sLit "reOrderTerms") $$ 
                                        (ppr pointed $$ ppr unpointed))
                     let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
   
@@ -687,7 +682,7 @@ cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
    | Just (tc, args) <- splitNewTyConApp_maybe ty
    , isNewTyCon tc
    , wrapped_type    <- newTyConInstRhs tc args
-   , Just dc         <- maybeTyConSingleCon tc
+   , Just dc         <- tyConSingleDataCon_maybe tc
    , t'              <- expandNewtypes t{ ty = wrapped_type
                                         , subTerms = map expandNewtypes tt }
    = NewtypeWrap ty (Right dc) t'
@@ -767,56 +762,55 @@ cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
                                      zip [0..] (filter isPointed subTtypes)]
       _ -> 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.
-     -- 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
-     -- TODO stripping newtypes shouldn't be necessary, test
-   where mb_subst = tcUnifyTys (const BindMe) 
-                               [rttiView ty]
-                               [rttiView rtti_ty]  
+-- Compute the difference between a base type and the type found by RTTI
+-- improveType <base_type> <rtti_type>
+-- The types can contain skolem type variables, which need to be treated as normal vars.
+-- In particular, we want them to unify with things.
+improveRTTIType :: HscEnv -> Type -> Type -> IO (Maybe TvSubst)
+improveRTTIType hsc_env ty rtti_ty = runTR_maybe hsc_env $ do
+    let (_,ty0)     = splitForAllTys ty
+        ty_tvs      = varSetElems $ tyVarsOfType ty0
+    let (_,rtti_ty0)= splitForAllTys rtti_ty
+        rtti_tvs    = varSetElems $ tyVarsOfType rtti_ty0
+    (ty_tvs',_,ty')<- tcInstType (mapM tcInstTyVar) (mkSigmaTy ty_tvs   [] ty0)
+    (_,_,rtti_ty') <- tcInstType (mapM tcInstTyVar) (mkSigmaTy rtti_tvs [] rtti_ty0)
+    boxyUnify rtti_ty' ty'
+    tvs1_contents  <- zonkTcTyVars ty_tvs'
+    let subst = uncurry zipTopTvSubst
+                  (unzip [(tv,ty) | tv <- ty_tvs, ty <- tvs1_contents
+                                  , getTyVar_maybe ty /= Just tv
+                                  , not(isTyVarTy ty)])
+--    liftIO $ hPutStrLn stderr $ showSDocDebug $ text "unify " <+> sep [ppr ty, ppr rtti_ty, equals, ppr subst ]
+    return subst
 
 -- Dealing with newtypes
 {-
-   A parallel fold over two Type values, 
+ congruenceNewtypes does a parallel fold over two Type values, 
  compensating for missing newtypes on both sides. 
  This is necessary because newtypes are not present 
- in runtime, but since sometimes there is evidence 
- available we do our best to reconstruct them. 
-   Evidence can come from DataCon signatures or 
+ in runtime, but sometimes there is evidence available.
+   Evidence can come from DataCon signatures or
  from compile-time type inference.
-   I am using the words congruence and rewriting 
- because what we are doing here is an approximation 
- of unification modulo a set of equations, which would 
- come from newtype definitions. These should be the 
- equality coercions seen in System Fc. Rewriting 
- is performed, taking those equations as rules, 
- before launching unification.
-
-   It doesn't make sense to rewrite everywhere, 
- or we would end up with all newtypes. So we rewrite 
- only in presence of evidence.
-   The lhs comes from the heap structure of ptrs,nptrs. 
-   The rhs comes from a DataCon type signature. 
- Rewriting in the rhs is restricted to the result type.
+ What we are doing here is an approximation
+ of unification modulo a set of equations derived
+ from newtype definitions. These equations should be the
+ same as the equality coercions generated for newtypes
+ in System Fc. The idea is to perform a sort of rewriting,
+ taking those equations as rules, before launching unification.
+
+ The caller must ensure the following.
+ The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
+ The 2nd type (rhs) comes from a DataCon type signature.
+ Rewriting (i.e. adding/removing a newtype wrapper) can happen
+ in both types, but in the rhs it is restricted to the result type.
 
    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.
-   This is a simple form of residuation, the technique of 
- delaying unification steps until enough information
- is available.
+ substitutions are operationally inlined. The order in which
+ constraints are unified is vital as we cannot modify
+ anything that has been touched by a previous unification step.
+Therefore, congruenceNewtypes is sound only if the types
+recovered by the RTTI mechanism are unified Top-Down.
 -}
 congruenceNewtypes ::  TcType -> TcType -> TR (TcType,TcType)
 congruenceNewtypes lhs rhs