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