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