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