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