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, nub )
  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    let term' =  tidyTypes term
 479    return term'
 480    where allvars = nub . foldTerm TermFold {
 481             fTerm       = \ty _ _ tt   ->
 482                           varEnvElts(tyVarsOfType ty) ++ concat tt,
 483             fSuspension = \_ mb_ty _ _ ->
 484                           maybe [] (varEnvElts . tyVarsOfType) mb_ty,
 485             fPrim       = \ _ _ -> [] }
 486          tidyTypes term = let
 487            go = foldTerm idTermFold {
 488                   fTerm       = \ty dc hval tt ->
 489                           Term (tidy ty) dc hval tt,
 490                   fSuspension = \ct mb_ty hval n ->
 491                           Suspension ct (fmap tidy mb_ty) hval n }
 492            tidy ty      = tidyType (emptyTidyOccEnv, tidyVarEnv) ty
 493            tidyVarEnv   = mkVarEnv$
 494                          [ (v, alpha_tv `setTyVarUnique` varUnique v)
 495                            | (alpha_tv,v) <- zip alphaTyVars (allvars term)]
 496            in go term
 497
 498 cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
 499 cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
 500    tv <- liftM mkTyVarTy (newVar argTypeKind)
 501    case mb_ty of
 502      Nothing -> go tv tv hval
 503      Just ty | isMonomorphic ty -> go ty ty hval
 504      Just ty -> do
 505               (ty',rev_subst) <- instScheme (sigmaType ty)
 506               addConstraint tv ty'
 507               term <- go tv tv hval
 508               --restore original Tyvars
 509               return$ flip foldTerm term idTermFold {
 510                 fTerm = \ty dc hval tt -> Term (substTy rev_subst ty) dc hval tt,
 511                 fSuspension = \ct mb_ty hval n ->
 512                           Suspension ct (substTy rev_subst `fmap` mb_ty) hval n}
 513     where
 514   go tv ty a = do
 515     let monomorphic = not(isTyVarTy tv)   -- This is a convention. The ancestor tests for
 516                                          -- monomorphism and passes a type instead of a tv
 517     clos <- trIO $ getClosureData a
 518     case tipe clos of
 519 -- Thunks we may want to force
 520       t | isThunk t && force -> seq a $ go tv ty a
 521 -- We always follow indirections
 522       Indirection _ -> go tv ty $! (ptrs clos ! 0)
 523  -- The interesting case
 524       Constr -> do
 525         m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
 526         case m_dc of
 527           Nothing -> panic "Can't find the DataCon for a term"
 528           Just dc -> do
 529             let extra_args = length(dataConRepArgTys dc) - length(dataConOrigArgTys dc)
 530                 subTtypes  = matchSubTypes dc ty
 531                 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
 532             subTermTvs <- sequence
 533                  [ if isMonomorphic t then return t else (mkTyVarTy `fmap` newVar k)
 534                    | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
 535             -- It is vital for newtype reconstruction that the unification step is done
 536             --     right here, _before_ the subterms are RTTI reconstructed.
 537             when (not monomorphic) $ do
 538                   let myType = mkFunTys (reOrderTerms subTermTvs subTtypesNP subTtypes) tv
 539                   instScheme(dataConRepType dc) >>= addConstraint myType . fst
 540             subTermsP <- sequence $ drop extra_args -- all extra arguments are pointed
 541                   [ appArr (go tv t) (ptrs clos) i
 542                    | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
 543             let unboxeds   = extractUnboxed subTtypesNP (nonPtrs clos)
 544                 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
 545                 subTerms   = reOrderTerms subTermsP subTermsNP (drop extra_args subTtypes)
 546             return (Term tv dc a subTerms)
 547 -- The otherwise case: can be a Thunk,AP,PAP,etc.
 548       otherwise ->
 549          return (Suspension (tipe clos) (Just tv) a Nothing)
 550
 551 -- Access the array of pointers and recurse down. Needs to be done with
 552 -- care of no introducing a thunk! or go will fail to do its job
 553   appArr f arr (I# i#) = case arr of
 554                  (Array _ _ ptrs#) -> case indexArray# ptrs# i# of
 555                        (# e #) -> f e
 556
 557   matchSubTypes dc ty
 558     | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
 559     , null (dataConExTyVars dc)  --TODO Handle the case of extra existential tyvars
 560     = dataConInstArgTys dc ty_args
 561
 562     | otherwise = dataConRepArgTys dc
 563
 564 -- This is used to put together pointed and nonpointed subterms in the
 565 --  correct order.
 566   reOrderTerms _ _ [] = []
 567   reOrderTerms pointed unpointed (ty:tys)
 568    | isPointed ty = ASSERT2(not(null pointed)
 569                            , ptext SLIT("reOrderTerms") $$ (ppr pointed $$ ppr unpointed))
 570                     head pointed : reOrderTerms (tail pointed) unpointed tys
 571    | otherwise    = ASSERT2(not(null unpointed)
 572                            , ptext SLIT("reOrderTerms") $$ (ppr pointed $$ ppr unpointed))
 573                     head unpointed : reOrderTerms pointed (tail unpointed) tys
 574
 575 isMonomorphic ty | isForAllTy ty = False
 576 isMonomorphic ty = (isEmptyVarSet . tyVarsOfType) ty
 577
 578 zonkTerm :: Term -> TcM Term
 579 zonkTerm = foldTerm idTermFoldM {
 580               fTerm = \ty dc v tt -> sequence tt      >>= \tt ->
 581                                      zonkTcType ty    >>= \ty' ->
 582                                      return (Term ty' dc v tt)
 583              ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
 584                                           return (Suspension ct ty v b)}
 585
 586
 587 -- Is this defined elsewhere?
 588 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
 589 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
 590
 591 {-
 592 Example of Type Reconstruction
 593 --------------------------------
 594 Suppose we have an existential type such as
 595
 596 data Opaque = forall a. Opaque a
 597
 598 And we have a term built as:
 599
 600 t = Opaque (map Just [[1,1],[2,2]])
 601
 602 The type of t as far as the typechecker goes is t :: Opaque
 603 If we seq the head of t, we obtain:
 604
 605 t - O (_1::a)
 606
 607 seq _1 ()
 608
 609 t - O ( (_3::b) : (_4::[b]) )
 610
 611 seq _3 ()
 612
 613 t - O ( (Just (_5::c)) : (_4::[b]) )
 614
 615 At this point, we know that b = (Maybe c)
 616
 617 seq _5 ()
 618
 619 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[b]) )
 620
 621 At this point, we know that c = [d]
 622
 623 seq _6 ()
 624
 625 t - O ( (Just (1 : (_7::[d]) )) : (_4::[b]) )
 626
 627 At this point, we know that d = Integer
 628
 629 The fully reconstructed expressions, with propagation, would be:
 630
 631 t - O ( (Just (_5::c)) : (_4::[Maybe c]) )
 632 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[Maybe [d]]) )
 633 t - O ( (Just (1 : (_7::[Integer]) )) : (_4::[Maybe [Integer]]) )
 634
 635
 636 For reference, the type of the thing inside the opaque is
 637 map Just [[1,1],[2,2]] :: [Maybe [Integer]]
 638
 639 NOTE: (Num t) contexts have been manually replaced by Integer for clarity
 640 -}