compiler/ghci/RtClosureInspect.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- GHC Interactive support for inspecting arbitrary closures at runtime
   4 --
   5 -- Pepe Iborra (supported by Google SoC) 2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module RtClosureInspect(
  10      cvObtainTerm,      -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
  11      cvReconstructType,
  12      improveRTTIType,
  13
  14      Term(..),
  15      isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap,
  16      isFullyEvaluated, isFullyEvaluatedTerm,
  17      termType, mapTermType, termTyVars,
  18      foldTerm, TermFold(..), foldTermM, TermFoldM(..), idTermFold,
  19      pprTerm, cPprTerm, cPprTermBase, CustomTermPrinter,
  20
  21 --     unsafeDeepSeq,
  22
  23      Closure(..), getClosureData, ClosureType(..), isConstr, isIndirection
  24  ) where
  25
  26 #include "HsVersions.h"
  27
  28 import ByteCodeItbls    ( StgInfoTable )
  29 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
  30 import HscTypes
  31 import Linker
  32
  33 import DataCon
  34 import Type
  35 import qualified Unify as U
  36 import TypeRep         -- I know I know, this is cheating
  37 import Var
  38 import TcRnMonad
  39 import TcType
  40 import TcMType
  41 import TcUnify
  42 import TcEnv
  43
  44 import TyCon
  45 import Name
  46 import VarEnv
  47 import Util
  48 import VarSet
  49 import TysPrim
  50 import PrelNames
  51 import TysWiredIn
  52 import DynFlags
  53 import Outputable as Ppr
  54 import FastString
  55 import Constants        ( wORD_SIZE )
  56 import GHC.Arr          ( Array(..) )
  57 import GHC.Exts
  58 import GHC.IO ( IO(..) )
  59
  60 import StaticFlags( opt_PprStyle_Debug )
  61 import Control.Monad
  62 import Data.Maybe
  63 import Data.Array.Base
  64 import Data.Ix
  65 import Data.List
  66 import qualified Data.Sequence as Seq
  67 import Data.Monoid
  68 import Data.Sequence (viewl, ViewL(..))
  69 import Foreign hiding (unsafePerformIO)
  70 import System.IO.Unsafe
  71
  72 ---------------------------------------------
  73 -- * A representation of semi evaluated Terms
  74 ---------------------------------------------
  75
  76 data Term = Term { ty        :: RttiType
  77                  , dc        :: Either String DataCon
  78                                -- Carries a text representation if the datacon is
  79                                -- not exported by the .hi file, which is the case
  80                                -- for private constructors in -O0 compiled libraries
  81                  , val       :: HValue
  82                  , subTerms  :: [Term] }
  83
  84           | Prim { ty        :: RttiType
  85                  , value     :: [Word] }
  86
  87           | Suspension { ctype    :: ClosureType
  88                        , ty       :: RttiType
  89                        , val      :: HValue
  90                        , bound_to :: Maybe Name   -- Useful for printing
  91                        }
  92           | NewtypeWrap{       -- At runtime there are no newtypes, and hence no
  93                                -- newtype constructors. A NewtypeWrap is just a
  94                                -- made-up tag saying "heads up, there used to be
  95                                -- a newtype constructor here".
  96                          ty           :: RttiType
  97                        , dc           :: Either String DataCon
  98                        , wrapped_term :: Term }
  99           | RefWrap    {       -- The contents of a reference
 100                          ty           :: RttiType
 101                        , wrapped_term :: Term }
 102
 103 isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap :: Term -> Bool
 104 isTerm Term{} = True
 105 isTerm   _    = False
 106 isSuspension Suspension{} = True
 107 isSuspension      _       = False
 108 isPrim Prim{} = True
 109 isPrim   _    = False
 110 isNewtypeWrap NewtypeWrap{} = True
 111 isNewtypeWrap _             = False
 112
 113 isFun Suspension{ctype=Fun} = True
 114 isFun _ = False
 115
 116 isFunLike s@Suspension{ty=ty} = isFun s || isFunTy ty
 117 isFunLike _ = False
 118
 119 termType :: Term -> RttiType
 120 termType t = ty t
 121
 122 isFullyEvaluatedTerm :: Term -> Bool
 123 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
 124 isFullyEvaluatedTerm Prim {}            = True
 125 isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
 126 isFullyEvaluatedTerm RefWrap{wrapped_term=t}     = isFullyEvaluatedTerm t
 127 isFullyEvaluatedTerm _                  = False
 128
 129 instance Outputable (Term) where
 130  ppr t | Just doc <- cPprTerm cPprTermBase t = doc
 131        | otherwise = panic "Outputable Term instance"
 132
 133 -------------------------------------------------------------------------
 134 -- Runtime Closure Datatype and functions for retrieving closure related stuff
 135 -------------------------------------------------------------------------
 136 data ClosureType = Constr
 137                  | Fun
 138                  | Thunk Int
 139                  | ThunkSelector
 140                  | Blackhole
 141                  | AP
 142                  | PAP
 143                  | Indirection Int
 144                  | MutVar Int
 145                  | MVar   Int
 146                  | Other  Int
 147  deriving (Show, Eq)
 148
 149 data Closure = Closure { tipe         :: ClosureType
 150                        , infoPtr      :: Ptr ()
 151                        , infoTable    :: StgInfoTable
 152                        , ptrs         :: Array Int HValue
 153                        , nonPtrs      :: [Word]
 154                        }
 155
 156 instance Outputable ClosureType where
 157   ppr = text . show
 158
 159 #include "../includes/rts/storage/ClosureTypes.h"
 160
 161 aP_CODE, pAP_CODE :: Int
 162 aP_CODE = AP
 163 pAP_CODE = PAP
 164 #undef AP
 165 #undef PAP
 166
 167 getClosureData :: a -> IO Closure
 168 getClosureData a =
 169    case unpackClosure# a of
 170      (# iptr, ptrs, nptrs #) -> do
 171            let iptr'
 172                 | ghciTablesNextToCode =
 173                    Ptr iptr
 174                 | otherwise =
 175                    -- the info pointer we get back from unpackClosure#
 176                    -- is to the beginning of the standard info table,
 177                    -- but the Storable instance for info tables takes
 178                    -- into account the extra entry pointer when
 179                    -- !ghciTablesNextToCode, so we must adjust here:
 180                    Ptr iptr `plusPtr` negate wORD_SIZE
 181            itbl <- peek iptr'
 182            let tipe = readCType (BCI.tipe itbl)
 183                elems = fromIntegral (BCI.ptrs itbl)
 184                ptrsList = Array 0 (elems - 1) elems ptrs
 185                nptrs_data = [W# (indexWordArray# nptrs i)
 186                               | I# i <- [0.. fromIntegral (BCI.nptrs itbl)-1] ]
 187            ASSERT(elems >= 0) return ()
 188            ptrsList `seq`
 189             return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
 190
 191 readCType :: Integral a => a -> ClosureType
 192 readCType i
 193  | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
 194  | i >= FUN    && i <= FUN_STATIC          = Fun
 195  | i >= THUNK  && i < THUNK_SELECTOR       = Thunk i'
 196  | i == THUNK_SELECTOR                     = ThunkSelector
 197  | i == BLACKHOLE                          = Blackhole
 198  | i >= IND    && i <= IND_STATIC          = Indirection i'
 199  | i' == aP_CODE                           = AP
 200  | i == AP_STACK                           = AP
 201  | i' == pAP_CODE                          = PAP
 202  | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY= MutVar i'
 203  | i == MVAR_CLEAN    || i == MVAR_DIRTY   = MVar i'
 204  | otherwise                               = Other  i'
 205   where i' = fromIntegral i
 206
 207 isConstr, isIndirection, isThunk :: ClosureType -> Bool
 208 isConstr Constr = True
 209 isConstr    _   = False
 210
 211 isIndirection (Indirection _) = True
 212 isIndirection _ = False
 213
 214 isThunk (Thunk _)     = True
 215 isThunk ThunkSelector = True
 216 isThunk AP            = True
 217 isThunk _             = False
 218
 219 isFullyEvaluated :: a -> IO Bool
 220 isFullyEvaluated a = do
 221   closure <- getClosureData a
 222   case tipe closure of
 223     Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
 224                  return$ and are_subs_evaluated
 225     _      -> return False
 226   where amapM f = sequence . amap' f
 227
 228 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
 229 {-
 230 unsafeDeepSeq :: a -> b -> b
 231 unsafeDeepSeq = unsafeDeepSeq1 2
 232  where unsafeDeepSeq1 0 a b = seq a $! b
 233        unsafeDeepSeq1 i a b   -- 1st case avoids infinite loops for non reducible thunks
 234         | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
 235      -- | unsafePerformIO (isFullyEvaluated a) = b
 236         | otherwise = case unsafePerformIO (getClosureData a) of
 237                         closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
 238         where tipe = unsafePerformIO (getClosureType a)
 239 -}
 240
 241 -----------------------------------
 242 -- * Traversals for Terms
 243 -----------------------------------
 244 type TermProcessor a b = RttiType -> Either String DataCon -> HValue -> [a] -> b
 245
 246 data TermFold a = TermFold { fTerm        :: TermProcessor a a
 247                            , fPrim        :: RttiType -> [Word] -> a
 248                            , fSuspension  :: ClosureType -> RttiType -> HValue
 249                                             -> Maybe Name -> a
 250                            , fNewtypeWrap :: RttiType -> Either String DataCon
 251                                             -> a -> a
 252                            , fRefWrap     :: RttiType -> a -> a
 253                            }
 254
 255
 256 data TermFoldM m a =
 257                    TermFoldM {fTermM        :: TermProcessor a (m a)
 258                             , fPrimM        :: RttiType -> [Word] -> m a
 259                             , fSuspensionM  :: ClosureType -> RttiType -> HValue
 260                                              -> Maybe Name -> m a
 261                             , fNewtypeWrapM :: RttiType -> Either String DataCon
 262                                             -> a -> m a
 263                             , fRefWrapM     :: RttiType -> a -> m a
 264                            }
 265
 266 foldTerm :: TermFold a -> Term -> a
 267 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
 268 foldTerm tf (Prim ty    v   ) = fPrim tf ty v
 269 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
 270 foldTerm tf (NewtypeWrap ty dc t)  = fNewtypeWrap tf ty dc (foldTerm tf t)
 271 foldTerm tf (RefWrap ty t)         = fRefWrap tf ty (foldTerm tf t)
 272
 273
 274 foldTermM :: Monad m => TermFoldM m a -> Term -> m a
 275 foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v
 276 foldTermM tf (Prim ty    v   ) = fPrimM tf ty v
 277 foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b
 278 foldTermM tf (NewtypeWrap ty dc t)  = foldTermM tf t >>=  fNewtypeWrapM tf ty dc
 279 foldTermM tf (RefWrap ty t)         = foldTermM tf t >>= fRefWrapM tf ty
 280
 281 idTermFold :: TermFold Term
 282 idTermFold = TermFold {
 283               fTerm = Term,
 284               fPrim = Prim,
 285               fSuspension  = Suspension,
 286               fNewtypeWrap = NewtypeWrap,
 287               fRefWrap = RefWrap
 288                       }
 289
 290 mapTermType :: (RttiType -> Type) -> Term -> Term
 291 mapTermType f = foldTerm idTermFold {
 292           fTerm       = \ty dc hval tt -> Term (f ty) dc hval tt,
 293           fSuspension = \ct ty hval n ->
 294                           Suspension ct (f ty) hval n,
 295           fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
 296           fRefWrap    = \ty t -> RefWrap (f ty) t}
 297
 298 mapTermTypeM :: Monad m =>  (RttiType -> m Type) -> Term -> m Term
 299 mapTermTypeM f = foldTermM TermFoldM {
 300           fTermM       = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty'  dc hval tt,
 301           fPrimM       = (return.) . Prim,
 302           fSuspensionM = \ct ty hval n ->
 303                           f ty >>= \ty' -> return $ Suspension ct ty' hval n,
 304           fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t,
 305           fRefWrapM    = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t}
 306
 307 termTyVars :: Term -> TyVarSet
 308 termTyVars = foldTerm TermFold {
 309             fTerm       = \ty _ _ tt   ->
 310                           tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
 311             fSuspension = \_ ty _ _ -> tyVarsOfType ty,
 312             fPrim       = \ _ _ -> emptyVarEnv,
 313             fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t,
 314             fRefWrap    = \ty t -> tyVarsOfType ty `plusVarEnv` t}
 315     where concatVarEnv = foldr plusVarEnv emptyVarEnv
 316
 317 ----------------------------------
 318 -- Pretty printing of terms
 319 ----------------------------------
 320
 321 type Precedence        = Int
 322 type TermPrinter       = Precedence -> Term ->   SDoc
 323 type TermPrinterM m    = Precedence -> Term -> m SDoc
 324
 325 app_prec,cons_prec, max_prec ::Int
 326 max_prec  = 10
 327 app_prec  = max_prec
 328 cons_prec = 5 -- TODO Extract this info from GHC itself
 329
 330 pprTerm :: TermPrinter -> TermPrinter
 331 pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
 332 pprTerm _ _ _ = panic "pprTerm"
 333
 334 pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
 335 pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
 336
 337 ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
 338   tt_docs <- mapM (y app_prec) tt
 339   return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
 340
 341 ppr_termM y p Term{dc=Right dc, subTerms=tt}
 342 {-  | dataConIsInfix dc, (t1:t2:tt') <- tt  --TODO fixity
 343   = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
 344     <+> hsep (map (ppr_term1 True) tt)
 345 -} -- TODO Printing infix constructors properly
 346   | null sub_terms_to_show
 347   = return (ppr dc)
 348   | otherwise
 349   = do { tt_docs <- mapM (y app_prec) sub_terms_to_show
 350        ; return $ cparen (p >= app_prec) $
 351          sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] }
 352   where
 353     sub_terms_to_show   -- Don't show the dictionary arguments to
 354                         -- constructors unless -dppr-debug is on
 355       | opt_PprStyle_Debug = tt
 356       | otherwise = dropList (dataConTheta dc) tt
 357
 358 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
 359 ppr_termM y p RefWrap{wrapped_term=t}  = do
 360   contents <- y app_prec t
 361   return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
 362   -- The constructor name is wired in here ^^^ for the sake of simplicity.
 363   -- I don't think mutvars are going to change in a near future.
 364   -- In any case this is solely a presentation matter: MutVar# is
 365   -- a datatype with no constructors, implemented by the RTS
 366   -- (hence there is no way to obtain a datacon and print it).
 367 ppr_termM _ _ t = ppr_termM1 t
 368
 369
 370 ppr_termM1 :: Monad m => Term -> m SDoc
 371 ppr_termM1 Prim{value=words, ty=ty} =
 372     return$ text$ repPrim (tyConAppTyCon ty) words
 373 ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
 374     return (char '_' <+> ifPprDebug (text "::" <> ppr ty))
 375 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
 376 --  | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")
 377   | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
 378 ppr_termM1 Term{}        = panic "ppr_termM1 - Term"
 379 ppr_termM1 RefWrap{}     = panic "ppr_termM1 - RefWrap"
 380 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
 381
 382 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
 383   | Just (tc,_) <- tcSplitTyConApp_maybe ty
 384   , ASSERT(isNewTyCon tc) True
 385   , Just new_dc <- tyConSingleDataCon_maybe tc = do
 386              real_term <- y max_prec t
 387              return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)
 388 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
 389
 390 -------------------------------------------------------
 391 -- Custom Term Pretty Printers
 392 -------------------------------------------------------
 393
 394 -- We can want to customize the representation of a
 395 --  term depending on its type.
 396 -- However, note that custom printers have to work with
 397 --  type representations, instead of directly with types.
 398 -- We cannot use type classes here, unless we employ some
 399 --  typerep trickery (e.g. Weirich's RepLib tricks),
 400 --  which I didn't. Therefore, this code replicates a lot
 401 --  of what type classes provide for free.
 402
 403 type CustomTermPrinter m = TermPrinterM m
 404                          -> [Precedence -> Term -> (m (Maybe SDoc))]
 405
 406 -- | Takes a list of custom printers with a explicit recursion knot and a term,
 407 -- and returns the output of the first succesful printer, or the default printer
 408 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
 409 cPprTerm printers_ = go 0 where
 410   printers = printers_ go
 411   go prec t = do
 412     let default_ = Just `liftM` pprTermM go prec t
 413         mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
 414     Just doc <- firstJustM mb_customDocs
 415     return$ cparen (prec>app_prec+1) doc
 416
 417   firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
 418   firstJustM [] = return Nothing
 419
 420 -- Default set of custom printers. Note that the recursion knot is explicit
 421 cPprTermBase :: forall m. Monad m => CustomTermPrinter m
 422 cPprTermBase y =
 423   [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
 424                                       . mapM (y (-1))
 425                                       . subTerms)
 426   , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
 427            ppr_list
 428   , ifTerm (isTyCon intTyCon    . ty) ppr_int
 429   , ifTerm (isTyCon charTyCon   . ty) ppr_char
 430   , ifTerm (isTyCon floatTyCon  . ty) ppr_float
 431   , ifTerm (isTyCon doubleTyCon . ty) ppr_double
 432   , ifTerm (isIntegerTy         . ty) ppr_integer
 433   ]
 434  where
 435    ifTerm :: (Term -> Bool)
 436           -> (Precedence -> Term -> m SDoc)
 437           -> Precedence -> Term -> m (Maybe SDoc)
 438    ifTerm pred f prec t@Term{}
 439        | pred t    = Just `liftM` f prec t
 440    ifTerm _ _ _ _  = return Nothing
 441
 442    isTupleTy ty    = fromMaybe False $ do
 443      (tc,_) <- tcSplitTyConApp_maybe ty
 444      return (isBoxedTupleTyCon tc)
 445
 446    isTyCon a_tc ty = fromMaybe False $ do
 447      (tc,_) <- tcSplitTyConApp_maybe ty
 448      return (a_tc == tc)
 449
 450    isIntegerTy ty = fromMaybe False $ do
 451      (tc,_) <- tcSplitTyConApp_maybe ty
 452      return (tyConName tc == integerTyConName)
 453
 454    ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer
 455       :: Precedence -> Term -> m SDoc
 456    ppr_int     _ v = return (Ppr.int     (unsafeCoerce# (val v)))
 457    ppr_char    _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'')
 458    ppr_float   _ v = return (Ppr.float   (unsafeCoerce# (val v)))
 459    ppr_double  _ v = return (Ppr.double  (unsafeCoerce# (val v)))
 460    ppr_integer _ v = return (Ppr.integer (unsafeCoerce# (val v)))
 461
 462    --Note pprinting of list terms is not lazy
 463    ppr_list :: Precedence -> Term -> m SDoc
 464    ppr_list p (Term{subTerms=[h,t]}) = do
 465        let elems      = h : getListTerms t
 466            isConsLast = not(termType(last elems) `eqType` termType h)
 467            is_string  = all (isCharTy . ty) elems
 468
 469        print_elems <- mapM (y cons_prec) elems
 470        if is_string
 471         then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems))))
 472         else if isConsLast
 473         then return $ cparen (p >= cons_prec)
 474                     $ pprDeeperList fsep
 475                     $ punctuate (space<>colon) print_elems
 476         else return $ brackets
 477                     $ pprDeeperList fcat
 478                     $ punctuate comma print_elems
 479
 480         where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
 481               getListTerms Term{subTerms=[]}    = []
 482               getListTerms t@Suspension{}       = [t]
 483               getListTerms t = pprPanic "getListTerms" (ppr t)
 484    ppr_list _ _ = panic "doList"
 485
 486
 487 repPrim :: TyCon -> [Word] -> String
 488 repPrim t = rep where
 489    rep x
 490     | t == charPrimTyCon   = show (build x :: Char)
 491     | t == intPrimTyCon    = show (build x :: Int)
 492     | t == wordPrimTyCon   = show (build x :: Word)
 493     | t == floatPrimTyCon  = show (build x :: Float)
 494     | t == doublePrimTyCon = show (build x :: Double)
 495     | t == int32PrimTyCon  = show (build x :: Int32)
 496     | t == word32PrimTyCon = show (build x :: Word32)
 497     | t == int64PrimTyCon  = show (build x :: Int64)
 498     | t == word64PrimTyCon = show (build x :: Word64)
 499     | t == addrPrimTyCon   = show (nullPtr `plusPtr` build x)
 500     | t == stablePtrPrimTyCon  = "<stablePtr>"
 501     | t == stableNamePrimTyCon = "<stableName>"
 502     | t == statePrimTyCon      = "<statethread>"
 503     | t == realWorldTyCon      = "<realworld>"
 504     | t == threadIdPrimTyCon   = "<ThreadId>"
 505     | t == weakPrimTyCon       = "<Weak>"
 506     | t == arrayPrimTyCon      = "<array>"
 507     | t == byteArrayPrimTyCon  = "<bytearray>"
 508     | t == mutableArrayPrimTyCon = "<mutableArray>"
 509     | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
 510     | t == mutVarPrimTyCon= "<mutVar>"
 511     | t == mVarPrimTyCon  = "<mVar>"
 512     | t == tVarPrimTyCon  = "<tVar>"
 513     | otherwise = showSDoc (char '<' <> ppr t <> char '>')
 514     where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
 515 --   This ^^^ relies on the representation of Haskell heap values being
 516 --   the same as in a C array.
 517
 518 -----------------------------------
 519 -- Type Reconstruction
 520 -----------------------------------
 521 {-
 522 Type Reconstruction is type inference done on heap closures.
 523 The algorithm walks the heap generating a set of equations, which
 524 are solved with syntactic unification.
 525 A type reconstruction equation looks like:
 526
 527   <datacon reptype>  =  <actual heap contents>
 528
 529 The full equation set is generated by traversing all the subterms, starting
 530 from a given term.
 531
 532 The only difficult part is that newtypes are only found in the lhs of equations.
 533 Right hand sides are missing them. We can either (a) drop them from the lhs, or
 534 (b) reconstruct them in the rhs when possible.
 535
 536 The function congruenceNewtypes takes a shot at (b)
 537 -}
 538
 539
 540 -- A (non-mutable) tau type containing
 541 -- existentially quantified tyvars.
 542 --    (since GHC type language currently does not support
 543 --     existentials, we leave these variables unquantified)
 544 type RttiType = Type
 545
 546 -- An incomplete type as stored in GHCi:
 547 --  no polymorphism: no quantifiers & all tyvars are skolem.
 548 type GhciType = Type
 549
 550
 551 -- The Type Reconstruction monad
 552 --------------------------------
 553 type TR a = TcM a
 554
 555 runTR :: HscEnv -> TR a -> IO a
 556 runTR hsc_env thing = do
 557   mb_val <- runTR_maybe hsc_env thing
 558   case mb_val of
 559     Nothing -> error "unable to :print the term"
 560     Just x  -> return x
 561
 562 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
 563 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False  iNTERACTIVE
 564
 565 traceTR :: SDoc -> TR ()
 566 traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti
 567
 568
 569 -- Semantically different to recoverM in TcRnMonad
 570 -- recoverM retains the errors in the first action,
 571 --  whereas recoverTc here does not
 572 recoverTR :: TR a -> TR a -> TR a
 573 recoverTR recover thing = do
 574   (_,mb_res) <- tryTcErrs thing
 575   case mb_res of
 576     Nothing  -> recover
 577     Just res -> return res
 578
 579 trIO :: IO a -> TR a
 580 trIO = liftTcM . liftIO
 581
 582 liftTcM :: TcM a -> TR a
 583 liftTcM = id
 584
 585 newVar :: Kind -> TR TcType
 586 newVar = liftTcM . newFlexiTyVarTy
 587
 588 instTyVars :: [TyVar] -> TR ([TcTyVar], [TcType], TvSubst)
 589 -- Instantiate fresh mutable type variables from some TyVars
 590 -- This function preserves the print-name, which helps error messages
 591 instTyVars = liftTcM . tcInstTyVars
 592
 593 type RttiInstantiation = [(TcTyVar, TyVar)]
 594    -- Associates the typechecker-world meta type variables
 595    -- (which are mutable and may be refined), to their
 596    -- debugger-world RuntimeUnk counterparts.
 597    -- If the TcTyVar has not been refined by the runtime type
 598    -- elaboration, then we want to turn it back into the
 599    -- original RuntimeUnk
 600
 601 -- | Returns the instantiated type scheme ty', and the
 602 --   mapping from new (instantiated) -to- old (skolem) type variables
 603 instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation)
 604 instScheme (tvs, ty)
 605   = liftTcM $ do { (tvs', _, subst) <- tcInstTyVars tvs
 606                  ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs]
 607                  ; return (substTy subst ty, rtti_inst) }
 608
 609 applyRevSubst :: RttiInstantiation -> TR ()
 610 -- Apply the *reverse* substitution in-place to any un-filled-in
 611 -- meta tyvars.  This recovers the original debugger-world variable
 612 -- unless it has been refined by new information from the heap
 613 applyRevSubst pairs = liftTcM (mapM_ do_pair pairs)
 614   where
 615     do_pair (tc_tv, rtti_tv)
 616       = do { tc_ty <- zonkTcTyVar tc_tv
 617            ; case tcGetTyVar_maybe tc_ty of
 618                Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv)
 619                _                        -> return () }
 620
 621 -- Adds a constraint of the form t1 == t2
 622 -- t1 is expected to come from walking the heap
 623 -- t2 is expected to come from a datacon signature
 624 -- Before unification, congruenceNewtypes needs to
 625 -- do its magic.
 626 addConstraint :: TcType -> TcType -> TR ()
 627 addConstraint actual expected = do
 628     traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected])
 629     recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
 630                                     text "with", ppr expected]) $
 631       do { (ty1, ty2) <- congruenceNewtypes actual expected
 632          ; _  <- captureConstraints $ unifyType ty1 ty2
 633          ; return () }
 634      -- TOMDO: what about the coercion?
 635      -- we should consider family instances
 636
 637
 638 -- Type & Term reconstruction
 639 ------------------------------
 640 cvObtainTerm :: HscEnv -> Int -> Bool -> RttiType -> HValue -> IO Term
 641 cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
 642   -- we quantify existential tyvars as universal,
 643   -- as this is needed to be able to manipulate
 644   -- them properly
 645    let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty
 646        sigma_old_ty = mkForAllTys old_tvs old_tau
 647    traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)
 648    term <-
 649      if null old_tvs
 650       then do
 651         term  <- go max_depth sigma_old_ty sigma_old_ty hval
 652         term' <- zonkTerm term
 653         return $ fixFunDictionaries $ expandNewtypes term'
 654       else do
 655               (old_ty', rev_subst) <- instScheme quant_old_ty
 656               my_ty <- newVar argTypeKind
 657               when (check1 quant_old_ty) (traceTR (text "check1 passed") >>
 658                                           addConstraint my_ty old_ty')
 659               term  <- go max_depth my_ty sigma_old_ty hval
 660               new_ty <- zonkTcType (termType term)
 661               if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty
 662                  then do
 663                       traceTR (text "check2 passed")
 664                       addConstraint new_ty old_ty'
 665                       applyRevSubst rev_subst
 666                       zterm' <- zonkTerm term
 667                       return ((fixFunDictionaries . expandNewtypes) zterm')
 668                  else do
 669                       traceTR (text "check2 failed" <+> parens
 670                                        (ppr term <+> text "::" <+> ppr new_ty))
 671                       -- we have unsound types. Replace constructor types in
 672                       -- subterms with tyvars
 673                       zterm' <- mapTermTypeM
 674                                  (\ty -> case tcSplitTyConApp_maybe ty of
 675                                            Just (tc, _:_) | tc /= funTyCon
 676                                                -> newVar argTypeKind
 677                                            _   -> return ty)
 678                                  term
 679                       zonkTerm zterm'
 680    traceTR (text "Term reconstruction completed." $$
 681             text "Term obtained: " <> ppr term $$
 682             text "Type obtained: " <> ppr (termType term))
 683    return term
 684     where
 685
 686   go :: Int -> Type -> Type -> HValue -> TcM Term
 687    -- [SPJ May 11] I don't understand the difference between my_ty and old_ty
 688
 689   go max_depth _ _ _ | seq max_depth False = undefined
 690   go 0 my_ty _old_ty a = do
 691     traceTR (text "Gave up reconstructing a term after" <>
 692                   int max_depth <> text " steps")
 693     clos <- trIO $ getClosureData a
 694     return (Suspension (tipe clos) my_ty a Nothing)
 695   go max_depth my_ty old_ty a = do
 696     let monomorphic = not(isTyVarTy my_ty)
 697     -- This ^^^ is a convention. The ancestor tests for
 698     -- monomorphism and passes a type instead of a tv
 699     clos <- trIO $ getClosureData a
 700     case tipe clos of
 701 -- Thunks we may want to force
 702       t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
 703                                 seq a (go (pred max_depth) my_ty old_ty a)
 704 -- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE.  So we
 705 -- treat them like indirections; if the payload is TSO or BLOCKING_QUEUE, we'll end up
 706 -- showing '_' which is what we want.
 707       Blackhole -> do traceTR (text "Following a BLACKHOLE")
 708                       appArr (go max_depth my_ty old_ty) (ptrs clos) 0
 709 -- We always follow indirections
 710       Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) )
 711                           go max_depth my_ty old_ty $! (ptrs clos ! 0)
 712 -- We also follow references
 713       MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
 714              -> do
 715                   -- Deal with the MutVar# primitive
 716                   -- It does not have a constructor at all,
 717                   -- so we simulate the following one
 718                   -- MutVar# :: contents_ty -> MutVar# s contents_ty
 719          traceTR (text "Following a MutVar")
 720          contents_tv <- newVar liftedTypeKind
 721          contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
 722          ASSERT(isUnliftedTypeKind $ typeKind my_ty) return ()
 723          (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy
 724                             contents_ty (mkTyConApp tycon [world,contents_ty])
 725          addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
 726          x <- go (pred max_depth) contents_tv contents_ty contents
 727          return (RefWrap my_ty x)
 728
 729  -- The interesting case
 730       Constr -> do
 731         traceTR (text "entering a constructor " <>
 732                       if monomorphic
 733                         then parens (text "already monomorphic: " <> ppr my_ty)
 734                         else Ppr.empty)
 735         Right dcname <- dataConInfoPtrToName (infoPtr clos)
 736         (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
 737         case mb_dc of
 738           Nothing -> do -- This can happen for private constructors compiled -O0
 739                         -- where the .hi descriptor does not export them
 740                         -- In such case, we return a best approximation:
 741                         --  ignore the unpointed args, and recover the pointeds
 742                         -- This preserves laziness, and should be safe.
 743                        traceTR (text "Nothing" <+> ppr dcname)
 744                        let tag = showSDoc (ppr dcname)
 745                        vars     <- replicateM (length$ elems$ ptrs clos)
 746                                               (newVar liftedTypeKind)
 747                        subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
 748                                               | (i, tv) <- zip [0..] vars]
 749                        return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
 750           Just dc -> do
 751             traceTR (text "Just" <+> ppr dc)
 752             subTtypes <- getDataConArgTys dc my_ty
 753             let (subTtypesP, subTtypesNP) = partition isPtrType subTtypes
 754             subTermsP <- sequence
 755                   [ appArr (go (pred max_depth) ty ty) (ptrs clos) i
 756                   | (i,ty) <- zip [0..] subTtypesP]
 757             let unboxeds   = extractUnboxed subTtypesNP clos
 758                 subTermsNP = zipWith Prim subTtypesNP unboxeds
 759                 subTerms   = reOrderTerms subTermsP subTermsNP subTtypes
 760             return (Term my_ty (Right dc) a subTerms)
 761
 762 -- The otherwise case: can be a Thunk,AP,PAP,etc.
 763       tipe_clos ->
 764          return (Suspension tipe_clos my_ty a Nothing)
 765
 766   -- put together pointed and nonpointed subterms in the
 767   --  correct order.
 768   reOrderTerms _ _ [] = []
 769   reOrderTerms pointed unpointed (ty:tys)
 770    | isPtrType ty = ASSERT2(not(null pointed)
 771                             , ptext (sLit "reOrderTerms") $$
 772                                         (ppr pointed $$ ppr unpointed))
 773                     let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
 774    | otherwise    = ASSERT2(not(null unpointed)
 775                            , ptext (sLit "reOrderTerms") $$
 776                                        (ppr pointed $$ ppr unpointed))
 777                     let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
 778
 779   -- insert NewtypeWraps around newtypes
 780   expandNewtypes = foldTerm idTermFold { fTerm = worker } where
 781    worker ty dc hval tt
 782      | Just (tc, args) <- tcSplitTyConApp_maybe ty
 783      , isNewTyCon tc
 784      , wrapped_type    <- newTyConInstRhs tc args
 785      , Just dc'        <- tyConSingleDataCon_maybe tc
 786      , t'              <- worker wrapped_type dc hval tt
 787      = NewtypeWrap ty (Right dc') t'
 788      | otherwise = Term ty dc hval tt
 789
 790
 791    -- Avoid returning types where predicates have been expanded to dictionaries.
 792   fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where
 793       worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
 794                           | otherwise  = Suspension ct ty hval n
 795
 796
 797 -- Fast, breadth-first Type reconstruction
 798 ------------------------------------------
 799 cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type)
 800 cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
 801    traceTR (text "RTTI started with initial type " <> ppr old_ty)
 802    let sigma_old_ty@(old_tvs, _) = quantifyType old_ty
 803    new_ty <-
 804        if null old_tvs
 805         then return old_ty
 806         else do
 807           (old_ty', rev_subst) <- instScheme sigma_old_ty
 808           my_ty <- newVar argTypeKind
 809           when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
 810                                       addConstraint my_ty old_ty')
 811           search (isMonomorphic `fmap` zonkTcType my_ty)
 812                  (\(ty,a) -> go ty a)
 813                  (Seq.singleton (my_ty, hval))
 814                  max_depth
 815           new_ty <- zonkTcType my_ty
 816           if isMonomorphic new_ty || check2 (quantifyType new_ty) sigma_old_ty
 817             then do
 818                  traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty)
 819                  addConstraint my_ty old_ty'
 820                  applyRevSubst rev_subst
 821                  zonkRttiType new_ty
 822             else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >>
 823                  return old_ty
 824    traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
 825    return new_ty
 826     where
 827 --  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
 828   search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
 829                                 int max_depth <> text " steps")
 830   search stop expand l d =
 831     case viewl l of
 832       EmptyL  -> return ()
 833       x :< xx -> unlessM stop $ do
 834                   new <- expand x
 835                   search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
 836
 837    -- returns unification tasks,since we are going to want a breadth-first search
 838   go :: Type -> HValue -> TR [(Type, HValue)]
 839   go my_ty a = do
 840     traceTR (text "go" <+> ppr my_ty)
 841     clos <- trIO $ getClosureData a
 842     case tipe clos of
 843       Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO
 844       Indirection _ -> go my_ty $! (ptrs clos ! 0)
 845       MutVar _ -> do
 846          contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
 847          tv'   <- newVar liftedTypeKind
 848          world <- newVar liftedTypeKind
 849          addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
 850          return [(tv', contents)]
 851       Constr -> do
 852         Right dcname <- dataConInfoPtrToName (infoPtr clos)
 853         traceTR (text "Constr1" <+> ppr dcname)
 854         (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
 855         case mb_dc of
 856           Nothing-> do
 857                      --  TODO: Check this case
 858             forM [0..length (elems $ ptrs clos)] $ \i -> do
 859                         tv <- newVar liftedTypeKind
 860                         return$ appArr (\e->(tv,e)) (ptrs clos) i
 861
 862           Just dc -> do
 863             arg_tys <- getDataConArgTys dc my_ty
 864             traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys)
 865             return $ [ appArr (\e-> (ty,e)) (ptrs clos) i
 866                      | (i,ty) <- zip [0..] (filter isPtrType arg_tys)]
 867       _ -> return []
 868
 869 -- Compute the difference between a base type and the type found by RTTI
 870 -- improveType <base_type> <rtti_type>
 871 -- The types can contain skolem type variables, which need to be treated as normal vars.
 872 -- In particular, we want them to unify with things.
 873 improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TvSubst
 874 improveRTTIType _ base_ty new_ty
 875   = U.tcUnifyTys (const U.BindMe) [base_ty] [new_ty]
 876
 877 getDataConArgTys :: DataCon -> Type -> TR [Type]
 878 -- Given the result type ty of a constructor application (D a b c :: ty)
 879 -- return the types of the arguments.  This is RTTI-land, so 'ty' might
 880 -- not be fully known.  Moreover, the arg types might involve existentials;
 881 -- if so, make up fresh RTTI type variables for them
 882 getDataConArgTys dc con_app_ty
 883   = do { (_, ex_tys, _) <- instTyVars ex_tvs
 884        ; let rep_con_app_ty = repType con_app_ty
 885        ; ty_args <- case tcSplitTyConApp_maybe rep_con_app_ty of
 886                        Just (tc, ty_args) | dataConTyCon dc == tc
 887                            -> ASSERT( univ_tvs `equalLength` ty_args)
 888                               return ty_args
 889                        _   -> do { (_, ty_args, subst) <- instTyVars univ_tvs
 890                                  ; let res_ty = substTy subst (dataConOrigResTy dc)
 891                                  ; addConstraint rep_con_app_ty res_ty
 892                                  ; return ty_args }
 893                 -- It is necessary to check dataConTyCon dc == tc
 894                 -- because it may be the case that tc is a recursive
 895                 -- newtype and tcSplitTyConApp has not removed it. In
 896                 -- that case, we happily give up and don't match
 897        ; let subst = zipTopTvSubst (univ_tvs ++ ex_tvs) (ty_args ++ ex_tys)
 898        ; return (substTys subst (dataConRepArgTys dc)) }
 899   where
 900     univ_tvs = dataConUnivTyVars dc
 901     ex_tvs   = dataConExTyVars dc
 902
 903 isPtrType :: Type -> Bool
 904 isPtrType ty = case typePrimRep ty of
 905                  PtrRep -> True
 906                  _      -> False
 907
 908 -- Soundness checks
 909 --------------------
 910 {-
 911 This is not formalized anywhere, so hold to your seats!
 912 RTTI in the presence of newtypes can be a tricky and unsound business.
 913
 914 Example:
 915 ~~~~~~~~~
 916 Suppose we are doing RTTI for a partially evaluated
 917 closure t, the real type of which is t :: MkT Int, for
 918
 919    newtype MkT a = MkT [Maybe a]
 920
 921 The table below shows the results of RTTI and the improvement
 922 calculated for different combinations of evaluatedness and :type t.
 923 Regard the two first columns as input and the next two as output.
 924
 925   # |     t     |  :type t  | rtti(t)  | improv.    | result
 926     ------------------------------------------------------------
 927   1 |     _     |    t b    |    a     | none       | OK
 928   2 |     _     |   MkT b   |    a     | none       | OK
 929   3 |     _     |   t Int   |    a     | none       | OK
 930
 931   If t is not evaluated at *all*, we are safe.
 932
 933   4 |  (_ : _)  |    t b    |   [a]    | t = []     | UNSOUND
 934   5 |  (_ : _)  |   MkT b   |  MkT a   | none       | OK (compensating for the missing newtype)
 935   6 |  (_ : _)  |   t Int   |  [Int]   | t = []     | UNSOUND
 936
 937   If a is a minimal whnf, we run into trouble. Note that
 938   row 5 above does newtype enrichment on the ty_rtty parameter.
 939
 940   7 | (Just _:_)|    t b    |[Maybe a] | t = [],    | UNSOUND
 941     |                       |          | b = Maybe a|
 942
 943   8 | (Just _:_)|   MkT b   |  MkT a   |  none      | OK
 944   9 | (Just _:_)|   t Int   |   FAIL   |  none      | OK
 945
 946   And if t is any more evaluated than whnf, we are still in trouble.
 947   Because constraints are solved in top-down order, when we reach the
 948   Maybe subterm what we got is already unsound. This explains why the
 949   row 9 fails to complete.
 950
 951   10 | (Just _:_)|  t Int  | [Maybe a]   |  FAIL    | OK
 952   11 | (Just 1:_)|  t Int  | [Maybe Int] |  FAIL    | OK
 953
 954   We can undo the failure in row 9 by leaving out the constraint
 955   coming from the type signature of t (i.e., the 2nd column).
 956   Note that this type information is still used
 957   to calculate the improvement. But we fail
 958   when trying to calculate the improvement, as there is no unifier for
 959   t Int = [Maybe a] or t Int = [Maybe Int].
 960
 961
 962   Another set of examples with t :: [MkT (Maybe Int)]  \equiv  [[Maybe (Maybe Int)]]
 963
 964   # |     t     |    :type t    |  rtti(t)    | improvement | result
 965     ---------------------------------------------------------------------
 966   1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = []      |
 967     |           |               |             | b = Maybe a |
 968
 969 The checks:
 970 ~~~~~~~~~~~
 971 Consider a function obtainType that takes a value and a type and produces
 972 the Term representation and a substitution (the improvement).
 973 Assume an auxiliar rtti' function which does the actual job if recovering
 974 the type, but which may produce a false type.
 975
 976 In pseudocode:
 977
 978   rtti' :: a -> IO Type  -- Does not use the static type information
 979
 980   obtainType :: a -> Type -> IO (Maybe (Term, Improvement))
 981   obtainType v old_ty = do
 982        rtti_ty <- rtti' v
 983        if monomorphic rtti_ty || (check rtti_ty old_ty)
 984         then ...
 985          else return Nothing
 986   where check rtti_ty old_ty = check1 rtti_ty &&
 987                               check2 rtti_ty old_ty
 988
 989   check1 :: Type -> Bool
 990   check2 :: Type -> Type -> Bool
 991
 992 Now, if rtti' returns a monomorphic type, we are safe.
 993 If that is not the case, then we consider two conditions.
 994
 995
 996 1. To prevent the class of unsoundness displayed by
 997    rows 4 and 7 in the example: no higher kind tyvars
 998    accepted.
 999
1000   check1 (t a)   = NO
1001   check1 (t Int) = NO
1002   check1 ([] a)  = YES
1003
1004 2. To prevent the class of unsoundness shown by row 6,
1005    the rtti type should be structurally more
1006    defined than the old type we are comparing it to.
1007   check2 :: NewType -> OldType -> Bool
1008   check2 a  _        = True
1009   check2 [a] a       = True
1010   check2 [a] (t Int) = False
1011   check2 [a] (t a)   = False  -- By check1 we never reach this equation
1012   check2 [Int] a     = True
1013   check2 [Int] (t Int) = True
1014   check2 [Maybe a]   (t Int) = False
1015   check2 [Maybe Int] (t Int) = True
1016   check2 (Maybe [a])   (m [Int]) = False
1017   check2 (Maybe [Int]) (m [Int]) = True
1018
1019 -}
1020
1021 check1 :: QuantifiedType -> Bool
1022 check1 (tvs, _) = not $ any isHigherKind (map tyVarKind tvs)
1023  where
1024    isHigherKind = not . null . fst . splitKindFunTys
1025
1026 check2 :: QuantifiedType -> QuantifiedType -> Bool
1027 check2 (_, rtti_ty) (_, old_ty)
1028   | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty
1029   = case () of
1030       _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty
1031         -> and$ zipWith check2 (map quantifyType rttis) (map quantifyType olds)
1032       _ | Just _ <- splitAppTy_maybe old_ty
1033         -> isMonomorphicOnNonPhantomArgs rtti_ty
1034       _ -> True
1035   | otherwise = True
1036
1037 -- Dealing with newtypes
1038 --------------------------
1039 {-
1040  congruenceNewtypes does a parallel fold over two Type values,
1041  compensating for missing newtypes on both sides.
1042  This is necessary because newtypes are not present
1043  in runtime, but sometimes there is evidence available.
1044    Evidence can come from DataCon signatures or
1045  from compile-time type inference.
1046  What we are doing here is an approximation
1047  of unification modulo a set of equations derived
1048  from newtype definitions. These equations should be the
1049  same as the equality coercions generated for newtypes
1050  in System Fc. The idea is to perform a sort of rewriting,
1051  taking those equations as rules, before launching unification.
1052
1053  The caller must ensure the following.
1054  The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
1055  The 2nd type (rhs) comes from a DataCon type signature.
1056  Rewriting (i.e. adding/removing a newtype wrapper) can happen
1057  in both types, but in the rhs it is restricted to the result type.
1058
1059    Note that it is very tricky to make this 'rewriting'
1060  work with the unification implemented by TcM, where
1061  substitutions are operationally inlined. The order in which
1062  constraints are unified is vital as we cannot modify
1063  anything that has been touched by a previous unification step.
1064 Therefore, congruenceNewtypes is sound only if the types
1065 recovered by the RTTI mechanism are unified Top-Down.
1066 -}
1067 congruenceNewtypes ::  TcType -> TcType -> TR (TcType,TcType)
1068 congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
1069  where
1070    go l r
1071  -- TyVar lhs inductive case
1072     | Just tv <- getTyVar_maybe l
1073     , isTcTyVar tv
1074     , isMetaTyVar tv
1075     = recoverTR (return r) $ do
1076          Indirect ty_v <- readMetaTyVar tv
1077          traceTR $ fsep [text "(congruence) Following indirect tyvar:",
1078                           ppr tv, equals, ppr ty_v]
1079          go ty_v r
1080 -- FunTy inductive case
1081     | Just (l1,l2) <- splitFunTy_maybe l
1082     , Just (r1,r2) <- splitFunTy_maybe r
1083     = do r2' <- go l2 r2
1084          r1' <- go l1 r1
1085          return (mkFunTy r1' r2')
1086 -- TyconApp Inductive case; this is the interesting bit.
1087     | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
1088     , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
1089     , tycon_l /= tycon_r
1090     = upgrade tycon_l r
1091
1092     | otherwise = return r
1093
1094     where upgrade :: TyCon -> Type -> TR Type
1095           upgrade new_tycon ty
1096             | not (isNewTyCon new_tycon) = do
1097               traceTR (text "(Upgrade) Not matching newtype evidence: " <>
1098                        ppr new_tycon <> text " for " <> ppr ty)
1099               return ty
1100             | otherwise = do
1101                traceTR (text "(Upgrade) upgraded " <> ppr ty <>
1102                         text " in presence of newtype evidence " <> ppr new_tycon)
1103                (_, vars, _) <- instTyVars (tyConTyVars new_tycon)
1104                let ty' = mkTyConApp new_tycon vars
1105                _ <- liftTcM (unifyType ty (repType ty'))
1106         -- assumes that reptype doesn't ^^^^ touch tyconApp args
1107                return ty'
1108
1109
1110 zonkTerm :: Term -> TcM Term
1111 zonkTerm = foldTermM (TermFoldM
1112              { fTermM = \ty dc v tt -> zonkRttiType ty    >>= \ty' ->
1113                                        return (Term ty' dc v tt)
1114              , fSuspensionM  = \ct ty v b -> zonkRttiType ty >>= \ty ->
1115                                              return (Suspension ct ty v b)
1116              , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' ->
1117                                            return$ NewtypeWrap ty' dc t
1118              , fRefWrapM     = \ty t -> return RefWrap  `ap`
1119                                         zonkRttiType ty `ap` return t
1120              , fPrimM        = (return.) . Prim })
1121
1122 zonkRttiType :: TcType -> TcM Type
1123 -- Zonk the type, replacing any unbound Meta tyvars
1124 -- by skolems, safely out of Meta-tyvar-land
1125 zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta)
1126   where
1127     zonk_unbound_meta tv
1128       = ASSERT( isTcTyVar tv )
1129         do { tv' <- skolemiseUnboundMetaTyVar tv RuntimeUnk
1130              -- This is where RuntimeUnks are born:
1131              -- otherwise-unconstrained unification variables are
1132              -- turned into RuntimeUnks as they leave the
1133              -- typechecker's monad
1134            ; return (mkTyVarTy tv') }
1135
1136 --------------------------------------------------------------------------------
1137 -- Restore Class predicates out of a representation type
1138 dictsView :: Type -> Type
1139 -- dictsView ty = ty
1140 dictsView (FunTy (TyConApp tc_dict args) ty)
1141   | Just c <- tyConClass_maybe tc_dict
1142   = FunTy (PredTy (ClassP c args)) (dictsView ty)
1143 dictsView ty
1144   | Just (tc_fun, [TyConApp tc_dict args, ty2]) <- tcSplitTyConApp_maybe ty
1145   , Just c <- tyConClass_maybe tc_dict
1146   = mkTyConApp tc_fun [PredTy (ClassP c args), dictsView ty2]
1147 dictsView ty = ty
1148
1149
1150 -- Use only for RTTI types
1151 isMonomorphic :: RttiType -> Bool
1152 isMonomorphic ty = noExistentials && noUniversals
1153  where (tvs, _, ty')  = tcSplitSigmaTy ty
1154        noExistentials = isEmptyVarSet (tyVarsOfType ty')
1155        noUniversals   = null tvs
1156
1157 -- Use only for RTTI types
1158 isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
1159 isMonomorphicOnNonPhantomArgs ty
1160   | Just (tc, all_args) <- tcSplitTyConApp_maybe (repType ty)
1161   , phantom_vars  <- tyConPhantomTyVars tc
1162   , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args
1163                            , tyv `notElem` phantom_vars]
1164   = all isMonomorphicOnNonPhantomArgs concrete_args
1165   | Just (ty1, ty2) <- splitFunTy_maybe ty
1166   = all isMonomorphicOnNonPhantomArgs [ty1,ty2]
1167   | otherwise = isMonomorphic ty
1168
1169 tyConPhantomTyVars :: TyCon -> [TyVar]
1170 tyConPhantomTyVars tc
1171   | isAlgTyCon tc
1172   , Just dcs <- tyConDataCons_maybe tc
1173   , dc_vars  <- concatMap dataConUnivTyVars dcs
1174   = tyConTyVars tc \\ dc_vars
1175 tyConPhantomTyVars _ = []
1176
1177 type QuantifiedType = ([TyVar], Type)   -- Make the free type variables explicit
1178
1179 quantifyType :: Type -> QuantifiedType
1180 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
1181 quantifyType ty = (varSetElems (tyVarsOfType ty), ty)
1182
1183 unlessM :: Monad m => m Bool -> m () -> m ()
1184 unlessM condM acc = condM >>= \c -> unless c acc
1185
1186
1187 -- Strict application of f at index i
1188 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
1189 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
1190  = ASSERT2 (i < length(elems a), ppr(length$ elems a, i))
1191    case indexArray# ptrs# i# of
1192        (# e #) -> f e
1193
1194 amap' :: (t -> b) -> Array Int t -> [b]
1195 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
1196     where g (I# i#) = case indexArray# arr# i# of
1197                           (# e #) -> f e
1198
1199 extractUnboxed  :: [Type] -> Closure -> [[Word]]
1200 extractUnboxed tt clos = go tt (nonPtrs clos)
1201    where sizeofType t = primRepSizeW (typePrimRep t)
1202          go [] _ = []
1203          go (t:tt) xx
1204            | (x, rest) <- splitAt (sizeofType t) xx
1205            = x : go tt rest