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