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