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