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 type Precedence        = Int
 327 type TermPrinter       = Precedence -> Term ->   SDoc
 328 type TermPrinterM m    = Precedence -> Term -> m SDoc
 329
 330 app_prec,cons_prec ::Int
 331 app_prec = 10
 332 cons_prec = 5 -- TODO Extract this info from GHC itself
 333
 334 pprTerm :: TermPrinter -> TermPrinter
 335 pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
 336 pprTerm _ _ _ = panic "pprTerm"
 337
 338 pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
 339 pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
 340
 341 pprTermM1, ppr_termM1 :: Monad m => Term -> m SDoc
 342 pprTermM1 t    = pprDeeper `liftM` ppr_termM1 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
 360 ppr_termM _ _ t = ppr_termM1 t
 361
 362
 363 ppr_termM1 Prim{value=words, ty=ty} =
 364     return$ text$ repPrim (tyConAppTyCon ty) words
 365 ppr_termM1 Term{} = panic "ppr_termM1 - unreachable"
 366 ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
 367 ppr_termM1 Suspension{mb_ty=Just ty, bound_to=Just n}
 368   | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
 369   | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
 370 ppr_termM1 _ = panic "ppr_termM1"
 371
 372 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
 373   | Just (tc,_) <- splitNewTyConApp_maybe ty
 374   , ASSERT(isNewTyCon tc) True
 375   , Just new_dc <- maybeTyConSingleCon tc = do
 376          real_term <- y 10 t
 377          return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
 378 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
 379
 380 -------------------------------------------------------
 381 -- Custom Term Pretty Printers
 382 -------------------------------------------------------
 383
 384 -- We can want to customize the representation of a
 385 --  term depending on its type.
 386 -- However, note that custom printers have to work with
 387 --  type representations, instead of directly with types.
 388 -- We cannot use type classes here, unless we employ some
 389 --  typerep trickery (e.g. Weirich's RepLib tricks),
 390 --  which I didn't. Therefore, this code replicates a lot
 391 --  of what type classes provide for free.
 392
 393 type CustomTermPrinter m = TermPrinterM m
 394                          -> [Precedence -> Term -> (m (Maybe SDoc))]
 395
 396 -- | Takes a list of custom printers with a explicit recursion knot and a term,
 397 -- and returns the output of the first succesful printer, or the default printer
 398 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
 399 cPprTerm printers_ = go 0 where
 400   printers = printers_ go
 401   go prec t | isTerm t || isNewtypeWrap t = do
 402     let default_ = Just `liftM` pprTermM go prec t
 403         mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
 404     Just doc <- firstJustM mb_customDocs
 405     return$ cparen (prec>app_prec+1) doc
 406   go _ t = pprTermM1 t
 407
 408   firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
 409   firstJustM [] = return Nothing
 410
 411 -- Default set of custom printers. Note that the recursion knot is explicit
 412 cPprTermBase :: Monad m => CustomTermPrinter m
 413 cPprTermBase y =
 414   [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
 415                                       . mapM (y (-1))
 416                                       . subTerms)
 417   , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
 418            (\ p Term{subTerms=[h,t]} -> doList p h t)
 419   , ifTerm (isTyCon intTyCon    . ty) (coerceShow$ \(a::Int)->a)
 420   , ifTerm (isTyCon charTyCon   . ty) (coerceShow$ \(a::Char)->a)
 421   , ifTerm (isTyCon floatTyCon  . ty) (coerceShow$ \(a::Float)->a)
 422   , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
 423   , ifTerm (isIntegerTy         . ty) (coerceShow$ \(a::Integer)->a)
 424   ]
 425      where ifTerm pred f prec t@Term{}
 426                | pred t    = Just `liftM` f prec t
 427            ifTerm _ _ _ _  = return Nothing
 428
 429            isIntegerTy ty  = fromMaybe False $ do
 430              (tc,_) <- splitTyConApp_maybe ty
 431              return (tyConName tc == integerTyConName)
 432
 433            isTupleTy ty    = fromMaybe False $ do
 434              (tc,_) <- splitTyConApp_maybe ty
 435              return (tc `elem` (fst.unzip.elems) boxedTupleArr)
 436
 437            isTyCon a_tc ty = fromMaybe False $ do
 438              (tc,_) <- splitTyConApp_maybe ty
 439              return (a_tc == tc)
 440
 441            coerceShow f _p = return . text . show . f . unsafeCoerce# . val
 442
 443            --NOTE pprinting of list terms is not lazy
 444            doList p h t = do
 445                let elems      = h : getListTerms t
 446                    isConsLast = termType(last elems) /= termType h
 447                print_elems <- mapM (y cons_prec) elems
 448                return$ if isConsLast
 449                      then cparen (p >= cons_prec)
 450                         . pprDeeperList fsep
 451                         . punctuate (space<>colon)
 452                         $ print_elems
 453                      else brackets (pprDeeperList fcat$
 454                                          punctuate comma print_elems)
 455
 456                 where Just a /= Just b = not (a `coreEqType` b)
 457                       _      /=   _    = True
 458                       getListTerms Term{subTerms=[h,t]} = h : getListTerms t
 459                       getListTerms Term{subTerms=[]}    = []
 460                       getListTerms t@Suspension{}       = [t]
 461                       getListTerms t = pprPanic "getListTerms" (ppr t)
 462
 463
 464 repPrim :: TyCon -> [Word] -> String
 465 repPrim t = rep where
 466    rep x
 467     | t == charPrimTyCon   = show (build x :: Char)
 468     | t == intPrimTyCon    = show (build x :: Int)
 469     | t == wordPrimTyCon   = show (build x :: Word)
 470     | t == floatPrimTyCon  = show (build x :: Float)
 471     | t == doublePrimTyCon = show (build x :: Double)
 472     | t == int32PrimTyCon  = show (build x :: Int32)
 473     | t == word32PrimTyCon = show (build x :: Word32)
 474     | t == int64PrimTyCon  = show (build x :: Int64)
 475     | t == word64PrimTyCon = show (build x :: Word64)
 476     | t == addrPrimTyCon   = show (nullPtr `plusPtr` build x)
 477     | t == stablePtrPrimTyCon  = "<stablePtr>"
 478     | t == stableNamePrimTyCon = "<stableName>"
 479     | t == statePrimTyCon      = "<statethread>"
 480     | t == realWorldTyCon      = "<realworld>"
 481     | t == threadIdPrimTyCon   = "<ThreadId>"
 482     | t == weakPrimTyCon       = "<Weak>"
 483     | t == arrayPrimTyCon      = "<array>"
 484     | t == byteArrayPrimTyCon  = "<bytearray>"
 485     | t == mutableArrayPrimTyCon = "<mutableArray>"
 486     | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
 487     | t == mutVarPrimTyCon= "<mutVar>"
 488     | t == mVarPrimTyCon  = "<mVar>"
 489     | t == tVarPrimTyCon  = "<tVar>"
 490     | otherwise = showSDoc (char '<' <> ppr t <> char '>')
 491     where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
 492 --   This ^^^ relies on the representation of Haskell heap values being
 493 --   the same as in a C array.
 494
 495 -----------------------------------
 496 -- Type Reconstruction
 497 -----------------------------------
 498 {-
 499 Type Reconstruction is type inference done on heap closures.
 500 The algorithm walks the heap generating a set of equations, which
 501 are solved with syntactic unification.
 502 A type reconstruction equation looks like:
 503
 504   <datacon reptype>  =  <actual heap contents>
 505
 506 The full equation set is generated by traversing all the subterms, starting
 507 from a given term.
 508
 509 The only difficult part is that newtypes are only found in the lhs of equations.
 510 Right hand sides are missing them. We can either (a) drop them from the lhs, or
 511 (b) reconstruct them in the rhs when possible.
 512
 513 The function congruenceNewtypes takes a shot at (b)
 514 -}
 515
 516 -- The Type Reconstruction monad
 517 type TR a = TcM a
 518
 519 runTR :: HscEnv -> TR a -> IO a
 520 runTR hsc_env c = do
 521   mb_term <- runTR_maybe hsc_env c
 522   case mb_term of
 523     Nothing -> panic "Can't unify"
 524     Just x  -> return x
 525
 526 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
 527 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
 528
 529 traceTR :: SDoc -> TR ()
 530 traceTR = liftTcM . traceTc
 531
 532 trIO :: IO a -> TR a
 533 trIO = liftTcM . ioToTcRn
 534
 535 liftTcM :: TcM a -> TR a
 536 liftTcM = id
 537
 538 newVar :: Kind -> TR TcType
 539 newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
 540
 541 -- | Returns the instantiated type scheme ty', and the substitution sigma
 542 --   such that sigma(ty') = ty
 543 instScheme :: Type -> TR (TcType, TvSubst)
 544 instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
 545    (tvs',_theta,ty') <- tcInstType (mapM tcInstTyVar) ty
 546    return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
 547
 548 -- Adds a constraint of the form t1 == t2
 549 -- t1 is expected to come from walking the heap
 550 -- t2 is expected to come from a datacon signature
 551 -- Before unification, congruenceNewtypes needs to
 552 -- do its magic.
 553 addConstraint :: TcType -> TcType -> TR ()
 554 addConstraint t1 t2  = congruenceNewtypes t1 t2 >>= uncurry unifyType
 555                        >> return () -- TOMDO: what about the coercion?
 556                                     -- we should consider family instances
 557
 558 -- Type & Term reconstruction
 559 cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
 560 cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
 561    tv <- newVar argTypeKind
 562    case mb_ty of
 563      Nothing ->      go bound tv tv hval
 564                 >>= zonkTerm
 565                 >>= return . expandNewtypes
 566      Just ty | isMonomorphic ty ->     go bound ty ty hval
 567                                    >>= zonkTerm
 568                                    >>= return . expandNewtypes
 569      Just ty -> do
 570               (ty',rev_subst) <- instScheme (sigmaType ty)
 571               addConstraint tv ty'
 572               term <- go bound tv tv hval >>= zonkTerm
 573               --restore original Tyvars
 574               return$ expandNewtypes $ mapTermType (substTy rev_subst) term
 575     where
 576   go bound _ _ _ | seq bound False = undefined
 577   go 0 tv _ty a = do
 578     clos <- trIO $ getClosureData a
 579     return (Suspension (tipe clos) (Just tv) a Nothing)
 580   go bound tv ty a = do
 581     let monomorphic = not(isTyVarTy tv)
 582     -- This ^^^ is a convention. The ancestor tests for
 583     -- monomorphism and passes a type instead of a tv
 584     clos <- trIO $ getClosureData a
 585     case tipe clos of
 586 -- Thunks we may want to force
 587 -- NB. this won't attempt to force a BLACKHOLE.  Even with :force, we never
 588 -- force blackholes, because it would almost certainly result in deadlock,
 589 -- and showing the '_' is more useful.
 590       t | isThunk t && force -> seq a $ go (pred bound) tv ty a
 591 -- We always follow indirections
 592       Indirection _ -> go bound tv ty $! (ptrs clos ! 0)
 593  -- The interesting case
 594       Constr -> do
 595         Right dcname <- dataConInfoPtrToName (infoPtr clos)
 596         (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
 597         case mb_dc of
 598           Nothing -> do -- This can happen for private constructors compiled -O0
 599                         -- where the .hi descriptor does not export them
 600                         -- In such case, we return a best approximation:
 601                         --  ignore the unpointed args, and recover the pointeds
 602                         -- This preserves laziness, and should be safe.
 603                        let tag = showSDoc (ppr dcname)
 604                        vars     <- replicateM (length$ elems$ ptrs clos)
 605                                               (newVar (liftedTypeKind))
 606                        subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
 607                                               | (i, tv) <- zip [0..] vars]
 608                        return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
 609           Just dc -> do
 610             let extra_args = length(dataConRepArgTys dc) -
 611                              length(dataConOrigArgTys dc)
 612                 subTtypes  = matchSubTypes dc ty
 613                 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
 614             subTermTvs <- sequence
 615                  [ if isMonomorphic t then return t
 616                                       else (newVar k)
 617                    | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
 618             -- It is vital for newtype reconstruction that the unification step
 619             --  is done right here, _before_ the subterms are RTTI reconstructed
 620             when (not monomorphic) $ do
 621                   let myType = mkFunTys (reOrderTerms subTermTvs
 622                                                       subTtypesNP
 623                                                       subTtypes)
 624                                         tv
 625                   (signatureType,_) <- instScheme(dataConRepType dc)
 626                   addConstraint myType signatureType
 627             subTermsP <- sequence $ drop extra_args
 628                                  -- ^^^  all extra arguments are pointed
 629                   [ appArr (go (pred bound) tv t) (ptrs clos) i
 630                    | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
 631             let unboxeds   = extractUnboxed subTtypesNP clos
 632                 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
 633                 subTerms   = reOrderTerms subTermsP subTermsNP
 634                                 (drop extra_args subTtypes)
 635             return (Term tv (Right dc) a subTerms)
 636 -- The otherwise case: can be a Thunk,AP,PAP,etc.
 637       tipe_clos ->
 638          return (Suspension tipe_clos (Just tv) a Nothing)
 639
 640   matchSubTypes dc ty
 641     | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
 642 --     assumption:             ^^^ looks through newtypes
 643     , isVanillaDataCon dc  --TODO non-vanilla case
 644     = dataConInstArgTys dc ty_args
 645     | otherwise = dataConRepArgTys dc
 646
 647 -- This is used to put together pointed and nonpointed subterms in the
 648 --  correct order.
 649   reOrderTerms _ _ [] = []
 650   reOrderTerms pointed unpointed (ty:tys)
 651    | isPointed ty = ASSERT2(not(null pointed)
 652                             , ptext SLIT("reOrderTerms") $$
 653                                         (ppr pointed $$ ppr unpointed))
 654                     let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
 655    | otherwise    = ASSERT2(not(null unpointed)
 656                            , ptext SLIT("reOrderTerms") $$
 657                                        (ppr pointed $$ ppr unpointed))
 658                     let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
 659
 660   expandNewtypes t@Term{ ty=ty, subTerms=tt }
 661    | Just (tc, args) <- splitNewTyConApp_maybe ty
 662    , isNewTyCon tc
 663    , wrapped_type    <- newTyConInstRhs tc args
 664    , Just dc         <- maybeTyConSingleCon tc
 665    , t'              <- expandNewtypes t{ ty = wrapped_type
 666                                         , subTerms = map expandNewtypes tt }
 667    = NewtypeWrap ty (Right dc) t'
 668
 669    | otherwise = t{ subTerms = map expandNewtypes tt }
 670
 671   expandNewtypes t = t
 672
 673
 674 -- Fast, breadth-first Type reconstruction
 675 cvReconstructType :: HscEnv -> Int -> Maybe Type -> HValue -> IO (Maybe Type)
 676 cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
 677    tv <- newVar argTypeKind
 678    case mb_ty of
 679      Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
 680                           (uncurry go)
 681                           (Seq.singleton (tv, hval))
 682                           max_depth
 683                    zonkTcType tv  -- TODO untested!
 684      Just ty | isMonomorphic ty -> return ty
 685      Just ty -> do
 686               (ty',rev_subst) <- instScheme (sigmaType ty)
 687               addConstraint tv ty'
 688               search (isMonomorphic `fmap` zonkTcType tv)
 689                      (\(ty,a) -> go ty a)
 690                      (Seq.singleton (tv, hval))
 691                      max_depth
 692               substTy rev_subst `fmap` zonkTcType tv
 693     where
 694 --  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
 695   search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
 696                                 int max_depth <> text " steps")
 697   search stop expand l d =
 698     case viewl l of
 699       EmptyL  -> return ()
 700       x :< xx -> unlessM stop $ do
 701                   new <- expand x
 702                   search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
 703
 704    -- returns unification tasks,since we are going to want a breadth-first search
 705   go :: Type -> HValue -> TR [(Type, HValue)]
 706   go tv a = do
 707     clos <- trIO $ getClosureData a
 708     case tipe clos of
 709       Indirection _ -> go tv $! (ptrs clos ! 0)
 710       Constr -> do
 711         Right dcname <- dataConInfoPtrToName (infoPtr clos)
 712         (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
 713         case mb_dc of
 714           Nothing-> do
 715                      --  TODO: Check this case
 716             forM [0..length (elems $ ptrs clos)] $ \i -> do
 717                         tv <- newVar liftedTypeKind
 718                         return$ appArr (\e->(tv,e)) (ptrs clos) i
 719
 720           Just dc -> do
 721             let extra_args = length(dataConRepArgTys dc) -
 722                              length(dataConOrigArgTys dc)
 723             subTtypes <- mapMif (not . isMonomorphic)
 724                                 (\t -> newVar (typeKind t))
 725                                 (dataConRepArgTys dc)
 726
 727             -- It is vital for newtype reconstruction that the unification step
 728             -- is done right here, _before_ the subterms are RTTI reconstructed
 729             let myType         = mkFunTys subTtypes tv
 730             (signatureType,_) <- instScheme(dataConRepType dc)
 731             addConstraint myType signatureType
 732             return $ [ appArr (\e->(t,e)) (ptrs clos) i
 733                        | (i,t) <- drop extra_args $
 734                                      zip [0..] (filter isPointed subTtypes)]
 735       _ -> return []
 736
 737      -- This helper computes the difference between a base type t and the
 738      -- improved rtti_t computed by RTTI
 739      -- The main difference between RTTI types and their normal counterparts
 740      --  is that the former are _not_ polymorphic, thus polymorphism must
 741      --  be stripped. Syntactically, forall's must be stripped.
 742      -- We also remove predicates.
 743 computeRTTIsubst :: Type -> Type -> TvSubst
 744 computeRTTIsubst ty rtti_ty =
 745     case mb_subst of
 746       Just subst -> subst
 747       Nothing    -> pprPanic "Failed to compute a RTTI substitution"
 748                              (ppr (ty, rtti_ty))
 749      -- In addition, we strip newtypes too, since the reconstructed type might
 750      --   not have recovered them all
 751      -- TODO stripping newtypes shouldn't be necessary, test
 752    where mb_subst = tcUnifyTys (const BindMe)
 753                                [rttiView ty]
 754                                [rttiView rtti_ty]
 755
 756 -- Dealing with newtypes
 757 {-
 758    A parallel fold over two Type values,
 759  compensating for missing newtypes on both sides.
 760  This is necessary because newtypes are not present
 761  in runtime, but since sometimes there is evidence
 762  available we do our best to reconstruct them.
 763    Evidence can come from DataCon signatures or
 764  from compile-time type inference.
 765    I am using the words congruence and rewriting
 766  because what we are doing here is an approximation
 767  of unification modulo a set of equations, which would
 768  come from newtype definitions. These should be the
 769  equality coercions seen in System Fc. Rewriting
 770  is performed, taking those equations as rules,
 771  before launching unification.
 772
 773    It doesn't make sense to rewrite everywhere,
 774  or we would end up with all newtypes. So we rewrite
 775  only in presence of evidence.
 776    The lhs comes from the heap structure of ptrs,nptrs.
 777    The rhs comes from a DataCon type signature.
 778  Rewriting in the rhs is restricted to the result type.
 779
 780    Note that it is very tricky to make this 'rewriting'
 781  work with the unification implemented by TcM, where
 782  substitutions are 'inlined'. The order in which
 783  constraints are unified is vital for this.
 784    This is a simple form of residuation, the technique of
 785  delaying unification steps until enough information
 786  is available.
 787 -}
 788 congruenceNewtypes ::  TcType -> TcType -> TR (TcType,TcType)
 789 congruenceNewtypes lhs rhs
 790  -- TyVar lhs inductive case
 791     | Just tv <- getTyVar_maybe lhs
 792     = recoverTc (return (lhs,rhs)) $ do
 793          Indirect ty_v <- readMetaTyVar tv
 794          (_lhs1, rhs1) <- congruenceNewtypes ty_v rhs
 795          return (lhs, rhs1)
 796 -- FunTy inductive case
 797     | Just (l1,l2) <- splitFunTy_maybe lhs
 798     , Just (r1,r2) <- splitFunTy_maybe rhs
 799     = do (l2',r2') <- congruenceNewtypes l2 r2
 800          (l1',r1') <- congruenceNewtypes l1 r1
 801          return (mkFunTy l1' l2', mkFunTy r1' r2')
 802 -- TyconApp Inductive case; this is the interesting bit.
 803     | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
 804     , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
 805     , tycon_l /= tycon_r
 806     = do rhs' <- upgrade tycon_l rhs
 807          return (lhs, rhs')
 808
 809     | otherwise = return (lhs,rhs)
 810
 811     where upgrade :: TyCon -> Type -> TR Type
 812           upgrade new_tycon ty
 813             | not (isNewTyCon new_tycon) = return ty
 814             | otherwise = do
 815                vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
 816                let ty' = mkTyConApp new_tycon vars
 817                liftTcM (unifyType ty (repType ty'))
 818         -- assumes that reptype doesn't ^^^^ touch tyconApp args
 819                return ty'
 820
 821
 822 --------------------------------------------------------------------------------
 823 -- Semantically different to recoverM in TcRnMonad
 824 -- recoverM retains the errors in the first action,
 825 --  whereas recoverTc here does not
 826 recoverTc :: TcM a -> TcM a -> TcM a
 827 recoverTc recover thing = do
 828   (_,mb_res) <- tryTcErrs thing
 829   case mb_res of
 830     Nothing  -> recover
 831     Just res -> return res
 832
 833 isMonomorphic :: Type -> Bool
 834 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
 835                  = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
 836
 837 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
 838 mapMif pred f xx = sequence $ mapMif_ pred f xx
 839   where
 840    mapMif_ _ _ []     = []
 841    mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
 842
 843 unlessM :: Monad m => m Bool -> m () -> m ()
 844 unlessM condM acc = condM >>= \c -> unless c acc
 845
 846 -- Strict application of f at index i
 847 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
 848 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
 849  = ASSERT (i < length(elems a))
 850    case indexArray# ptrs# i# of
 851        (# e #) -> f e
 852
 853 zonkTerm :: Term -> TcM Term
 854 zonkTerm = foldTerm idTermFoldM {
 855               fTerm = \ty dc v tt -> sequence tt      >>= \tt ->
 856                                      zonkTcType ty    >>= \ty' ->
 857                                      return (Term ty' dc v tt)
 858              ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
 859                                           return (Suspension ct ty v b)
 860              ,fNewtypeWrap= \ty dc t ->
 861                    return NewtypeWrap `ap` zonkTcType ty `ap` return dc `ap` t}
 862
 863
 864 -- Is this defined elsewhere?
 865 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
 866 sigmaType :: Type -> Type
 867 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
 868
 869