Fix #13819 by refactoring TypeEqOrigin.uo_thing
[ghc.git] / compiler / ghci / RtClosureInspect.hs
index 49e943c..263aeba 100644 (file)
@@ -1,3 +1,5 @@
+{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash, UnboxedTuples #-}
+
 -----------------------------------------------------------------------------
 --
 -- GHC Interactive support for inspecting arbitrary closures at runtime
@@ -5,14 +7,6 @@
 -- Pepe Iborra (supported by Google SoC) 2006
 --
 -----------------------------------------------------------------------------
-
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
 module RtClosureInspect(
      cvObtainTerm,      -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
      cvReconstructType,
@@ -21,7 +15,7 @@ module RtClosureInspect(
      Term(..),
      isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap,
      isFullyEvaluated, isFullyEvaluatedTerm,
-     termType, mapTermType, termTyVars,
+     termType, mapTermType, termTyCoVars,
      foldTerm, TermFold(..), foldTermM, TermFoldM(..), idTermFold,
      pprTerm, cPprTerm, cPprTermBase, CustomTermPrinter,
 
@@ -33,13 +27,14 @@ module RtClosureInspect(
 #include "HsVersions.h"
 
 import DebuggerUtils
-import ByteCodeItbls    ( StgInfoTable )
-import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
+import GHCi.RemoteTypes ( HValue )
+import qualified GHCi.InfoTable as InfoTable
+import GHCi.InfoTable (StgInfoTable, peekItbl)
 import HscTypes
-import Linker
 
 import DataCon
 import Type
+import RepType
 import qualified Unify as U
 import Var
 import TcRnMonad
@@ -51,10 +46,9 @@ import TcEnv
 
 import TyCon
 import Name
-import VarEnv
 import Util
 import VarSet
-import BasicTypes       ( TupleSort(UnboxedTuple) )
+import BasicTypes       ( Boxity(..) )
 import TysPrim
 import PrelNames
 import TysWiredIn
@@ -64,16 +58,14 @@ import GHC.Arr          ( Array(..) )
 import GHC.Exts
 import GHC.IO ( IO(..) )
 
-import StaticFlags( opt_PprStyle_Debug )
 import Control.Monad
 import Data.Maybe
 import Data.Array.Base
 import Data.Ix
 import Data.List
 import qualified Data.Sequence as Seq
-import Data.Monoid (mappend)
 import Data.Sequence (viewl, ViewL(..))
-import Foreign.Safe
+import Foreign
 import System.IO.Unsafe
 
 ---------------------------------------------
@@ -83,9 +75,9 @@ import System.IO.Unsafe
 data Term = Term { ty        :: RttiType
                  , dc        :: Either String DataCon
                                -- Carries a text representation if the datacon is
-                               -- not exported by the .hi file, which is the case 
+                               -- not exported by the .hi file, which is the case
                                -- for private constructors in -O0 compiled libraries
-                 , val       :: HValue 
+                 , val       :: HValue
                  , subTerms  :: [Term] }
 
           | Prim { ty        :: RttiType
@@ -140,20 +132,20 @@ instance Outputable (Term) where
 -------------------------------------------------------------------------
 -- Runtime Closure Datatype and functions for retrieving closure related stuff
 -------------------------------------------------------------------------
-data ClosureType = Constr 
-                 | Fun 
-                 | Thunk Int 
+data ClosureType = Constr
+                 | Fun
+                 | Thunk Int
                  | ThunkSelector
-                 | Blackhole 
-                 | AP 
-                 | PAP 
-                 | Indirection Int 
+                 | Blackhole
+                 | AP
+                 | PAP
+                 | Indirection Int
                  | MutVar Int
                  | MVar   Int
                  | Other  Int
  deriving (Show, Eq)
 
-data Closure = Closure { tipe         :: ClosureType 
+data Closure = Closure { tipe         :: ClosureType
                        , infoPtr      :: Ptr ()
                        , infoTable    :: StgInfoTable
                        , ptrs         :: Array Int HValue
@@ -161,7 +153,7 @@ data Closure = Closure { tipe         :: ClosureType
                        }
 
 instance Outputable ClosureType where
-  ppr = text . show 
+  ppr = text . show
 
 #include "../includes/rts/storage/ClosureTypes.h"
 
@@ -173,31 +165,31 @@ pAP_CODE = PAP
 
 getClosureData :: DynFlags -> a -> IO Closure
 getClosureData dflags a =
-   case unpackClosure# a of 
+   case unpackClosure# a of
      (# iptr, ptrs, nptrs #) -> do
-           let iptr'
-                | ghciTablesNextToCode =
-                   Ptr iptr
+           let iptr0 = Ptr iptr
+           let iptr1
+                | ghciTablesNextToCode = iptr0
                 | 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 dflags)
-           itbl <- peek iptr'
-           let tipe = readCType (BCI.tipe itbl)
-               elems = fromIntegral (BCI.ptrs itbl)
+                   iptr0 `plusPtr` negate (wORD_SIZE dflags)
+           itbl <- peekItbl iptr1
+           let tipe = readCType (InfoTable.tipe itbl)
+               elems = fromIntegral (InfoTable.ptrs itbl)
                ptrsList = Array 0 (elems - 1) elems ptrs
                nptrs_data = [W# (indexWordArray# nptrs i)
-                              | I# i <- [0.. fromIntegral (BCI.nptrs itbl)-1] ]
+                            | I# i <- [0.. fromIntegral (InfoTable.nptrs itbl)-1] ]
            ASSERT(elems >= 0) return ()
-           ptrsList `seq` 
-            return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
+           ptrsList `seq`
+            return (Closure tipe iptr0 itbl ptrsList nptrs_data)
 
 readCType :: Integral a => a -> ClosureType
-readCType i 
- | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
+readCType i
+ | i >= CONSTR && i <= CONSTR_NOCAF        = Constr
  | i >= FUN    && i <= FUN_STATIC          = Fun
  | i >= THUNK  && i < THUNK_SELECTOR       = Thunk i'
  | i == THUNK_SELECTOR                     = ThunkSelector
@@ -210,7 +202,7 @@ readCType i
  | i == MVAR_CLEAN    || i == MVAR_DIRTY   = MVar i'
  | otherwise                               = Other  i'
   where i' = fromIntegral i
+
 isConstr, isIndirection, isThunk :: ClosureType -> Bool
 isConstr Constr = True
 isConstr    _   = False
@@ -238,7 +230,7 @@ unsafeDeepSeq :: a -> b -> b
 unsafeDeepSeq = unsafeDeepSeq1 2
  where unsafeDeepSeq1 0 a b = seq a $! b
        unsafeDeepSeq1 i a b   -- 1st case avoids infinite loops for non reducible thunks
-        | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b     
+        | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
      -- | unsafePerformIO (isFullyEvaluated a) = b
         | otherwise = case unsafePerformIO (getClosureData a) of
                         closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
@@ -311,15 +303,15 @@ mapTermTypeM f = foldTermM TermFoldM {
           fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t,
           fRefWrapM    = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t}
 
-termTyVars :: Term -> TyVarSet
-termTyVars = foldTerm TermFold {
-            fTerm       = \ty _ _ tt   -> 
-                          tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
-            fSuspension = \_ ty _ _ -> tyVarsOfType ty,
-            fPrim       = \ _ _ -> emptyVarEnv,
-            fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t,
-            fRefWrap    = \ty t -> tyVarsOfType ty `plusVarEnv` t}
-    where concatVarEnv = foldr plusVarEnv emptyVarEnv
+termTyCoVars :: Term -> TyCoVarSet
+termTyCoVars = foldTerm TermFold {
+            fTerm       = \ty _ _ tt   ->
+                          tyCoVarsOfType ty `unionVarSet` concatVarEnv tt,
+            fSuspension = \_ ty _ _ -> tyCoVarsOfType ty,
+            fPrim       = \ _ _ -> emptyVarSet,
+            fNewtypeWrap= \ty _ t -> tyCoVarsOfType ty `unionVarSet` t,
+            fRefWrap    = \ty t -> tyCoVarsOfType ty `unionVarSet` t}
+    where concatVarEnv = foldr unionVarSet emptyVarSet
 
 ----------------------------------
 -- Pretty printing of terms
@@ -345,23 +337,23 @@ ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
   tt_docs <- mapM (y app_prec) tt
   return $ cparen (not (null tt) && p >= app_prec)
                   (text dc_tag <+> pprDeeperList fsep tt_docs)
-  
-ppr_termM y p Term{dc=Right dc, subTerms=tt} 
+
+ppr_termM y p Term{dc=Right dc, subTerms=tt} = do
 {-  | dataConIsInfix dc, (t1:t2:tt') <- tt  --TODO fixity
-  = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2) 
-    <+> hsep (map (ppr_term1 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 sub_terms_to_show
-  = return (ppr dc)
-  | otherwise 
-  = do { tt_docs <- mapM (y app_prec) sub_terms_to_show
-       ; return $ cparen (p >= app_prec) $
-         sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] }
-  where
-    sub_terms_to_show  -- Don't show the dictionary arguments to 
-                       -- constructors unless -dppr-debug is on
-      | opt_PprStyle_Debug = tt
-      | otherwise = dropList (dataConTheta dc) tt
+  tt_docs' <- mapM (y app_prec) tt
+  return $ sdocWithPprDebug $ \dbg ->
+    -- Don't show the dictionary arguments to
+    -- constructors unless -dppr-debug is on
+    let tt_docs = if dbg
+           then tt_docs'
+           else dropList (dataConTheta dc) tt_docs'
+    in if null tt_docs
+      then ppr dc
+      else cparen (p >= app_prec) $
+             sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)]
 
 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
 ppr_termM y p RefWrap{wrapped_term=t}  = do
@@ -376,9 +368,9 @@ ppr_termM _ _ t = ppr_termM1 t
 
 
 ppr_termM1 :: Monad m => Term -> m SDoc
-ppr_termM1 Prim{value=words, ty=ty} = 
+ppr_termM1 Prim{value=words, ty=ty} =
     return $ repPrim (tyConAppTyCon ty) words
-ppr_termM1 Suspension{ty=ty, bound_to=Nothing} = 
+ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
     return (char '_' <+> ifPprDebug (text "::" <> ppr ty))
 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
 --  | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")
@@ -390,7 +382,7 @@ ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
   | Just (tc,_) <- tcSplitTyConApp_maybe ty
   , ASSERT(isNewTyCon tc) True
-  , Just new_dc <- tyConSingleDataCon_maybe 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"
@@ -399,11 +391,11 @@ pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
 -- Custom Term Pretty Printers
 -------------------------------------------------------
 
--- We can want to customize the representation of a 
---  term depending on its type. 
+-- We can want to customize the representation of a
+--  term depending on its type.
 -- However, note that custom printers have to work with
 --  type representations, instead of directly with types.
--- We cannot use type classes here, unless we employ some 
+-- We cannot use type classes here, unless we employ some
 --  typerep trickery (e.g. Weirich's RepLib tricks),
 --  which I didn't. Therefore, this code replicates a lot
 --  of what type classes provide for free.
@@ -411,8 +403,8 @@ pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
 type CustomTermPrinter m = TermPrinterM m
                          -> [Precedence -> Term -> (m (Maybe SDoc))]
 
--- | 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
+-- | Takes a list of custom printers with a explicit recursion knot and a term,
+-- and returns the output of the first successful printer, or the default printer
 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
 cPprTerm printers_ = go 0 where
   printers = printers_ go
@@ -428,7 +420,7 @@ cPprTerm printers_ = go 0 where
 -- Default set of custom printers. Note that the recursion knot is explicit
 cPprTermBase :: forall m. Monad m => CustomTermPrinter m
 cPprTermBase y =
-  [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma) 
+  [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
                                       . mapM (y (-1))
                                       . subTerms)
   , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
@@ -439,7 +431,7 @@ cPprTermBase y =
   , ifTerm (isTyCon doubleTyCon . ty) ppr_double
   , ifTerm (isIntegerTy         . ty) ppr_integer
   ]
- where 
+ where
    ifTerm :: (Term -> Bool)
           -> (Precedence -> Term -> m SDoc)
           -> Precedence -> Term -> m (Maybe SDoc)
@@ -447,11 +439,11 @@ cPprTermBase y =
        | pred t    = Just `liftM` f prec t
    ifTerm _ _ _ _  = return Nothing
 
-   isTupleTy ty    = fromMaybe False $ do 
-     (tc,_) <- tcSplitTyConApp_maybe ty 
+   isTupleTy ty    = fromMaybe False $ do
+     (tc,_) <- tcSplitTyConApp_maybe ty
      return (isBoxedTupleTyCon tc)
 
-   isTyCon a_tc ty = fromMaybe False $ do 
+   isTyCon a_tc ty = fromMaybe False $ do
      (tc,_) <- tcSplitTyConApp_maybe ty
      return (a_tc == tc)
 
@@ -459,7 +451,7 @@ cPprTermBase y =
      (tc,_) <- tcSplitTyConApp_maybe ty
      return (tyConName tc == integerTyConName)
 
-   ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer 
+   ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer
       :: Precedence -> Term -> m SDoc
    ppr_int     _ v = return (Ppr.int     (unsafeCoerce# (val v)))
    ppr_char    _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'')
@@ -471,17 +463,17 @@ cPprTermBase y =
    ppr_list :: Precedence -> Term -> m SDoc
    ppr_list p (Term{subTerms=[h,t]}) = do
        let elems      = h : getListTerms t
-           isConsLast = not(termType(last elems) `eqType` termType h)
-          is_string  = all (isCharTy . ty) elems
+           isConsLast = not (termType (last elems) `eqType` termType h)
+           is_string  = all (isCharTy . ty) elems
 
        print_elems <- mapM (y cons_prec) elems
        if is_string
         then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems))))
         else if isConsLast
-        then return $ cparen (p >= cons_prec) 
-                    $ pprDeeperList fsep 
+        then return $ cparen (p >= cons_prec)
+                    $ pprDeeperList fsep
                     $ punctuate (space<>colon) print_elems
-        else return $ brackets 
+        else return $ brackets
                     $ pprDeeperList fcat
                     $ punctuate comma print_elems
 
@@ -508,20 +500,23 @@ repPrim t = rep where
     | t == stablePtrPrimTyCon        = text "<stablePtr>"
     | t == stableNamePrimTyCon       = text "<stableName>"
     | t == statePrimTyCon            = text "<statethread>"
+    | t == proxyPrimTyCon            = text "<proxy>"
     | t == realWorldTyCon            = text "<realworld>"
     | t == threadIdPrimTyCon         = text "<ThreadId>"
     | t == weakPrimTyCon             = text "<Weak>"
     | t == arrayPrimTyCon            = text "<array>"
+    | t == smallArrayPrimTyCon       = text "<smallArray>"
     | t == byteArrayPrimTyCon        = text "<bytearray>"
     | t == mutableArrayPrimTyCon     = text "<mutableArray>"
+    | t == smallMutableArrayPrimTyCon = text "<smallMutableArray>"
     | t == mutableByteArrayPrimTyCon = text "<mutableByteArray>"
     | t == mutVarPrimTyCon           = text "<mutVar>"
     | t == mVarPrimTyCon             = text "<mVar>"
     | t == tVarPrimTyCon             = text "<tVar>"
     | otherwise                      = char '<' <> ppr t <> char '>'
-    where build ww = unsafePerformIO $ withArray ww (peek . castPtr) 
---   This ^^^ relies on the representation of Haskell heap values being 
---   the same as in a C array. 
+    where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
+--   This ^^^ relies on the representation of Haskell heap values being
+--   the same as in a C array.
 
 -----------------------------------
 -- Type Reconstruction
@@ -532,14 +527,14 @@ The algorithm walks the heap generating a set of equations, which
 are solved with syntactic unification.
 A type reconstruction equation looks like:
 
-  <datacon reptype>  =  <actual heap contents> 
+  <datacon reptype>  =  <actual heap contents>
 
 The full equation set is generated by traversing all the subterms, starting
 from a given term.
 
 The only difficult part is that newtypes are only found in the lhs of equations.
-Right hand sides are missing them. We can either (a) drop them from the lhs, or 
-(b) reconstruct them in the rhs when possible. 
+Right hand sides are missing them. We can either (a) drop them from the lhs, or
+(b) reconstruct them in the rhs when possible.
 
 The function congruenceNewtypes takes a shot at (b)
 -}
@@ -568,23 +563,22 @@ runTR hsc_env thing = 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 thing_inside
+  = do { (_errs, res) <- initTcInteractive hsc_env thing_inside
+       ; return res }
 
+-- | Term Reconstruction trace
 traceTR :: SDoc -> TR ()
 traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti
 
 
--- Semantically different to recoverM in TcRnMonad 
+-- Semantically different to recoverM in TcRnMonad
 -- recoverM retains the errors in the first action,
 --  whereas recoverTc here does not
 recoverTR :: TR a -> TR a -> TR a
-recoverTR recover thing = do 
-  (_,mb_res) <- tryTcErrs thing
-  case mb_res of 
-    Nothing  -> recover
-    Just res -> return res
+recoverTR = tryTcDiscardingErrs
 
-trIO :: IO a -> TR a 
+trIO :: IO a -> TR a
 trIO = liftTcM . liftIO
 
 liftTcM :: TcM a -> TR a
@@ -593,26 +587,30 @@ liftTcM = id
 newVar :: Kind -> TR TcType
 newVar = liftTcM . newFlexiTyVarTy
 
-instTyVars :: [TyVar] -> TR ([TcTyVar], [TcType], TvSubst)
+newOpenVar :: TR TcType
+newOpenVar = liftTcM newOpenFlexiTyVarTy
+
+instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar])
 -- Instantiate fresh mutable type variables from some TyVars
 -- This function preserves the print-name, which helps error messages
-instTyVars = liftTcM . tcInstTyVars
+instTyVars tvs
+  = liftTcM $ fst <$> captureConstraints (newMetaTyVars tvs)
 
 type RttiInstantiation = [(TcTyVar, TyVar)]
-   -- Associates the typechecker-world meta type variables 
-   -- (which are mutable and may be refined), to their 
+   -- Associates the typechecker-world meta type variables
+   -- (which are mutable and may be refined), to their
    -- debugger-world RuntimeUnk counterparts.
    -- If the TcTyVar has not been refined by the runtime type
    -- elaboration, then we want to turn it back into the
    -- original RuntimeUnk
 
--- | Returns the instantiated type scheme ty', and the 
+-- | Returns the instantiated type scheme ty', and the
 --   mapping from new (instantiated) -to- old (skolem) type variables
 instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation)
-instScheme (tvs, ty) 
-  = liftTcM $ do { (tvs', _, subst) <- tcInstTyVars tvs
-                 ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs]
-                 ; return (substTy subst ty, rtti_inst) }
+instScheme (tvs, ty)
+  = do { (subst, tvs') <- instTyVars tvs
+       ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs]
+       ; return (substTy subst ty, rtti_inst) }
 
 applyRevSubst :: RttiInstantiation -> TR ()
 -- Apply the *reverse* substitution in-place to any un-filled-in
@@ -636,13 +634,13 @@ addConstraint actual expected = do
     traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected])
     recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
                                     text "with", ppr expected]) $
+      discardResult $
+      captureConstraints $
       do { (ty1, ty2) <- congruenceNewtypes actual expected
-         ; _  <- captureConstraints $ unifyType ty1 ty2
-         ; return () }
+         ; unifyType Nothing ty1 ty2 }
      -- TOMDO: what about the coercion?
      -- we should consider family instances
 
-
 -- Type & Term reconstruction
 ------------------------------
 cvObtainTerm :: HscEnv -> Int -> Bool -> RttiType -> HValue -> IO Term
@@ -651,7 +649,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
   -- as this is needed to be able to manipulate
   -- them properly
    let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty
-       sigma_old_ty = mkForAllTys old_tvs old_tau
+       sigma_old_ty = mkInvForAllTys old_tvs old_tau
    traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)
    term <-
      if null old_tvs
@@ -661,7 +659,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
         return $ fixFunDictionaries $ expandNewtypes term'
       else do
               (old_ty', rev_subst) <- instScheme quant_old_ty
-              my_ty <- newVar openTypeKind
+              my_ty <- newOpenVar
               when (check1 quant_old_ty) (traceTR (text "check1 passed") >>
                                           addConstraint my_ty old_ty')
               term  <- go max_depth my_ty sigma_old_ty hval
@@ -681,7 +679,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
                       zterm' <- mapTermTypeM
                                  (\ty -> case tcSplitTyConApp_maybe ty of
                                            Just (tc, _:_) | tc /= funTyCon
-                                               -> newVar openTypeKind
+                                               -> newOpenVar
                                            _   -> return ty)
                                  term
                       zonkTerm zterm'
@@ -689,20 +687,23 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
             text "Term obtained: " <> ppr term $$
             text "Type obtained: " <> ppr (termType term))
    return term
-    where 
+    where
   dflags = hsc_dflags hsc_env
 
   go :: Int -> Type -> Type -> HValue -> TcM Term
+   -- I believe that my_ty should not have any enclosing
+   -- foralls, nor any free RuntimeUnk skolems;
+   -- that is partly what the quantifyType stuff achieved
+   --
    -- [SPJ May 11] I don't understand the difference between my_ty and old_ty
 
-  go max_depth _ _ _ | seq max_depth False = undefined
   go 0 my_ty _old_ty a = do
     traceTR (text "Gave up reconstructing a term after" <>
                   int max_depth <> text " steps")
     clos <- trIO $ getClosureData dflags a
     return (Suspension (tipe clos) my_ty a Nothing)
-  go max_depth my_ty old_ty a = do
-    let monomorphic = not(isTyVarTy my_ty)   
+  go !max_depth my_ty old_ty a = do
+    let monomorphic = not(isTyVarTy my_ty)
     -- This ^^^ is a convention. The ancestor tests for
     -- monomorphism and passes a type instead of a tv
     clos <- trIO $ getClosureData dflags a
@@ -722,14 +723,14 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
       MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
              -> do
                   -- Deal with the MutVar# primitive
-                  -- It does not have a constructor at all, 
+                  -- It does not have a constructor at all,
                   -- so we simulate the following one
                   -- MutVar# :: contents_ty -> MutVar# s contents_ty
          traceTR (text "Following a MutVar")
          contents_tv <- newVar liftedTypeKind
          contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
-         ASSERT(isUnliftedTypeKind $ typeKind my_ty) return ()
-         (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy 
+         ASSERT(isUnliftedType my_ty) return ()
+         (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy
                             contents_ty (mkTyConApp tycon [world,contents_ty])
          addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
          x <- go (pred max_depth) contents_tv contents_ty contents
@@ -742,19 +743,19 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
                         then parens (text "already monomorphic: " <> ppr my_ty)
                         else Ppr.empty)
         Right dcname <- dataConInfoPtrToName (infoPtr clos)
-        (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
+        (_,mb_dc)    <- tryTc (tcLookupDataCon dcname)
         case mb_dc of
           Nothing -> do -- This can happen for private constructors compiled -O0
                         -- where the .hi descriptor does not export them
                         -- In such case, we return a best approximation:
                         --  ignore the unpointed args, and recover the pointeds
                         -- This preserves laziness, and should be safe.
-                      traceTR (text "Not constructor" <+> ppr dcname)
+                       traceTR (text "Not constructor" <+> ppr dcname)
                        let dflags = hsc_dflags hsc_env
                            tag = showPpr dflags dcname
-                       vars     <- replicateM (length$ elems$ ptrs clos) 
+                       vars     <- replicateM (length$ elems$ ptrs clos)
                                               (newVar liftedTypeKind)
-                       subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i 
+                       subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
                                               | (i, tv) <- zip [0..] vars]
                        return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
           Just dc -> do
@@ -764,7 +765,8 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
             return (Term my_ty (Right dc) a subTerms)
 
 -- The otherwise case: can be a Thunk,AP,PAP,etc.
-      tipe_clos ->
+      tipe_clos -> do
+         traceTR (text "Unknown closure:" <+> ppr tipe_clos)
          return (Suspension tipe_clos my_ty a Nothing)
 
   -- insert NewtypeWraps around newtypes
@@ -786,44 +788,46 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
 
 extractSubTerms :: (Type -> HValue -> TcM Term)
                 -> Closure -> [Type] -> TcM [Term]
-extractSubTerms recurse clos = liftM thirdOf3 . go 0 (nonPtrs clos)
+extractSubTerms recurse clos = liftM thdOf3 . go 0 (nonPtrs clos)
   where
     go ptr_i ws [] = return (ptr_i, ws, [])
     go ptr_i ws (ty:tys)
       | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
       , isUnboxedTupleTyCon tc
-      = do (ptr_i, ws, terms0) <- go ptr_i ws elem_tys
+                -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
+      = do (ptr_i, ws, terms0) <- go ptr_i ws (dropRuntimeRepArgs elem_tys)
            (ptr_i, ws, terms1) <- go ptr_i ws tys
            return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)
       | otherwise
-      = case repType ty of
-          UnaryRep rep_ty -> do
-            (ptr_i, ws, term0)  <- go_rep ptr_i ws ty (typePrimRep rep_ty)
+      = case typePrimRepArgs ty of
+          [rep_ty] ->  do
+            (ptr_i, ws, term0)  <- go_rep ptr_i ws ty rep_ty
             (ptr_i, ws, terms1) <- go ptr_i ws tys
             return (ptr_i, ws, term0 : terms1)
-          UbxTupleRep rep_tys -> do
-            (ptr_i, ws, terms0) <- go_unary_types ptr_i ws rep_tys
-            (ptr_i, ws, terms1) <- go ptr_i ws tys
-            return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)
+          rep_tys -> do
+           (ptr_i, ws, terms0) <- go_unary_types ptr_i ws rep_tys
+           (ptr_i, ws, terms1) <- go ptr_i ws tys
+           return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)
 
     go_unary_types ptr_i ws [] = return (ptr_i, ws, [])
     go_unary_types ptr_i ws (rep_ty:rep_tys) = do
       tv <- newVar liftedTypeKind
-      (ptr_i, ws, term0)  <- go_rep ptr_i ws tv (typePrimRep rep_ty)
+      (ptr_i, ws, term0)  <- go_rep ptr_i ws tv rep_ty
       (ptr_i, ws, terms1) <- go_unary_types ptr_i ws rep_tys
       return (ptr_i, ws, term0 : terms1)
 
-    go_rep ptr_i ws ty rep = case rep of
-      PtrRep -> do
-        t <- appArr (recurse ty) (ptrs clos) ptr_i
-        return (ptr_i + 1, ws, t)
-      _ -> do
-        dflags <- getDynFlags
-        let (ws0, ws1) = splitAt (primRepSizeW dflags rep) ws
-        return (ptr_i, ws1, Prim ty ws0)
+    go_rep ptr_i ws ty rep
+      | isGcPtrRep rep
+      = do t <- appArr (recurse ty) (ptrs clos) ptr_i
+           return (ptr_i + 1, ws, t)
+      | otherwise
+      = do dflags <- getDynFlags
+           let (ws0, ws1) = splitAt (primRepSizeW dflags rep) ws
+           return (ptr_i, ws1, Prim ty ws0)
 
-    unboxedTupleTerm ty terms = Term ty (Right (tupleCon UnboxedTuple (length terms)))
-                                        (error "unboxedTupleTerm: no HValue for unboxed tuple") terms
+    unboxedTupleTerm ty terms
+      = Term ty (Right (tupleDataCon Unboxed (length terms)))
+                (error "unboxedTupleTerm: no HValue for unboxed tuple") terms
 
 
 -- Fast, breadth-first Type reconstruction
@@ -837,7 +841,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
         then return old_ty
         else do
           (old_ty', rev_subst) <- instScheme sigma_old_ty
-          my_ty <- newVar openTypeKind
+          my_ty <- newOpenVar
           when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
                                       addConstraint my_ty old_ty')
           search (isMonomorphic `fmap` zonkTcType my_ty)
@@ -862,7 +866,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
   search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
                                 int max_depth <> text " steps")
   search stop expand l d =
-    case viewl l of 
+    case viewl l of
       EmptyL  -> return ()
       x :< xx -> unlessM stop $ do
                   new <- expand x
@@ -885,13 +889,12 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
       Constr -> do
         Right dcname <- dataConInfoPtrToName (infoPtr clos)
         traceTR (text "Constr1" <+> ppr dcname)
-        (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
+        (_,mb_dc)    <- tryTc (tcLookupDataCon dcname)
         case mb_dc of
           Nothing-> do
-                     --  TODO: Check this case
-            forM [0..length (elems $ ptrs clos)] $ \i -> do
-                        tv <- newVar liftedTypeKind
-                        return$ appArr (\e->(tv,e)) (ptrs clos) i
+            forM (elems $ ptrs clos) $ \a -> do
+              tv <- newVar liftedTypeKind
+              return (tv, a)
 
           Just dc -> do
             arg_tys <- getDataConArgTys dc my_ty
@@ -908,56 +911,51 @@ findPtrTys i ty
   | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
   , isUnboxedTupleTyCon tc
   = findPtrTyss i elem_tys
-  
+
   | otherwise
-  = case repType ty of
-      UnaryRep rep_ty | typePrimRep rep_ty == PtrRep -> return (i + 1, [(i, ty)])
-                      | otherwise                    -> return (i,     [])
-      UbxTupleRep rep_tys  -> foldM (\(i, extras) rep_ty -> if typePrimRep rep_ty == PtrRep
-                                                             then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)])
-                                                             else return (i, extras))
-                                    (i, []) rep_tys
+  = case typePrimRep ty of
+      [rep] | isGcPtrRep rep -> return (i + 1, [(i, ty)])
+            | otherwise      -> return (i,     [])
+      prim_reps              ->
+        foldM (\(i, extras) prim_rep ->
+                if isGcPtrRep prim_rep
+                  then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)])
+                  else return (i, extras))
+              (i, []) prim_reps
 
 findPtrTyss :: Int
             -> [Type]
             -> TR (Int, [(Int, Type)])
 findPtrTyss i tys = foldM step (i, []) tys
-  where step (i, discovered) elem_ty = findPtrTys i elem_ty >>= \(i, extras) -> return (i, discovered ++ extras)
+  where step (i, discovered) elem_ty = do
+          (i, extras) <- findPtrTys i elem_ty
+          return (i, discovered ++ extras)
 
 
 -- 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 -> RttiType -> RttiType -> Maybe TvSubst
-improveRTTIType _ base_ty new_ty
-  = U.tcUnifyTys (const U.BindMe) [base_ty] [new_ty]
+improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TCvSubst
+improveRTTIType _ base_ty new_ty = U.tcUnifyTyKi base_ty new_ty
 
 getDataConArgTys :: DataCon -> Type -> TR [Type]
--- Given the result type ty of a constructor application (D a b c :: ty) 
+-- Given the result type ty of a constructor application (D a b c :: ty)
 -- return the types of the arguments.  This is RTTI-land, so 'ty' might
 -- not be fully known.  Moreover, the arg types might involve existentials;
 -- if so, make up fresh RTTI type variables for them
+--
+-- I believe that con_app_ty should not have any enclosing foralls
 getDataConArgTys dc con_app_ty
-  = do { (_, ex_tys, ex_subst) <- instTyVars ex_tvs
-       ; let UnaryRep rep_con_app_ty = repType con_app_ty
-       ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty))
-       ; ty_args <- case tcSplitTyConApp_maybe rep_con_app_ty of
-                       Just (tc, ty_args) | dataConTyCon dc == tc
-                          -> ASSERT( univ_tvs `equalLength` ty_args) 
-                              return ty_args
-                      _   -> do { (_, ty_args, univ_subst) <- instTyVars univ_tvs
-                                ; let res_ty = substTy ex_subst (substTy univ_subst (dataConOrigResTy dc))
-                                   -- See Note [Constructor arg types]
-                                 ; addConstraint rep_con_app_ty res_ty
-                                 ; return ty_args }
-               -- It is necessary to check dataConTyCon dc == tc
-               -- because it may be the case that tc is a recursive
-               -- newtype and tcSplitTyConApp has not removed it. In
-               -- that case, we happily give up and don't match
-       ; let subst = zipTopTvSubst (univ_tvs ++ ex_tvs) (ty_args ++ ex_tys)
-       ; traceTR (text "getDataConArgTys 2" <+> (ppr rep_con_app_ty $$ ppr ty_args $$ ppr subst))
-       ; return (substTys subst (dataConRepArgTys dc)) }
+  = do { let rep_con_app_ty = unwrapType con_app_ty
+       ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty
+                   $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty)))
+       ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs)
+       ; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc))
+              -- See Note [Constructor arg types]
+       ; let con_arg_tys = substTys subst (dataConRepArgTys dc)
+       ; traceTR (text "getDataConArgTys 2" <+> (ppr rep_con_app_ty $$ ppr con_arg_tys $$ ppr subst))
+       ; return con_arg_tys }
   where
     univ_tvs = dataConUnivTyVars dc
     ex_tvs   = dataConExTyVars dc
@@ -966,19 +964,21 @@ getDataConArgTys dc con_app_ty
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider a GADT (cf Trac #7386)
    data family D a b
-   data instance D [a] b where
-     MkT :: b -> D [a] (Maybe b)
+   data instance D [a] a where
+     MkT :: a -> D [a] (Maybe a)
+     ...
 
 In getDataConArgTys
-* con_app_ty is the known type (from outside) of the constructor application, 
-  say D [Int] Bool
+* con_app_ty is the known type (from outside) of the constructor application,
+  say D [Int] Int
 
 * The data constructor MkT has a (representation) dataConTyCon = DList,
   say where
-    data DList a b where
-      MkT :: b -> DList a (Maybe b)
+    data DList a where
+      MkT :: a -> DList a (Maybe a)
+      ...
 
-So the dataConTyCon of the data constructor, DList, differs from 
+So the dataConTyCon of the data constructor, DList, differs from
 the "outside" type, D. So we can't straightforwardly decompose the
 "outside" type, and we end up in the "_" branch of the case.
 
@@ -1104,7 +1104,7 @@ If that is not the case, then we consider two conditions.
 check1 :: QuantifiedType -> Bool
 check1 (tvs, _) = not $ any isHigherKind (map tyVarKind tvs)
  where
-   isHigherKind = not . null . fst . splitKindFunTys
+   isHigherKind = not . null . fst . splitPiTys
 
 check2 :: QuantifiedType -> QuantifiedType -> Bool
 check2 (_, rtti_ty) (_, old_ty)
@@ -1120,9 +1120,9 @@ check2 (_, rtti_ty) (_, old_ty)
 -- Dealing with newtypes
 --------------------------
 {-
- congruenceNewtypes does a parallel fold over two Type values, 
- compensating for missing newtypes on both sides. 
- This is necessary because newtypes are not present 
+ 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 sometimes there is evidence available.
    Evidence can come from DataCon signatures or
  from compile-time type inference.
@@ -1168,8 +1168,8 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
          return (mkFunTy r1' r2')
 -- TyconApp Inductive case; this is the interesting bit.
     | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
-    , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs 
-    , tycon_l /= tycon_r 
+    , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
+    , tycon_l /= tycon_r
     = upgrade tycon_l r
 
     | otherwise = return r
@@ -1179,15 +1179,15 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
             | not (isNewTyCon new_tycon) = do
               traceTR (text "(Upgrade) Not matching newtype evidence: " <>
                        ppr new_tycon <> text " for " <> ppr ty)
-              return ty 
+              return ty
             | otherwise = do
                traceTR (text "(Upgrade) upgraded " <> ppr ty <>
                         text " in presence of newtype evidence " <> ppr new_tycon)
-               (_, vars, _) <- instTyVars (tyConTyVars new_tycon)
-               let ty' = mkTyConApp new_tycon vars
-                   UnaryRep rep_ty = repType ty'
-               _ <- liftTcM (unifyType ty rep_ty)
-        -- assumes that reptype doesn't ^^^^ touch tyconApp args 
+               (_, vars) <- instTyVars (tyConTyVars new_tycon)
+               let ty' = mkTyConApp new_tycon (mkTyVarTys vars)
+                   rep_ty = unwrapType ty'
+               _ <- liftTcM (unifyType Nothing ty rep_ty)
+        -- assumes that reptype doesn't ^^^^ touch tyconApp args
                return ty'
 
 
@@ -1199,7 +1199,7 @@ zonkTerm = foldTermM (TermFoldM
                                              return (Suspension ct ty v b)
              , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' ->
                                            return$ NewtypeWrap ty' dc t
-             , fRefWrapM     = \ty t -> return RefWrap  `ap` 
+             , fRefWrapM     = \ty t -> return RefWrap  `ap`
                                         zonkRttiType ty `ap` return t
              , fPrimM        = (return.) . Prim })
 
@@ -1208,13 +1208,13 @@ zonkRttiType :: TcType -> TcM Type
 -- by skolems, safely out of Meta-tyvar-land
 zonkRttiType = zonkTcTypeToType (mkEmptyZonkEnv zonk_unbound_meta)
   where
-    zonk_unbound_meta tv 
+    zonk_unbound_meta tv
       = ASSERT( isTcTyVar tv )
-        do { tv' <- skolemiseUnboundMetaTyVar tv RuntimeUnk
-            -- This is where RuntimeUnks are born: 
-            -- otherwise-unconstrained unification variables are
-            -- turned into RuntimeUnks as they leave the
-            -- typechecker's monad
+        do { tv' <- skolemiseRuntimeUnk tv
+             -- This is where RuntimeUnks are born:
+             -- otherwise-unconstrained unification variables are
+             -- turned into RuntimeUnks as they leave the
+             -- typechecker's monad
            ; return (mkTyVarTy tv') }
 
 --------------------------------------------------------------------------------
@@ -1227,14 +1227,13 @@ dictsView ty = ty
 isMonomorphic :: RttiType -> Bool
 isMonomorphic ty = noExistentials && noUniversals
  where (tvs, _, ty')  = tcSplitSigmaTy ty
-       noExistentials = isEmptyVarSet (tyVarsOfType ty')
+       noExistentials = noFreeVarsOfType ty'
        noUniversals   = null tvs
 
 -- Use only for RTTI types
 isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
 isMonomorphicOnNonPhantomArgs ty
-  | UnaryRep rep_ty <- repType ty
-  , Just (tc, all_args) <- tcSplitTyConApp_maybe rep_ty
+  | Just (tc, all_args) <- tcSplitTyConApp_maybe (unwrapType ty)
   , phantom_vars  <- tyConPhantomTyVars tc
   , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args
                            , tyv `notElem` phantom_vars]
@@ -1251,20 +1250,28 @@ tyConPhantomTyVars tc
   = tyConTyVars tc \\ dc_vars
 tyConPhantomTyVars _ = []
 
-type QuantifiedType = ([TyVar], Type)   -- Make the free type variables explicit
+type QuantifiedType = ([TyVar], Type)
+   -- Make the free type variables explicit
+   -- The returned Type should have no top-level foralls (I believe)
 
 quantifyType :: Type -> QuantifiedType
--- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
-quantifyType ty = (varSetElems (tyVarsOfType ty), ty)
-
-unlessM :: Monad m => m Bool -> m () -> m ()
-unlessM condM acc = condM >>= \c -> unless c acc
+-- Generalize the type: find all free and forall'd tyvars
+-- and return them, together with the type inside, which
+-- should not be a forall type.
+--
+-- Thus (quantifyType (forall a. a->[b]))
+-- returns ([a,b], a -> [b])
 
+quantifyType ty = ( filter isTyVar $
+                    tyCoVarsOfTypeWellScoped rho
+                  , rho)
+  where
+    (_tvs, rho) = tcSplitForAllTys ty
 
 -- Strict application of f at index i
 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
- = ASSERT2 (i < length(elems a), ppr(length$ elems a, i))
+ = ASSERT2(i < length(elems a), ppr(length$ elems a, i))
    case indexArray# ptrs# i# of
        (# e #) -> f e