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 -> Bool -> Maybe Type -> HValue -> IO Term
  12
  13      Term(..),
  14      pprTerm,
  15      cPprTerm,
  16      cPprTermBase,
  17      termType,
  18      foldTerm,
  19      TermFold(..),
  20      idTermFold,
  21      idTermFoldM,
  22      isFullyEvaluated,
  23      isPointed,
  24      isFullyEvaluatedTerm,
  25 --     unsafeDeepSeq,
  26  ) where
  27
  28 #include "HsVersions.h"
  29
  30 import ByteCodeItbls    ( StgInfoTable )
  31 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
  32 import ByteCodeLink     ( HValue )
  33 import HscTypes         ( HscEnv )
  34
  35 import DataCon
  36 import Type
  37 import TcRnMonad        ( TcM, initTcPrintErrors, ioToTcRn, recoverM, writeMutVar )
  38 import TcType
  39 import TcMType
  40 import TcUnify
  41 import TcGadt
  42 import TyCon
  43 import Var
  44 import Name
  45 import VarEnv
  46 import OccName
  47 import VarSet
  48 import {-#SOURCE#-} TcRnDriver ( tcRnRecoverDataCon )
  49
  50 import TysPrim
  51 import PrelNames
  52 import TysWiredIn
  53
  54 import Constants        ( wORD_SIZE )
  55 import Outputable
  56 import Maybes
  57 import Panic
  58 import FiniteMap
  59
  60 import GHC.Arr          ( Array(..) )
  61 import GHC.Ptr          ( Ptr(..), castPtr )
  62 import GHC.Exts
  63 import GHC.Int          ( Int32(..),  Int64(..) )
  64 import GHC.Word         ( Word32(..), Word64(..) )
  65
  66 import Control.Monad
  67 import Data.Maybe
  68 import Data.Array.Base
  69 import Data.List        ( partition )
  70 import Foreign.Storable
  71
  72 import IO
  73
  74 ---------------------------------------------
  75 -- * A representation of semi evaluated Terms
  76 ---------------------------------------------
  77 {-
  78   A few examples in this representation:
  79
  80   > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
  81
  82   > (('a',_,_),_,('b',_,_)) =
  83       Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
  84           [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
  85           , Suspension
  86           , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
  87 -}
  88
  89 data Term = Term { ty        :: Type
  90                  , dc        :: DataCon
  91                  , val       :: HValue
  92                  , subTerms  :: [Term] }
  93
  94           | Prim { ty        :: Type
  95                  , value     :: String }
  96
  97           | Suspension { ctype    :: ClosureType
  98                        , mb_ty    :: Maybe Type
  99                        , val      :: HValue
 100                        , bound_to :: Maybe Name   -- Useful for printing
 101                        }
 102
 103 isTerm Term{} = True
 104 isTerm   _    = False
 105 isSuspension Suspension{} = True
 106 isSuspension      _       = False
 107 isPrim Prim{} = True
 108 isPrim   _    = False
 109
 110 termType t@(Suspension {}) = mb_ty t
 111 termType t = Just$ ty t
 112
 113 isFullyEvaluatedTerm :: Term -> Bool
 114 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
 115 isFullyEvaluatedTerm Suspension {}      = False
 116 isFullyEvaluatedTerm Prim {}            = True
 117
 118 instance Outputable (Term) where
 119  ppr = head . cPprTerm cPprTermBase
 120
 121 -------------------------------------------------------------------------
 122 -- Runtime Closure Datatype and functions for retrieving closure related stuff
 123 -------------------------------------------------------------------------
 124 data ClosureType = Constr
 125                  | Fun
 126                  | Thunk Int
 127                  | ThunkSelector
 128                  | Blackhole
 129                  | AP
 130                  | PAP
 131                  | Indirection Int
 132                  | Other Int
 133  deriving (Show, Eq)
 134
 135 data Closure = Closure { tipe         :: ClosureType
 136                        , infoPtr      :: Ptr ()
 137                        , infoTable    :: StgInfoTable
 138                        , ptrs         :: Array Int HValue
 139                        , nonPtrs      :: ByteArray#
 140                        }
 141
 142 instance Outputable ClosureType where
 143   ppr = text . show
 144
 145 #include "../includes/ClosureTypes.h"
 146
 147 aP_CODE = AP
 148 pAP_CODE = PAP
 149 #undef AP
 150 #undef PAP
 151
 152 getClosureData :: a -> IO Closure
 153 getClosureData a =
 154    case unpackClosure# a of
 155      (# iptr, ptrs, nptrs #) -> do
 156            itbl <- peek (Ptr iptr)
 157            let tipe = readCType (BCI.tipe itbl)
 158                elems = BCI.ptrs itbl
 159                ptrsList = Array 0 (fromIntegral$ elems) ptrs
 160            ptrsList `seq` return (Closure tipe (Ptr iptr) itbl ptrsList nptrs)
 161
 162 readCType :: Integral a => a -> ClosureType
 163 readCType i
 164  | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
 165  | i >= FUN    && i <= FUN_STATIC          = Fun
 166  | i >= THUNK  && i < THUNK_SELECTOR       = Thunk (fromIntegral i)
 167  | i == THUNK_SELECTOR                     = ThunkSelector
 168  | i == BLACKHOLE                          = Blackhole
 169  | i >= IND    && i <= IND_STATIC          = Indirection (fromIntegral i)
 170  | fromIntegral i == aP_CODE               = AP
 171  | i == AP_STACK                           = AP
 172  | fromIntegral i == pAP_CODE              = PAP
 173  | otherwise                               = Other (fromIntegral i)
 174
 175 isConstr, isIndirection :: ClosureType -> Bool
 176 isConstr Constr = True
 177 isConstr    _   = False
 178
 179 isIndirection (Indirection _) = True
 180 --isIndirection ThunkSelector = True
 181 isIndirection _ = False
 182
 183 isThunk (Thunk _)     = True
 184 isThunk ThunkSelector = True
 185 isThunk AP            = True
 186 isThunk _             = False
 187
 188 isFullyEvaluated :: a -> IO Bool
 189 isFullyEvaluated a = do
 190   closure <- getClosureData a
 191   case tipe closure of
 192     Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
 193                  return$ and are_subs_evaluated
 194     otherwise -> return False
 195   where amapM f = sequence . amap' f
 196
 197 amap' f (Array i0 i arr#) = map (\(I# i#) -> case indexArray# arr# i# of
 198                                    (# e #) -> f e)
 199                                 [0 .. i - i0]
 200
 201 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
 202 {-
 203 unsafeDeepSeq :: a -> b -> b
 204 unsafeDeepSeq = unsafeDeepSeq1 2
 205  where unsafeDeepSeq1 0 a b = seq a $! b
 206        unsafeDeepSeq1 i a b                -- 1st case avoids infinite loops for non reducible thunks
 207         | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
 208      -- | unsafePerformIO (isFullyEvaluated a) = b
 209         | otherwise = case unsafePerformIO (getClosureData a) of
 210                         closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
 211         where tipe = unsafePerformIO (getClosureType a)
 212 -}
 213 isPointed :: Type -> Bool
 214 isPointed t | Just (t, _) <- splitTyConApp_maybe t = not$ isUnliftedTypeKind (tyConKind t)
 215 isPointed _ = True
 216
 217 #define MKDECODER(offset,cons,builder) (offset, show$ cons (builder addr 0#))
 218
 219 extractUnboxed  :: [Type] -> ByteArray# -> [String]
 220 extractUnboxed tt ba = helper tt (byteArrayContents# ba)
 221    where helper :: [Type] -> Addr# -> [String]
 222          helper (t:tt) addr
 223           | Just ( tycon,_) <- splitTyConApp_maybe t
 224           =  let (offset, txt) = decode tycon addr
 225                  (I# word_offset)   = offset*wORD_SIZE
 226              in txt : helper tt (plusAddr# addr word_offset)
 227           | otherwise
 228           = -- ["extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)]
 229             panic$ "extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)
 230          helper [] addr = []
 231          decode :: TyCon -> Addr# -> (Int, String)
 232          decode t addr
 233            | t == charPrimTyCon   = MKDECODER(1,C#,indexCharOffAddr#)
 234            | t == intPrimTyCon    = MKDECODER(1,I#,indexIntOffAddr#)
 235            | t == wordPrimTyCon   = MKDECODER(1,W#,indexWordOffAddr#)
 236            | t == floatPrimTyCon  = MKDECODER(1,F#,indexFloatOffAddr#)
 237            | t == doublePrimTyCon = MKDECODER(2,D#,indexDoubleOffAddr#)
 238            | t == int32PrimTyCon  = MKDECODER(1,I32#,indexInt32OffAddr#)
 239            | t == word32PrimTyCon = MKDECODER(1,W32#,indexWord32OffAddr#)
 240            | t == int64PrimTyCon  = MKDECODER(2,I64#,indexInt64OffAddr#)
 241            | t == word64PrimTyCon = MKDECODER(2,W64#,indexWord64OffAddr#)
 242            | t == addrPrimTyCon   = MKDECODER(1,I#,(\x off-> addr2Int# (indexAddrOffAddr# x off)))  --OPT Improve the presentation of addresses
 243            | t == stablePtrPrimTyCon  = (1, "<stablePtr>")
 244            | t == stableNamePrimTyCon = (1, "<stableName>")
 245            | t == statePrimTyCon      = (1, "<statethread>")
 246            | t == realWorldTyCon      = (1, "<realworld>")
 247            | t == threadIdPrimTyCon   = (1, "<ThreadId>")
 248            | t == weakPrimTyCon       = (1, "<Weak>")
 249            | t == arrayPrimTyCon      = (1,"<array>")
 250            | t == byteArrayPrimTyCon  = (1,"<bytearray>")
 251            | t == mutableArrayPrimTyCon = (1, "<mutableArray>")
 252            | t == mutableByteArrayPrimTyCon = (1, "<mutableByteArray>")
 253            | t == mutVarPrimTyCon= (1, "<mutVar>")
 254            | t == mVarPrimTyCon  = (1, "<mVar>")
 255            | t == tVarPrimTyCon  = (1, "<tVar>")
 256            | otherwise = (1, showSDoc (char '<' <> ppr t <> char '>'))
 257                  -- We cannot know the right offset in the otherwise case, so 1 is just a wild dangerous guess!
 258            -- TODO: Improve the offset handling in decode (make it machine dependant)
 259
 260 -----------------------------------
 261 -- * Traversals for Terms
 262 -----------------------------------
 263
 264 data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a
 265                            , fPrim :: Type -> String -> a
 266                            , fSuspension :: ClosureType -> Maybe Type -> HValue -> 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 ----------------------------------
 288 -- Pretty printing of terms
 289 ----------------------------------
 290
 291 app_prec::Int
 292 app_prec = 10
 293
 294 pprTerm :: Int -> Term -> SDoc
 295 pprTerm p Term{dc=dc, subTerms=tt}
 296 {-  | dataConIsInfix dc, (t1:t2:tt') <- tt
 297   = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2)
 298     <+> hsep (map (pprTerm1 True) tt)
 299 -}
 300   | null tt   = ppr dc
 301   | otherwise = cparen (p >= app_prec)
 302                        (ppr dc <+> sep (map (pprTerm app_prec) tt))
 303
 304   where fixity   = undefined
 305
 306 pprTerm _ t = pprTerm1 t
 307
 308 pprTerm1 Prim{value=value} = text value
 309 pprTerm1 t@Term{} = pprTerm 0 t
 310 pprTerm1 Suspension{bound_to=Nothing} =  char '_' -- <> ppr ct <> char '_'
 311 pprTerm1 Suspension{mb_ty=Just ty, bound_to=Just n}
 312   | Just _ <- splitFunTy_maybe ty = ptext SLIT("<function>")
 313   | otherwise = parens$ ppr n <> text "::" <> ppr ty
 314
 315
 316 cPprTerm :: forall m. Monad m => ((Int->Term->m SDoc)->[Int->Term->m (Maybe SDoc)]) -> Term -> m SDoc
 317 cPprTerm custom = go 0 where
 318   go prec t@Term{subTerms=tt, dc=dc} = do
 319     let mb_customDocs = map (($t) . ($prec)) (custom go) :: [m (Maybe SDoc)]
 320     first_success <- firstJustM mb_customDocs
 321     case first_success of
 322       Just doc -> return$ cparen (prec>app_prec+1) doc
 323 --    | dataConIsInfix dc, (t1:t2:tt') <- tt =
 324       Nothing  -> do pprSubterms <- mapM (go (app_prec+1)) tt
 325                      return$ cparen (prec >= app_prec)
 326                                     (ppr dc <+> sep pprSubterms)
 327   go _ t = return$ pprTerm1 t
 328   firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
 329   firstJustM [] = return Nothing
 330
 331 cPprTermBase :: Monad m => (Int->Term-> m SDoc)->[Int->Term->m (Maybe SDoc)]
 332 cPprTermBase pprP =
 333   [
 334     ifTerm isTupleDC            (\_ -> liftM (parens . hcat . punctuate comma)
 335                                  . mapM (pprP (-1)) . subTerms)
 336   , ifTerm (isDC consDataCon)   (\ p Term{subTerms=[h,t]} -> doList p h t)
 337   , ifTerm (isDC intDataCon)    (coerceShow$ \(a::Int)->a)
 338   , ifTerm (isDC charDataCon)   (coerceShow$ \(a::Char)->a)
 339 --  , ifTerm (isDC wordDataCon) (coerceShow$ \(a::Word)->a)
 340   , ifTerm (isDC floatDataCon)  (coerceShow$ \(a::Float)->a)
 341   , ifTerm (isDC doubleDataCon) (coerceShow$ \(a::Double)->a)
 342   , ifTerm isIntegerDC          (coerceShow$ \(a::Integer)->a)
 343   ]
 344      where ifTerm pred f p t = if pred t then liftM Just (f p t) else return Nothing
 345            isIntegerDC Term{dc=dc} =
 346               dataConName dc `elem` [ smallIntegerDataConName
 347                                     , largeIntegerDataConName]
 348            isTupleDC Term{dc=dc} = dc `elem` snd (unzip (elems boxedTupleArr))
 349            isDC a_dc Term{dc=dc} = a_dc == dc
 350            coerceShow f _ = return . text . show . f . unsafeCoerce# . val
 351            --TODO pprinting of list terms is not lazy
 352            doList p h t = do
 353                let elems = h : getListTerms t
 354                    isConsLast = termType(last elems) /= termType h
 355                print_elems <- mapM (pprP 5) elems
 356                return$ if isConsLast
 357                      then cparen (p >= 5) . hsep . punctuate (space<>colon)
 358                            $ print_elems
 359                      else brackets (hcat$ punctuate comma print_elems)
 360
 361                 where Just a /= Just b = not (a `coreEqType` b)
 362                       _      /=   _    = True
 363                       getListTerms Term{subTerms=[h,t]} = h : getListTerms t
 364                       getListTerms t@Term{subTerms=[]}  = []
 365                       getListTerms t@Suspension{}       = [t]
 366                       getListTerms t = pprPanic "getListTerms" (ppr t)
 367
 368 -----------------------------------
 369 -- Type Reconstruction
 370 -----------------------------------
 371
 372 -- The Type Reconstruction monad
 373 type TR a = TcM a
 374
 375 runTR :: HscEnv -> TR Term -> IO Term
 376 runTR hsc_env c = do
 377   mb_term <- initTcPrintErrors hsc_env iNTERACTIVE (c >>= zonkTerm)
 378   case mb_term of
 379     Nothing -> panic "Can't unify"
 380     Just term -> return term
 381
 382 trIO :: IO a -> TR a
 383 trIO = liftTcM . ioToTcRn
 384
 385 addConstraint :: TcType -> TcType -> TR ()
 386 addConstraint t1 t2  = congruenceNewtypes t1 t2 >>= uncurry unifyType
 387
 388 {-
 389    A parallel fold over two Type values,
 390  compensating for missing newtypes on both sides.
 391  This is necessary because newtypes are not present
 392  in runtime, but since sometimes there is evidence
 393  available we do our best to reconstruct them.
 394    Evidence can come from DataCon signatures or
 395  from compile-time type inference.
 396    I am using the words congruence and rewriting
 397  because what we are doing here is an approximation
 398  of unification modulo a set of equations, which would
 399  come from newtype definitions. These should be the
 400  equality coercions seen in System Fc. Rewriting
 401  is performed, taking those equations as rules,
 402  before launching unification.
 403
 404    It doesn't make sense to rewrite everywhere,
 405  or we would end up with all newtypes. So we rewrite
 406  only in presence of evidence.
 407    The lhs comes from the heap structure of ptrs,nptrs.
 408    The rhs comes from a DataCon type signature.
 409  Rewriting in the rhs is restricted to the result type.
 410
 411    Note that it is very tricky to make this 'rewriting'
 412  work with the unification implemented by TcM, where
 413  substitutions are 'inlined'. The order in which
 414  constraints are unified is vital for this (or I am
 415  using TcM wrongly).
 416 -}
 417 congruenceNewtypes ::  TcType -> TcType -> TcM (TcType,TcType)
 418 congruenceNewtypes = go True
 419   where
 420    go rewriteRHS lhs rhs
 421  -- TyVar lhs inductive case
 422     | Just tv <- getTyVar_maybe lhs
 423     = recoverM (return (lhs,rhs)) $ do
 424          Indirect ty_v <- readMetaTyVar tv
 425          (lhs', rhs') <- go rewriteRHS ty_v rhs
 426          writeMutVar (metaTvRef tv) (Indirect lhs')
 427          return (lhs, rhs')
 428  -- TyVar rhs inductive case
 429     | Just tv <- getTyVar_maybe rhs
 430     = recoverM (return (lhs,rhs)) $ do
 431          Indirect ty_v <- readMetaTyVar tv
 432          (lhs', rhs') <- go rewriteRHS lhs ty_v
 433          writeMutVar (metaTvRef tv) (Indirect rhs')
 434          return (lhs', rhs)
 435 -- FunTy inductive case
 436     | Just (l1,l2) <- splitFunTy_maybe lhs
 437     , Just (r1,r2) <- splitFunTy_maybe rhs
 438     = do (l2',r2') <- go True l2 r2
 439          (l1',r1') <- go False l1 r1
 440          return (mkFunTy l1' l2', mkFunTy r1' r2')
 441 -- TyconApp Inductive case; this is the interesting bit.
 442     | Just (tycon_l, args_l) <- splitNewTyConApp_maybe lhs
 443     , Just (tycon_r, args_r) <- splitNewTyConApp_maybe rhs = do
 444
 445       let (tycon_l',args_l') = if isNewTyCon tycon_r && not(isNewTyCon tycon_l)
 446                                 then (tycon_r, rewrite tycon_r lhs)
 447                                 else (tycon_l, args_l)
 448           (tycon_r',args_r') = if rewriteRHS && isNewTyCon tycon_l && not(isNewTyCon tycon_r)
 449                                 then (tycon_l, rewrite tycon_l rhs)
 450                                 else (tycon_r, args_r)
 451       (args_l'', args_r'') <- unzip `liftM` zipWithM (go rewriteRHS) args_l' args_r'
 452       return (mkTyConApp tycon_l' args_l'', mkTyConApp tycon_r' args_r'')
 453
 454     | otherwise = return (lhs,rhs)
 455
 456     where rewrite newtyped_tc lame_tipe
 457            | (tvs, tipe) <- newTyConRep newtyped_tc
 458            = case tcUnifyTys (const BindMe) [tipe] [lame_tipe] of
 459                Just subst -> substTys subst (map mkTyVarTy tvs)
 460                otherwise  -> panic "congruenceNewtypes: Can't unify a newtype"
 461
 462 newVar :: Kind -> TR TcTyVar
 463 newVar = liftTcM . newFlexiTyVar
 464
 465 liftTcM = id
 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 cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
 475 cvObtainTerm hsc_env force mb_ty a = do
 476    -- Obtain the term and tidy the type before returning it
 477    term <- cvObtainTerm1 hsc_env force mb_ty a
 478    return $ tidyTypes term
 479    where
 480          tidyTypes = foldTerm idTermFold {
 481             fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt,
 482             fSuspension = \ct mb_ty hval n ->
 483                           Suspension ct (fmap tidy mb_ty) hval n
 484             }
 485          tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv ty) ty
 486          tidyVarEnv ty = mkVarEnv$
 487                          [ (v, setTyVarName v (tyVarName tv))
 488                            | (tv,v) <- zip alphaTyVars vars]
 489              where vars = varSetElems$ tyVarsOfType ty
 490
 491 cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
 492 cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
 493    tv <- liftM mkTyVarTy (newVar argTypeKind)
 494    case mb_ty of
 495      Nothing -> go tv tv hval
 496      Just ty | isMonomorphic ty -> go ty ty hval
 497      Just ty -> do
 498               (ty',rev_subst) <- instScheme (sigmaType ty)
 499               addConstraint tv ty'
 500               term <- go tv tv hval
 501               --restore original Tyvars
 502               return$ flip foldTerm term idTermFold {
 503                 fTerm = \ty dc hval tt -> Term (substTy rev_subst ty) dc hval tt,
 504                 fSuspension = \ct mb_ty hval n ->
 505                           Suspension ct (substTy rev_subst `fmap` mb_ty) hval n}
 506     where
 507   go tv ty a = do
 508     let monomorphic = not(isTyVarTy tv)   -- This is a convention. The ancestor tests for
 509                                          -- monomorphism and passes a type instead of a tv
 510     clos <- trIO $ getClosureData a
 511     case tipe clos of
 512 -- Thunks we may want to force
 513       t | isThunk t && force -> seq a $ go tv ty a
 514 -- We always follow indirections
 515       Indirection _ -> go tv ty $! (ptrs clos ! 0)
 516  -- The interesting case
 517       Constr -> do
 518         m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
 519         case m_dc of
 520           Nothing -> panic "Can't find the DataCon for a term"
 521           Just dc -> do
 522             let extra_args = length(dataConRepArgTys dc) - length(dataConOrigArgTys dc)
 523                 subTtypes  = matchSubTypes dc ty
 524                 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
 525             subTermTvs <- sequence
 526                  [ if isMonomorphic t then return t else (mkTyVarTy `fmap` newVar k)
 527                    | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
 528             -- It is vital for newtype reconstruction that the unification step is done
 529             --     right here, _before_ the subterms are RTTI reconstructed.
 530             when (not monomorphic) $ do
 531                   let myType = mkFunTys (reOrderTerms subTermTvs subTtypesNP subTtypes) tv
 532                   instScheme(dataConRepType dc) >>= addConstraint myType . fst
 533             subTermsP <- sequence $ drop extra_args -- all extra arguments are pointed
 534                   [ appArr (go tv t) (ptrs clos) i
 535                    | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
 536             let unboxeds   = extractUnboxed subTtypesNP (nonPtrs clos)
 537                 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
 538                 subTerms   = reOrderTerms subTermsP subTermsNP (drop extra_args subTtypes)
 539             return (Term tv dc a subTerms)
 540 -- The otherwise case: can be a Thunk,AP,PAP,etc.
 541       otherwise ->
 542          return (Suspension (tipe clos) (Just tv) a Nothing)
 543
 544 -- Access the array of pointers and recurse down. Needs to be done with
 545 -- care of no introducing a thunk! or go will fail to do its job
 546   appArr f arr (I# i#) = case arr of
 547                  (Array _ _ ptrs#) -> case indexArray# ptrs# i# of
 548                        (# e #) -> f e
 549
 550   matchSubTypes dc ty
 551     | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
 552     , null (dataConExTyVars dc)  --TODO Handle the case of extra existential tyvars
 553     = dataConInstArgTys dc ty_args
 554
 555     | otherwise = dataConRepArgTys dc
 556
 557 -- This is used to put together pointed and nonpointed subterms in the
 558 --  correct order.
 559   reOrderTerms _ _ [] = []
 560   reOrderTerms pointed unpointed (ty:tys)
 561    | isPointed ty = ASSERT2(not(null pointed)
 562                            , ptext SLIT("reOrderTerms") $$ (ppr pointed $$ ppr unpointed))
 563                     head pointed : reOrderTerms (tail pointed) unpointed tys
 564    | otherwise    = ASSERT2(not(null unpointed)
 565                            , ptext SLIT("reOrderTerms") $$ (ppr pointed $$ ppr unpointed))
 566                     head unpointed : reOrderTerms pointed (tail unpointed) tys
 567
 568 isMonomorphic ty | isForAllTy ty = False
 569 isMonomorphic ty = (isEmptyVarSet . tyVarsOfType) ty
 570
 571 zonkTerm :: Term -> TcM Term
 572 zonkTerm = foldTerm idTermFoldM {
 573               fTerm = \ty dc v tt -> sequence tt      >>= \tt ->
 574                                      zonkTcType ty    >>= \ty' ->
 575                                      return (Term ty' dc v tt)
 576              ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
 577                                           return (Suspension ct ty v b)}
 578
 579
 580 -- Is this defined elsewhere?
 581 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
 582 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
 583
 584 {-
 585 Example of Type Reconstruction
 586 --------------------------------
 587 Suppose we have an existential type such as
 588
 589 data Opaque = forall a. Opaque a
 590
 591 And we have a term built as:
 592
 593 t = Opaque (map Just [[1,1],[2,2]])
 594
 595 The type of t as far as the typechecker goes is t :: Opaque
 596 If we seq the head of t, we obtain:
 597
 598 t - O (_1::a)
 599
 600 seq _1 ()
 601
 602 t - O ( (_3::b) : (_4::[b]) )
 603
 604 seq _3 ()
 605
 606 t - O ( (Just (_5::c)) : (_4::[b]) )
 607
 608 At this point, we know that b = (Maybe c)
 609
 610 seq _5 ()
 611
 612 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[b]) )
 613
 614 At this point, we know that c = [d]
 615
 616 seq _6 ()
 617
 618 t - O ( (Just (1 : (_7::[d]) )) : (_4::[b]) )
 619
 620 At this point, we know that d = Integer
 621
 622 The fully reconstructed expressions, with propagation, would be:
 623
 624 t - O ( (Just (_5::c)) : (_4::[Maybe c]) )
 625 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[Maybe [d]]) )
 626 t - O ( (Just (1 : (_7::[Integer]) )) : (_4::[Maybe [Integer]]) )
 627
 628
 629 For reference, the type of the thing inside the opaque is
 630 map Just [[1,1],[2,2]] :: [Maybe [Integer]]
 631
 632 NOTE: (Num t) contexts have been manually replaced by Integer for clarity
 633 -}