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