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