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