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
  11      cvObtainTerm,      -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
  12
  13      Term(..),
  14      isTerm,
  15      isSuspension,
  16      isPrim,
  17      isNewtypeWrap,
  18      pprTerm,
  19      cPprTerm,
  20      cPprTermBase,
  21      CustomTermPrinter,
  22      termType,
  23      foldTerm,
  24      TermFold(..),
  25      idTermFold,
  26      idTermFoldM,
  27      isFullyEvaluated,
  28      isPointed,
  29      isFullyEvaluatedTerm,
  30      mapTermType,
  31      termTyVars,
  32 --     unsafeDeepSeq,
  33      cvReconstructType,
  34      unifyRTTI,
  35      sigmaType,
  36      Closure(..),
  37      getClosureData,
  38      ClosureType(..),
  39      isConstr,
  40      isIndirection
  41  ) where
  42
  43 #include "HsVersions.h"
  44
  45 import ByteCodeItbls    ( StgInfoTable )
  46 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
  47 import HscTypes         ( HscEnv )
  48 import Linker
  49
  50 import DataCon
  51 import Type
  52 import Var
  53 import TcRnMonad
  54 import TcType
  55 import TcMType
  56 import TcUnify
  57 import TcGadt
  58 import TcEnv
  59 import DriverPhases
  60 import TyCon
  61 import Name
  62 import VarEnv
  63 import Util
  64 import VarSet
  65
  66 import TysPrim
  67 import PrelNames
  68 import TysWiredIn
  69
  70 import Constants
  71 import Outputable
  72 import Panic
  73
  74 import GHC.Arr          ( Array(..) )
  75 import GHC.Exts
  76 import GHC.IOBase ( IO(IO) )
  77
  78 import Control.Monad
  79 import Data.Maybe
  80 import Data.Array.Base
  81 import Data.Ix
  82 import Data.List        ( partition )
  83 import qualified Data.Sequence as Seq
  84 import Data.Monoid
  85 import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
  86 import Foreign
  87 import System.IO.Unsafe
  88
  89 ---------------------------------------------
  90 -- * A representation of semi evaluated Terms
  91 ---------------------------------------------
  92 {-
  93
  94 -}
  95
  96 data Term = Term { ty        :: Type
  97                  , dc        :: Either String DataCon
  98                                -- Carries a text representation if the datacon is
  99                                -- not exported by the .hi file, which is the case
 100                                -- for private constructors in -O0 compiled libraries
 101                  , val       :: HValue
 102                  , subTerms  :: [Term] }
 103
 104           | Prim { ty        :: Type
 105                  , value     :: [Word] }
 106
 107           | Suspension { ctype    :: ClosureType
 108                        , ty       :: Type
 109                        , val      :: HValue
 110                        , bound_to :: Maybe Name   -- Useful for printing
 111                        }
 112           | NewtypeWrap{ ty           :: Type
 113                        , dc           :: Either String DataCon
 114                        , wrapped_term :: Term }
 115           | RefWrap    { ty           :: Type
 116                        , wrapped_term :: Term }
 117
 118 isTerm, isSuspension, isPrim, isNewtypeWrap :: Term -> Bool
 119 isTerm Term{} = True
 120 isTerm   _    = False
 121 isSuspension Suspension{} = True
 122 isSuspension      _       = False
 123 isPrim Prim{} = True
 124 isPrim   _    = False
 125 isNewtypeWrap NewtypeWrap{} = True
 126 isNewtypeWrap _             = False
 127
 128 termType :: Term -> Type
 129 termType t = ty t
 130
 131 isFullyEvaluatedTerm :: Term -> Bool
 132 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
 133 isFullyEvaluatedTerm Prim {}            = True
 134 isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
 135 isFullyEvaluatedTerm RefWrap{wrapped_term=t}     = isFullyEvaluatedTerm t
 136 isFullyEvaluatedTerm _                  = False
 137
 138 instance Outputable (Term) where
 139  ppr t | Just doc <- cPprTerm cPprTermBase t = doc
 140        | otherwise = panic "Outputable Term instance"
 141
 142 -------------------------------------------------------------------------
 143 -- Runtime Closure Datatype and functions for retrieving closure related stuff
 144 -------------------------------------------------------------------------
 145 data ClosureType = Constr
 146                  | Fun
 147                  | Thunk Int
 148                  | ThunkSelector
 149                  | Blackhole
 150                  | AP
 151                  | PAP
 152                  | Indirection Int
 153                  | MutVar Int
 154                  | Other  Int
 155  deriving (Show, Eq)
 156
 157 data Closure = Closure { tipe         :: ClosureType
 158                        , infoPtr      :: Ptr ()
 159                        , infoTable    :: StgInfoTable
 160                        , ptrs         :: Array Int HValue
 161                        , nonPtrs      :: [Word]
 162                        }
 163
 164 instance Outputable ClosureType where
 165   ppr = text . show
 166
 167 #include "../includes/ClosureTypes.h"
 168
 169 aP_CODE, pAP_CODE :: Int
 170 aP_CODE = AP
 171 pAP_CODE = PAP
 172 #undef AP
 173 #undef PAP
 174
 175 getClosureData :: a -> IO Closure
 176 getClosureData a =
 177    case unpackClosure# a of
 178      (# iptr, ptrs, nptrs #) -> do
 179 #ifndef GHCI_TABLES_NEXT_TO_CODE
 180            -- the info pointer we get back from unpackClosure# is to the
 181            -- beginning of the standard info table, but the Storable instance
 182            -- for info tables takes into account the extra entry pointer
 183            -- when !tablesNextToCode, so we must adjust here:
 184            itbl <- peek (Ptr iptr `plusPtr` negate wORD_SIZE)
 185 #else
 186            itbl <- peek (Ptr iptr)
 187 #endif
 188            let tipe = readCType (BCI.tipe itbl)
 189                elems = fromIntegral (BCI.ptrs itbl)
 190                ptrsList = Array 0 (elems - 1) elems ptrs
 191                nptrs_data = [W# (indexWordArray# nptrs i)
 192                               | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
 193            ASSERT(elems >= 0) return ()
 194            ptrsList `seq`
 195             return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
 196
 197 readCType :: Integral a => a -> ClosureType
 198 readCType i
 199  | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
 200  | i >= FUN    && i <= FUN_STATIC          = Fun
 201  | i >= THUNK  && i < THUNK_SELECTOR       = Thunk i'
 202  | i == THUNK_SELECTOR                     = ThunkSelector
 203  | i == BLACKHOLE                          = Blackhole
 204  | i >= IND    && i <= IND_STATIC          = Indirection i'
 205  | i' == aP_CODE                           = AP
 206  | i == AP_STACK                           = AP
 207  | i' == pAP_CODE                          = PAP
 208  | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY     = MutVar i'
 209  | otherwise                               = Other  i'
 210   where i' = fromIntegral i
 211
 212 isConstr, isIndirection, isThunk :: ClosureType -> Bool
 213 isConstr Constr = True
 214 isConstr    _   = False
 215
 216 isIndirection (Indirection _) = True
 217 isIndirection _ = False
 218
 219 isThunk (Thunk _)     = True
 220 isThunk ThunkSelector = True
 221 isThunk AP            = True
 222 isThunk _             = False
 223
 224 isFullyEvaluated :: a -> IO Bool
 225 isFullyEvaluated a = do
 226   closure <- getClosureData a
 227   case tipe closure of
 228     Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
 229                  return$ and are_subs_evaluated
 230     _      -> return False
 231   where amapM f = sequence . amap' f
 232
 233 amap' :: (t -> b) -> Array Int t -> [b]
 234 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
 235     where g (I# i#) = case indexArray# arr# i# of
 236                           (# e #) -> f e
 237
 238 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
 239 {-
 240 unsafeDeepSeq :: a -> b -> b
 241 unsafeDeepSeq = unsafeDeepSeq1 2
 242  where unsafeDeepSeq1 0 a b = seq a $! b
 243        unsafeDeepSeq1 i a b   -- 1st case avoids infinite loops for non reducible thunks
 244         | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
 245      -- | unsafePerformIO (isFullyEvaluated a) = b
 246         | otherwise = case unsafePerformIO (getClosureData a) of
 247                         closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
 248         where tipe = unsafePerformIO (getClosureType a)
 249 -}
 250 isPointed :: Type -> Bool
 251 isPointed t | Just (t, _) <- splitTyConApp_maybe t
 252             = not$ isUnliftedTypeKind (tyConKind t)
 253 isPointed _ = True
 254
 255 extractUnboxed  :: [Type] -> Closure -> [[Word]]
 256 extractUnboxed tt clos = go tt (nonPtrs clos)
 257    where sizeofType t
 258            | Just (tycon,_) <- splitTyConApp_maybe t
 259            = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
 260            | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
 261          go [] _ = []
 262          go (t:tt) xx
 263            | (x, rest) <- splitAt ((sizeofType t + wORD_SIZE - 1) `div` wORD_SIZE) xx
 264            = x : go tt rest
 265
 266 sizeofTyCon :: TyCon -> Int
 267 sizeofTyCon = sizeofPrimRep . tyConPrimRep
 268
 269 -----------------------------------
 270 -- * Traversals for Terms
 271 -----------------------------------
 272 type TermProcessor a b = Type -> Either String DataCon -> HValue -> [a] -> b
 273
 274 data TermFold a = TermFold { fTerm        :: TermProcessor a a
 275                            , fPrim        :: Type -> [Word] -> a
 276                            , fSuspension  :: ClosureType -> Type -> HValue
 277                                             -> Maybe Name -> a
 278                            , fNewtypeWrap :: Type -> Either String DataCon
 279                                             -> a -> a
 280                            , fRefWrap     :: Type -> a -> a
 281                            }
 282
 283 foldTerm :: TermFold a -> Term -> a
 284 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
 285 foldTerm tf (Prim ty    v   ) = fPrim tf ty v
 286 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
 287 foldTerm tf (NewtypeWrap ty dc t)  = fNewtypeWrap tf ty dc (foldTerm tf t)
 288 foldTerm tf (RefWrap ty t)         = fRefWrap tf ty (foldTerm tf t)
 289
 290 idTermFold :: TermFold Term
 291 idTermFold = TermFold {
 292               fTerm = Term,
 293               fPrim = Prim,
 294               fSuspension  = Suspension,
 295               fNewtypeWrap = NewtypeWrap,
 296               fRefWrap = RefWrap
 297                       }
 298 idTermFoldM :: Monad m => TermFold (m Term)
 299 idTermFoldM = TermFold {
 300               fTerm       = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
 301               fPrim       = (return.). Prim,
 302               fSuspension = (((return.).).). Suspension,
 303               fNewtypeWrap= \ty dc t -> NewtypeWrap ty dc `liftM` t,
 304               fRefWrap    = \ty t -> RefWrap ty `liftM` t
 305                        }
 306
 307 mapTermType :: (Type -> Type) -> Term -> Term
 308 mapTermType f = foldTerm idTermFold {
 309           fTerm       = \ty dc hval tt -> Term (f ty) dc hval tt,
 310           fSuspension = \ct ty hval n ->
 311                           Suspension ct (f ty) hval n,
 312           fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
 313           fRefWrap    = \ty t -> RefWrap (f ty) t}
 314
 315 termTyVars :: Term -> TyVarSet
 316 termTyVars = foldTerm TermFold {
 317             fTerm       = \ty _ _ tt   ->
 318                           tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
 319             fSuspension = \_ ty _ _ -> tyVarsOfType ty,
 320             fPrim       = \ _ _ -> emptyVarEnv,
 321             fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t,
 322             fRefWrap    = \ty t -> tyVarsOfType ty `plusVarEnv` t}
 323     where concatVarEnv = foldr plusVarEnv emptyVarEnv
 324
 325 ----------------------------------
 326 -- Pretty printing of terms
 327 ----------------------------------
 328
 329 type Precedence        = Int
 330 type TermPrinter       = Precedence -> Term ->   SDoc
 331 type TermPrinterM m    = Precedence -> Term -> m SDoc
 332
 333 app_prec,cons_prec, max_prec ::Int
 334 max_prec  = 10
 335 app_prec  = max_prec
 336 cons_prec = 5 -- TODO Extract this info from GHC itself
 337
 338 pprTerm :: TermPrinter -> TermPrinter
 339 pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
 340 pprTerm _ _ _ = panic "pprTerm"
 341
 342 pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
 343 pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
 344
 345 ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
 346   tt_docs <- mapM (y app_prec) tt
 347   return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
 348
 349 ppr_termM y p Term{dc=Right dc, subTerms=tt}
 350 {-  | dataConIsInfix dc, (t1:t2:tt') <- tt  --TODO fixity
 351   = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
 352     <+> hsep (map (ppr_term1 True) tt)
 353 -} -- TODO Printing infix constructors properly
 354   | null tt   = return$ ppr dc
 355   | otherwise = do
 356          tt_docs <- mapM (y app_prec) tt
 357          return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
 358
 359 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
 360 ppr_termM y p RefWrap{wrapped_term=t}  = do
 361   contents <- y app_prec t
 362   return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
 363   -- The constructor name is wired in here ^^^ for the sake of simplicity.
 364   -- I don't think mutvars are going to change in a near future.
 365   -- In any case this is solely a presentation matter: MutVar# is
 366   -- a datatype with no constructors, implemented by the RTS
 367   -- (hence there is no way to obtain a datacon and print it).
 368 ppr_termM _ _ t = ppr_termM1 t
 369
 370
 371 ppr_termM1 :: Monad m => Term -> m SDoc
 372 ppr_termM1 Prim{value=words, ty=ty} =
 373     return$ text$ repPrim (tyConAppTyCon ty) words
 374 ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
 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,_) <- splitNewTyConApp_maybe ty
 384   , ASSERT(isNewTyCon tc) True
 385   , Just new_dc <- maybeTyConSingleCon 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 :: 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            (\ p Term{subTerms=[h,t]} -> doList p h t)
 428   , ifTerm (isTyCon intTyCon    . ty) (coerceShow$ \(a::Int)->a)
 429   , ifTerm (isTyCon charTyCon   . ty) (coerceShow$ \(a::Char)->a)
 430   , ifTerm (isTyCon floatTyCon  . ty) (coerceShow$ \(a::Float)->a)
 431   , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
 432   , ifTerm (isIntegerTy         . ty) (coerceShow$ \(a::Integer)->a)
 433   ]
 434      where ifTerm pred f prec t@Term{}
 435                | pred t    = Just `liftM` f prec t
 436            ifTerm _ _ _ _  = return Nothing
 437
 438            isIntegerTy ty  = fromMaybe False $ do
 439              (tc,_) <- splitTyConApp_maybe ty
 440              return (tyConName tc == integerTyConName)
 441
 442            isTupleTy ty    = fromMaybe False $ do
 443              (tc,_) <- splitTyConApp_maybe ty
 444              return (tc `elem` (fst.unzip.elems) boxedTupleArr)
 445
 446            isTyCon a_tc ty = fromMaybe False $ do
 447              (tc,_) <- splitTyConApp_maybe ty
 448              return (a_tc == tc)
 449
 450            coerceShow f _p = return . text . show . f . unsafeCoerce# . val
 451
 452            --Note pprinting of list terms is not lazy
 453            doList p h t = do
 454                let elems      = h : getListTerms t
 455                    isConsLast = not(termType(last elems) `coreEqType` termType h)
 456                print_elems <- mapM (y cons_prec) elems
 457                return$ if isConsLast
 458                      then cparen (p >= cons_prec)
 459                         . pprDeeperList fsep
 460                         . punctuate (space<>colon)
 461                         $ print_elems
 462                      else brackets (pprDeeperList fcat$
 463                                          punctuate comma print_elems)
 464
 465                 where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
 466                       getListTerms Term{subTerms=[]}    = []
 467                       getListTerms t@Suspension{}       = [t]
 468                       getListTerms t = pprPanic "getListTerms" (ppr t)
 469
 470
 471 repPrim :: TyCon -> [Word] -> String
 472 repPrim t = rep where
 473    rep x
 474     | t == charPrimTyCon   = show (build x :: Char)
 475     | t == intPrimTyCon    = show (build x :: Int)
 476     | t == wordPrimTyCon   = show (build x :: Word)
 477     | t == floatPrimTyCon  = show (build x :: Float)
 478     | t == doublePrimTyCon = show (build x :: Double)
 479     | t == int32PrimTyCon  = show (build x :: Int32)
 480     | t == word32PrimTyCon = show (build x :: Word32)
 481     | t == int64PrimTyCon  = show (build x :: Int64)
 482     | t == word64PrimTyCon = show (build x :: Word64)
 483     | t == addrPrimTyCon   = show (nullPtr `plusPtr` build x)
 484     | t == stablePtrPrimTyCon  = "<stablePtr>"
 485     | t == stableNamePrimTyCon = "<stableName>"
 486     | t == statePrimTyCon      = "<statethread>"
 487     | t == realWorldTyCon      = "<realworld>"
 488     | t == threadIdPrimTyCon   = "<ThreadId>"
 489     | t == weakPrimTyCon       = "<Weak>"
 490     | t == arrayPrimTyCon      = "<array>"
 491     | t == byteArrayPrimTyCon  = "<bytearray>"
 492     | t == mutableArrayPrimTyCon = "<mutableArray>"
 493     | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
 494     | t == mutVarPrimTyCon= "<mutVar>"
 495     | t == mVarPrimTyCon  = "<mVar>"
 496     | t == tVarPrimTyCon  = "<tVar>"
 497     | otherwise = showSDoc (char '<' <> ppr t <> char '>')
 498     where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
 499 --   This ^^^ relies on the representation of Haskell heap values being
 500 --   the same as in a C array.
 501
 502 -----------------------------------
 503 -- Type Reconstruction
 504 -----------------------------------
 505 {-
 506 Type Reconstruction is type inference done on heap closures.
 507 The algorithm walks the heap generating a set of equations, which
 508 are solved with syntactic unification.
 509 A type reconstruction equation looks like:
 510
 511   <datacon reptype>  =  <actual heap contents>
 512
 513 The full equation set is generated by traversing all the subterms, starting
 514 from a given term.
 515
 516 The only difficult part is that newtypes are only found in the lhs of equations.
 517 Right hand sides are missing them. We can either (a) drop them from the lhs, or
 518 (b) reconstruct them in the rhs when possible.
 519
 520 The function congruenceNewtypes takes a shot at (b)
 521 -}
 522
 523 -- The Type Reconstruction monad
 524 type TR a = TcM a
 525
 526 runTR :: HscEnv -> TR a -> IO a
 527 runTR hsc_env c = do
 528   mb_term <- runTR_maybe hsc_env c
 529   case mb_term of
 530     Nothing -> panic "Can't unify"
 531     Just x  -> return x
 532
 533 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
 534 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
 535
 536 traceTR :: SDoc -> TR ()
 537 traceTR = liftTcM . traceTc
 538
 539 trIO :: IO a -> TR a
 540 trIO = liftTcM . liftIO
 541
 542 liftTcM :: TcM a -> TR a
 543 liftTcM = id
 544
 545 newVar :: Kind -> TR TcType
 546 newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
 547
 548 -- | Returns the instantiated type scheme ty', and the substitution sigma
 549 --   such that sigma(ty') = ty
 550 instScheme :: Type -> TR (TcType, TvSubst)
 551 instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
 552    (tvs',_theta,ty') <- tcInstType (mapM tcInstTyVar) ty
 553    return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
 554
 555 -- Adds a constraint of the form t1 == t2
 556 -- t1 is expected to come from walking the heap
 557 -- t2 is expected to come from a datacon signature
 558 -- Before unification, congruenceNewtypes needs to
 559 -- do its magic.
 560 addConstraint :: TcType -> TcType -> TR ()
 561 addConstraint t1 t2  = congruenceNewtypes t1 t2 >>= uncurry unifyType
 562                        >> return () -- TOMDO: what about the coercion?
 563                                     -- we should consider family instances
 564
 565 -- Type & Term reconstruction
 566 cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
 567 cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
 568    tv <- newVar argTypeKind
 569    case mb_ty of
 570      Nothing ->      go bound tv tv hval
 571                 >>= zonkTerm
 572                 >>= return . expandNewtypes
 573      Just ty | isMonomorphic ty ->     go bound ty ty hval
 574                                    >>= zonkTerm
 575                                    >>= return . expandNewtypes
 576      Just ty -> do
 577               (ty',rev_subst) <- instScheme (sigmaType ty)
 578               addConstraint tv ty'
 579               term <- go bound tv tv hval >>= zonkTerm
 580               --restore original Tyvars
 581               return$ expandNewtypes $ mapTermType (substTy rev_subst) term
 582     where
 583   go bound _ _ _ | seq bound False = undefined
 584   go 0 tv _ty a = do
 585     clos <- trIO $ getClosureData a
 586     return (Suspension (tipe clos) tv a Nothing)
 587   go bound tv ty a = do
 588     let monomorphic = not(isTyVarTy tv)
 589     -- This ^^^ is a convention. The ancestor tests for
 590     -- monomorphism and passes a type instead of a tv
 591     clos <- trIO $ getClosureData a
 592     case tipe clos of
 593 -- Thunks we may want to force
 594 -- NB. this won't attempt to force a BLACKHOLE.  Even with :force, we never
 595 -- force blackholes, because it would almost certainly result in deadlock,
 596 -- and showing the '_' is more useful.
 597       t | isThunk t && force -> seq a $ go (pred bound) tv ty a
 598 -- We always follow indirections
 599       Indirection _ -> go bound tv ty $! (ptrs clos ! 0)
 600 -- We also follow references
 601       MutVar _ | Just (tycon,[world,ty_contents]) <- splitTyConApp_maybe ty
 602                 -- , tycon == mutVarPrimTyCon
 603              -> do
 604          contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
 605          tv' <- newVar liftedTypeKind
 606          addConstraint tv (mkTyConApp tycon [world,tv'])
 607          x <- go bound tv' ty_contents contents
 608          return (RefWrap ty x)
 609
 610  -- The interesting case
 611       Constr -> do
 612         Right dcname <- dataConInfoPtrToName (infoPtr clos)
 613         (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
 614         case mb_dc of
 615           Nothing -> do -- This can happen for private constructors compiled -O0
 616                         -- where the .hi descriptor does not export them
 617                         -- In such case, we return a best approximation:
 618                         --  ignore the unpointed args, and recover the pointeds
 619                         -- This preserves laziness, and should be safe.
 620                        let tag = showSDoc (ppr dcname)
 621                        vars     <- replicateM (length$ elems$ ptrs clos)
 622                                               (newVar (liftedTypeKind))
 623                        subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
 624                                               | (i, tv) <- zip [0..] vars]
 625                        return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
 626           Just dc -> do
 627             let extra_args = length(dataConRepArgTys dc) -
 628                              length(dataConOrigArgTys dc)
 629                 subTtypes  = matchSubTypes dc ty
 630                 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
 631             subTermTvs <- sequence
 632                  [ if isMonomorphic t then return t
 633                                       else (newVar k)
 634                    | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
 635             -- It is vital for newtype reconstruction that the unification step
 636             --  is done right here, _before_ the subterms are RTTI reconstructed
 637             when (not monomorphic) $ do
 638                   let myType = mkFunTys (reOrderTerms subTermTvs
 639                                                       subTtypesNP
 640                                                       subTtypes)
 641                                         tv
 642                   (signatureType,_) <- instScheme(dataConRepType dc)
 643                   addConstraint myType signatureType
 644             subTermsP <- sequence $ drop extra_args
 645                                  -- ^^^  all extra arguments are pointed
 646                   [ appArr (go (pred bound) tv t) (ptrs clos) i
 647                    | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
 648             let unboxeds   = extractUnboxed subTtypesNP clos
 649                 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
 650                 subTerms   = reOrderTerms subTermsP subTermsNP
 651                                 (drop extra_args subTtypes)
 652             return (Term tv (Right dc) a subTerms)
 653 -- The otherwise case: can be a Thunk,AP,PAP,etc.
 654       tipe_clos ->
 655          return (Suspension tipe_clos tv a Nothing)
 656
 657   matchSubTypes dc ty
 658     | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
 659 --     assumption:             ^^^ looks through newtypes
 660     , isVanillaDataCon dc  --TODO non-vanilla case
 661     = dataConInstArgTys dc ty_args
 662     | otherwise = dataConRepArgTys dc
 663
 664 -- This is used to put together pointed and nonpointed subterms in the
 665 --  correct order.
 666   reOrderTerms _ _ [] = []
 667   reOrderTerms pointed unpointed (ty:tys)
 668    | isPointed ty = ASSERT2(not(null pointed)
 669                             , ptext SLIT("reOrderTerms") $$
 670                                         (ppr pointed $$ ppr unpointed))
 671                     let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
 672    | otherwise    = ASSERT2(not(null unpointed)
 673                            , ptext SLIT("reOrderTerms") $$
 674                                        (ppr pointed $$ ppr unpointed))
 675                     let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
 676
 677   expandNewtypes t@Term{ ty=ty, subTerms=tt }
 678    | Just (tc, args) <- splitNewTyConApp_maybe ty
 679    , isNewTyCon tc
 680    , wrapped_type    <- newTyConInstRhs tc args
 681    , Just dc         <- maybeTyConSingleCon tc
 682    , t'              <- expandNewtypes t{ ty = wrapped_type
 683                                         , subTerms = map expandNewtypes tt }
 684    = NewtypeWrap ty (Right dc) t'
 685
 686    | otherwise = t{ subTerms = map expandNewtypes tt }
 687
 688   expandNewtypes t = t
 689
 690
 691 -- Fast, breadth-first Type reconstruction
 692 cvReconstructType :: HscEnv -> Int -> Maybe Type -> HValue -> IO (Maybe Type)
 693 cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
 694    tv <- newVar argTypeKind
 695    case mb_ty of
 696      Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
 697                           (uncurry go)
 698                           (Seq.singleton (tv, hval))
 699                           max_depth
 700                    zonkTcType tv  -- TODO untested!
 701      Just ty | isMonomorphic ty -> return ty
 702      Just ty -> do
 703               (ty',rev_subst) <- instScheme (sigmaType ty)
 704               addConstraint tv ty'
 705               search (isMonomorphic `fmap` zonkTcType tv)
 706                      (\(ty,a) -> go ty a)
 707                      (Seq.singleton (tv, hval))
 708                      max_depth
 709               substTy rev_subst `fmap` zonkTcType tv
 710     where
 711 --  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
 712   search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
 713                                 int max_depth <> text " steps")
 714   search stop expand l d =
 715     case viewl l of
 716       EmptyL  -> return ()
 717       x :< xx -> unlessM stop $ do
 718                   new <- expand x
 719                   search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
 720
 721    -- returns unification tasks,since we are going to want a breadth-first search
 722   go :: Type -> HValue -> TR [(Type, HValue)]
 723   go tv a = do
 724     clos <- trIO $ getClosureData a
 725     case tipe clos of
 726       Indirection _ -> go tv $! (ptrs clos ! 0)
 727       MutVar _ -> do
 728          contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
 729          tv'   <- newVar liftedTypeKind
 730          world <- newVar liftedTypeKind
 731          addConstraint tv (mkTyConApp mutVarPrimTyCon [world,tv'])
 732 --         x <- go tv' ty_contents contents
 733          return [(tv', contents)]
 734       Constr -> do
 735         Right dcname <- dataConInfoPtrToName (infoPtr clos)
 736         (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
 737         case mb_dc of
 738           Nothing-> do
 739                      --  TODO: Check this case
 740             forM [0..length (elems $ ptrs clos)] $ \i -> do
 741                         tv <- newVar liftedTypeKind
 742                         return$ appArr (\e->(tv,e)) (ptrs clos) i
 743
 744           Just dc -> do
 745             let extra_args = length(dataConRepArgTys dc) -
 746                              length(dataConOrigArgTys dc)
 747             subTtypes <- mapMif (not . isMonomorphic)
 748                                 (\t -> newVar (typeKind t))
 749                                 (dataConRepArgTys dc)
 750
 751             -- It is vital for newtype reconstruction that the unification step
 752             -- is done right here, _before_ the subterms are RTTI reconstructed
 753             let myType         = mkFunTys subTtypes tv
 754             (signatureType,_) <- instScheme(dataConRepType dc)
 755             addConstraint myType signatureType
 756             return $ [ appArr (\e->(t,e)) (ptrs clos) i
 757                        | (i,t) <- drop extra_args $
 758                                      zip [0..] (filter isPointed subTtypes)]
 759       _ -> return []
 760
 761 {-
 762  This helper computes the difference between a base type t and the
 763  improved rtti_t computed by RTTI
 764  The main difference between RTTI types and their normal counterparts
 765  is that the former are _not_ polymorphic, thus polymorphism must
 766  be stripped. Syntactically, forall's must be stripped.
 767  We also remove predicates.
 768 -}
 769 unifyRTTI :: Type -> Type -> TvSubst
 770 unifyRTTI ty rtti_ty =
 771     case mb_subst of
 772       Just subst -> subst
 773       Nothing    -> pprPanic "Failed to compute a RTTI substitution"
 774                              (ppr (ty, rtti_ty))
 775      -- In addition, we strip newtypes too, since the reconstructed type might
 776      --   not have recovered them all
 777      -- TODO stripping newtypes shouldn't be necessary, test
 778    where mb_subst = tcUnifyTys (const BindMe)
 779                                [rttiView ty]
 780                                [rttiView rtti_ty]
 781
 782 -- Dealing with newtypes
 783 {-
 784  congruenceNewtypes does a parallel fold over two Type values,
 785  compensating for missing newtypes on both sides.
 786  This is necessary because newtypes are not present
 787  in runtime, but sometimes there is evidence available.
 788    Evidence can come from DataCon signatures or
 789  from compile-time type inference.
 790  What we are doing here is an approximation
 791  of unification modulo a set of equations derived
 792  from newtype definitions. These equations should be the
 793  same as the equality coercions generated for newtypes
 794  in System Fc. The idea is to perform a sort of rewriting,
 795  taking those equations as rules, before launching unification.
 796
 797  The caller must ensure the following.
 798  The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
 799  The 2nd type (rhs) comes from a DataCon type signature.
 800  Rewriting (i.e. adding/removing a newtype wrapper) can happen
 801  in both types, but in the rhs it is restricted to the result type.
 802
 803    Note that it is very tricky to make this 'rewriting'
 804  work with the unification implemented by TcM, where
 805  substitutions are operationally inlined. The order in which
 806  constraints are unified is vital as we cannot modify
 807  anything that has been touched by a previous unification step.
 808 Therefore, congruenceNewtypes is sound only if the types
 809 recovered by the RTTI mechanism are unified Top-Down.
 810 -}
 811 congruenceNewtypes ::  TcType -> TcType -> TR (TcType,TcType)
 812 congruenceNewtypes lhs rhs
 813  -- TyVar lhs inductive case
 814     | Just tv <- getTyVar_maybe lhs
 815     = recoverTc (return (lhs,rhs)) $ do
 816          Indirect ty_v <- readMetaTyVar tv
 817          (_lhs1, rhs1) <- congruenceNewtypes ty_v rhs
 818          return (lhs, rhs1)
 819 -- FunTy inductive case
 820     | Just (l1,l2) <- splitFunTy_maybe lhs
 821     , Just (r1,r2) <- splitFunTy_maybe rhs
 822     = do (l2',r2') <- congruenceNewtypes l2 r2
 823          (l1',r1') <- congruenceNewtypes l1 r1
 824          return (mkFunTy l1' l2', mkFunTy r1' r2')
 825 -- TyconApp Inductive case; this is the interesting bit.
 826     | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
 827     , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
 828     , tycon_l /= tycon_r
 829     = do rhs' <- upgrade tycon_l rhs
 830          return (lhs, rhs')
 831
 832     | otherwise = return (lhs,rhs)
 833
 834     where upgrade :: TyCon -> Type -> TR Type
 835           upgrade new_tycon ty
 836             | not (isNewTyCon new_tycon) = return ty
 837             | otherwise = do
 838                vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
 839                let ty' = mkTyConApp new_tycon vars
 840                liftTcM (unifyType ty (repType ty'))
 841         -- assumes that reptype doesn't ^^^^ touch tyconApp args
 842                return ty'
 843
 844
 845 --------------------------------------------------------------------------------
 846 -- Semantically different to recoverM in TcRnMonad
 847 -- recoverM retains the errors in the first action,
 848 --  whereas recoverTc here does not
 849 recoverTc :: TcM a -> TcM a -> TcM a
 850 recoverTc recover thing = do
 851   (_,mb_res) <- tryTcErrs thing
 852   case mb_res of
 853     Nothing  -> recover
 854     Just res -> return res
 855
 856 isMonomorphic :: Type -> Bool
 857 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
 858                  = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
 859
 860 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
 861 mapMif pred f xx = sequence $ mapMif_ pred f xx
 862   where
 863    mapMif_ _ _ []     = []
 864    mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
 865
 866 unlessM :: Monad m => m Bool -> m () -> m ()
 867 unlessM condM acc = condM >>= \c -> unless c acc
 868
 869 -- Strict application of f at index i
 870 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
 871 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
 872  = ASSERT (i < length(elems a))
 873    case indexArray# ptrs# i# of
 874        (# e #) -> f e
 875
 876 zonkTerm :: Term -> TcM Term
 877 zonkTerm = foldTerm idTermFoldM {
 878               fTerm = \ty dc v tt -> sequence tt      >>= \tt ->
 879                                      zonkTcType ty    >>= \ty' ->
 880                                      return (Term ty' dc v tt)
 881              ,fSuspension = \ct ty v b -> zonkTcType ty >>= \ty ->
 882                                           return (Suspension ct ty v b)
 883              ,fNewtypeWrap= \ty dc t ->
 884                    return NewtypeWrap `ap` zonkTcType ty `ap` return dc `ap` t}
 885
 886
 887 -- Is this defined elsewhere?
 888 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
 889 sigmaType :: Type -> Type
 890 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
 891
 892