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