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  | fromIntegral i == pAP_CODE              = PAP
 172  | otherwise                               = Other (fromIntegral i)
 173
 174 isConstr, isIndirection :: ClosureType -> Bool
 175 isConstr Constr = True
 176 isConstr    _   = False
 177
 178 isIndirection (Indirection _) = True
 179 --isIndirection ThunkSelector = True
 180 isIndirection _ = False
 181
 182 isFullyEvaluated :: a -> IO Bool
 183 isFullyEvaluated a = do
 184   closure <- getClosureData a
 185   case tipe closure of
 186     Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
 187                  return$ and are_subs_evaluated
 188     otherwise -> return False
 189   where amapM f = sequence . amap' f
 190
 191 amap' f (Array i0 i arr#) = map (\(I# i#) -> case indexArray# arr# i# of
 192                                    (# e #) -> f e)
 193                                 [0 .. i - i0]
 194
 195 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
 196 {-
 197 unsafeDeepSeq :: a -> b -> b
 198 unsafeDeepSeq = unsafeDeepSeq1 2
 199  where unsafeDeepSeq1 0 a b = seq a $! b
 200        unsafeDeepSeq1 i a b                -- 1st case avoids infinite loops for non reducible thunks
 201         | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
 202      -- | unsafePerformIO (isFullyEvaluated a) = b
 203         | otherwise = case unsafePerformIO (getClosureData a) of
 204                         closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
 205         where tipe = unsafePerformIO (getClosureType a)
 206 -}
 207 isPointed :: Type -> Bool
 208 isPointed t | Just (t, _) <- splitTyConApp_maybe t = not$ isUnliftedTypeKind (tyConKind t)
 209 isPointed _ = True
 210
 211 #define MKDECODER(offset,cons,builder) (offset, show$ cons (builder addr 0#))
 212
 213 extractUnboxed  :: [Type] -> ByteArray# -> [String]
 214 extractUnboxed tt ba = helper tt (byteArrayContents# ba)
 215    where helper :: [Type] -> Addr# -> [String]
 216          helper (t:tt) addr
 217           | Just ( tycon,_) <- splitTyConApp_maybe t
 218           =  let (offset, txt) = decode tycon addr
 219                  (I# word_offset)   = offset*wORD_SIZE
 220              in txt : helper tt (plusAddr# addr word_offset)
 221           | otherwise
 222           = -- ["extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)]
 223             panic$ "extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)
 224          helper [] addr = []
 225          decode :: TyCon -> Addr# -> (Int, String)
 226          decode t addr
 227            | t == charPrimTyCon   = MKDECODER(1,C#,indexCharOffAddr#)
 228            | t == intPrimTyCon    = MKDECODER(1,I#,indexIntOffAddr#)
 229            | t == wordPrimTyCon   = MKDECODER(1,W#,indexWordOffAddr#)
 230            | t == floatPrimTyCon  = MKDECODER(1,F#,indexFloatOffAddr#)
 231            | t == doublePrimTyCon = MKDECODER(2,D#,indexDoubleOffAddr#)
 232            | t == int32PrimTyCon  = MKDECODER(1,I32#,indexInt32OffAddr#)
 233            | t == word32PrimTyCon = MKDECODER(1,W32#,indexWord32OffAddr#)
 234            | t == int64PrimTyCon  = MKDECODER(2,I64#,indexInt64OffAddr#)
 235            | t == word64PrimTyCon = MKDECODER(2,W64#,indexWord64OffAddr#)
 236            | t == addrPrimTyCon   = MKDECODER(1,I#,(\x off-> addr2Int# (indexAddrOffAddr# x off)))  --OPT Improve the presentation of addresses
 237            | t == stablePtrPrimTyCon  = (1, "<stablePtr>")
 238            | t == stableNamePrimTyCon = (1, "<stableName>")
 239            | t == statePrimTyCon      = (1, "<statethread>")
 240            | t == realWorldTyCon      = (1, "<realworld>")
 241            | t == threadIdPrimTyCon   = (1, "<ThreadId>")
 242            | t == weakPrimTyCon       = (1, "<Weak>")
 243            | t == arrayPrimTyCon      = (1,"<array>")
 244            | t == byteArrayPrimTyCon  = (1,"<bytearray>")
 245            | t == mutableArrayPrimTyCon = (1, "<mutableArray>")
 246            | t == mutableByteArrayPrimTyCon = (1, "<mutableByteArray>")
 247            | t == mutVarPrimTyCon= (1, "<mutVar>")
 248            | t == mVarPrimTyCon  = (1, "<mVar>")
 249            | t == tVarPrimTyCon  = (1, "<tVar>")
 250            | otherwise = (1, showSDoc (char '<' <> ppr t <> char '>'))
 251                  -- We cannot know the right offset in the otherwise case, so 1 is just a wild dangerous guess!
 252            -- TODO: Improve the offset handling in decode (make it machine dependant)
 253
 254 -----------------------------------
 255 -- * Traversals for Terms
 256 -----------------------------------
 257
 258 data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a
 259                            , fPrim :: Type -> String -> a
 260                            , fSuspension :: ClosureType -> Maybe Type -> HValue -> 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 ----------------------------------
 282 -- Pretty printing of terms
 283 ----------------------------------
 284
 285 app_prec::Int
 286 app_prec = 10
 287
 288 pprTerm :: Int -> Term -> SDoc
 289 pprTerm p Term{dc=dc, subTerms=tt}
 290 {-  | dataConIsInfix dc, (t1:t2:tt') <- tt
 291   = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2)
 292     <+> hsep (map (pprTerm1 True) tt)
 293 -}
 294   | null tt   = ppr dc
 295   | otherwise = cparen (p >= app_prec)
 296                        (ppr dc <+> sep (map (pprTerm app_prec) tt))
 297
 298   where fixity   = undefined
 299
 300 pprTerm _ t = pprTerm1 t
 301
 302 pprTerm1 Prim{value=value} = text value
 303 pprTerm1 t@Term{} = pprTerm 0 t
 304 pprTerm1 Suspension{bound_to=Nothing} =  char '_' -- <> ppr ct <> char '_'
 305 pprTerm1 Suspension{mb_ty=Just ty, bound_to=Just n}
 306   | Just _ <- splitFunTy_maybe ty = ptext SLIT("<function>")
 307   | otherwise = parens$ ppr n <> text "::" <> ppr ty
 308
 309
 310 cPprTerm :: forall m. Monad m => ((Int->Term->m SDoc)->[Int->Term->m (Maybe SDoc)]) -> Term -> m SDoc
 311 cPprTerm custom = go 0 where
 312   go prec t@Term{subTerms=tt, dc=dc} = do
 313     let mb_customDocs = map (($t) . ($prec)) (custom go) :: [m (Maybe SDoc)]
 314     first_success <- firstJustM mb_customDocs
 315     case first_success of
 316       Just doc -> return$ cparen (prec>app_prec+1) doc
 317 --    | dataConIsInfix dc, (t1:t2:tt') <- tt =
 318       Nothing  -> do pprSubterms <- mapM (go (app_prec+1)) tt
 319                      return$ cparen (prec >= app_prec)
 320                                     (ppr dc <+> sep pprSubterms)
 321   go _ t = return$ pprTerm1 t
 322   firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
 323   firstJustM [] = return Nothing
 324
 325 cPprTermBase :: Monad m => (Int->Term-> m SDoc)->[Int->Term->m (Maybe SDoc)]
 326 cPprTermBase pprP =
 327   [
 328     ifTerm isTupleDC            (\_ -> liftM (parens . hcat . punctuate comma)
 329                                  . mapM (pprP (-1)) . subTerms)
 330   , ifTerm (isDC consDataCon)   (\ p Term{subTerms=[h,t]} -> doList p h t)
 331   , ifTerm (isDC intDataCon)    (coerceShow$ \(a::Int)->a)
 332   , ifTerm (isDC charDataCon)   (coerceShow$ \(a::Char)->a)
 333 --  , ifTerm (isDC wordDataCon) (coerceShow$ \(a::Word)->a)
 334   , ifTerm (isDC floatDataCon)  (coerceShow$ \(a::Float)->a)
 335   , ifTerm (isDC doubleDataCon) (coerceShow$ \(a::Double)->a)
 336   , ifTerm isIntegerDC          (coerceShow$ \(a::Integer)->a)
 337   ]
 338      where ifTerm pred f p t = if pred t then liftM Just (f p t) else return Nothing
 339            isIntegerDC Term{dc=dc} =
 340               dataConName dc `elem` [ smallIntegerDataConName
 341                                     , largeIntegerDataConName]
 342            isTupleDC Term{dc=dc} = dc `elem` snd (unzip (elems boxedTupleArr))
 343            isDC a_dc Term{dc=dc} = a_dc == dc
 344            coerceShow f _ = return . text . show . f . unsafeCoerce# . val
 345            --TODO pprinting of list terms is not lazy
 346            doList p h t = do
 347                let elems = h : getListTerms t
 348                    isConsLast = termType(last elems) /= termType h
 349                print_elems <- mapM (pprP 5) elems
 350                return$ if isConsLast
 351                      then cparen (p >= 5) . hsep . punctuate (space<>colon)
 352                            $ print_elems
 353                      else brackets (hcat$ punctuate comma print_elems)
 354
 355                 where Just a /= Just b = not (a `coreEqType` b)
 356                       _      /=   _    = True
 357                       getListTerms Term{subTerms=[h,t]} = h : getListTerms t
 358                       getListTerms t@Term{subTerms=[]}  = []
 359                       getListTerms t@Suspension{}       = [t]
 360                       getListTerms t = pprPanic "getListTerms" (ppr t)
 361
 362 -----------------------------------
 363 -- Type Reconstruction
 364 -----------------------------------
 365
 366 -- The Type Reconstruction monad
 367 type TR a = TcM a
 368
 369 runTR :: HscEnv -> TR Term -> IO Term
 370 runTR hsc_env c = do
 371   mb_term <- initTcPrintErrors hsc_env iNTERACTIVE (c >>= zonkTerm)
 372   case mb_term of
 373     Nothing -> panic "Can't unify"
 374     Just term -> return term
 375
 376 trIO :: IO a -> TR a
 377 trIO = liftTcM . ioToTcRn
 378
 379 addConstraint :: TcType -> TcType -> TR ()
 380 addConstraint t1 t2  = congruenceNewtypes t1 t2 >>= uncurry unifyType
 381
 382 {-
 383    A parallel fold over two Type values,
 384  compensating for missing newtypes on both sides.
 385  This is necessary because newtypes are not present
 386  in runtime, but since sometimes there is evidence
 387  available we do our best to reconstruct them.
 388    Evidence can come from DataCon signatures or
 389  from compile-time type inference.
 390    I am using the words congruence and rewriting
 391  because what we are doing here is an approximation
 392  of unification modulo a set of equations, which would
 393  come from newtype definitions. These should be the
 394  equality coercions seen in System Fc. Rewriting
 395  is performed, taking those equations as rules,
 396  before launching unification.
 397
 398    It doesn't make sense to rewrite everywhere,
 399  or we would end up with all newtypes. So we rewrite
 400  only in presence of evidence.
 401    The lhs comes from the heap structure of ptrs,nptrs.
 402    The rhs comes from a DataCon type signature.
 403  Rewriting in the rhs is restricted to the result type.
 404
 405    Note that it is very tricky to make this 'rewriting'
 406  work with the unification implemented by TcM, where
 407  substitutions are 'inlined'. The order in which
 408  constraints are unified is vital for this (or I am
 409  using TcM wrongly).
 410 -}
 411 congruenceNewtypes ::  TcType -> TcType -> TcM (TcType,TcType)
 412 congruenceNewtypes = go True
 413   where
 414    go rewriteRHS lhs rhs
 415  -- TyVar lhs inductive case
 416     | Just tv <- getTyVar_maybe lhs
 417     = recoverM (return (lhs,rhs)) $ do
 418          Indirect ty_v <- readMetaTyVar tv
 419          (lhs', rhs') <- go rewriteRHS ty_v rhs
 420          writeMutVar (metaTvRef tv) (Indirect lhs')
 421          return (lhs, rhs')
 422  -- TyVar rhs inductive case
 423     | Just tv <- getTyVar_maybe rhs
 424     = recoverM (return (lhs,rhs)) $ do
 425          Indirect ty_v <- readMetaTyVar tv
 426          (lhs', rhs') <- go rewriteRHS lhs ty_v
 427          writeMutVar (metaTvRef tv) (Indirect rhs')
 428          return (lhs', rhs)
 429 -- FunTy inductive case
 430     | Just (l1,l2) <- splitFunTy_maybe lhs
 431     , Just (r1,r2) <- splitFunTy_maybe rhs
 432     = do (l2',r2') <- go True l2 r2
 433          (l1',r1') <- go False l1 r1
 434          return (mkFunTy l1' l2', mkFunTy r1' r2')
 435 -- TyconApp Inductive case; this is the interesting bit.
 436     | Just (tycon_l, args_l) <- splitNewTyConApp_maybe lhs
 437     , Just (tycon_r, args_r) <- splitNewTyConApp_maybe rhs = do
 438
 439       let (tycon_l',args_l') = if isNewTyCon tycon_r && not(isNewTyCon tycon_l)
 440                                 then (tycon_r, rewrite tycon_r lhs)
 441                                 else (tycon_l, args_l)
 442           (tycon_r',args_r') = if rewriteRHS && isNewTyCon tycon_l && not(isNewTyCon tycon_r)
 443                                 then (tycon_l, rewrite tycon_l rhs)
 444                                 else (tycon_r, args_r)
 445       (args_l'', args_r'') <- unzip `liftM` zipWithM (go rewriteRHS) args_l' args_r'
 446       return (mkTyConApp tycon_l' args_l'', mkTyConApp tycon_r' args_r'')
 447
 448     | otherwise = return (lhs,rhs)
 449
 450     where rewrite newtyped_tc lame_tipe
 451            | (tvs, tipe) <- newTyConRep newtyped_tc
 452            = case tcUnifyTys (const BindMe) [tipe] [lame_tipe] of
 453                Just subst -> substTys subst (map mkTyVarTy tvs)
 454                otherwise  -> panic "congruenceNewtypes: Can't unify a newtype"
 455
 456 newVar :: Kind -> TR TcTyVar
 457 newVar = liftTcM . newFlexiTyVar
 458
 459 liftTcM = id
 460
 461 -- | Returns the instantiated type scheme ty', and the substitution sigma
 462 --   such that sigma(ty') = ty
 463 instScheme :: Type -> TR (TcType, TvSubst)
 464 instScheme ty | (tvs, rho) <- tcSplitForAllTys ty = liftTcM$ do
 465    (tvs',theta,ty') <- tcInstType (mapM tcInstTyVar) ty
 466    return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
 467
 468 cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
 469 cvObtainTerm hsc_env force mb_ty a = do
 470    -- Obtain the term and tidy the type before returning it
 471    term <- cvObtainTerm1 hsc_env force mb_ty a
 472    return $ tidyTypes term
 473    where
 474          tidyTypes = foldTerm idTermFold {
 475             fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt,
 476             fSuspension = \ct mb_ty hval n ->
 477                           Suspension ct (fmap tidy mb_ty) hval n
 478             }
 479          tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv ty) ty
 480          tidyVarEnv ty = mkVarEnv$
 481                          [ (v, setTyVarName v (tyVarName tv))
 482                            | (tv,v) <- zip alphaTyVars vars]
 483              where vars = varSetElems$ tyVarsOfType ty
 484
 485 cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
 486 cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
 487    tv <- liftM mkTyVarTy (newVar argTypeKind)
 488    case mb_ty of
 489      Nothing -> go tv tv hval
 490      Just ty | isMonomorphic ty -> go ty ty hval
 491      Just ty -> do
 492               (ty',rev_subst) <- instScheme (sigmaType$ fromJust mb_ty)
 493               addConstraint tv ty'
 494               term <- go tv tv hval
 495               --restore original Tyvars
 496               return$ flip foldTerm term idTermFold {
 497                 fTerm = \ty dc hval tt -> Term (substTy rev_subst ty) dc hval tt,
 498                 fSuspension = \ct mb_ty hval n ->
 499                           Suspension ct (substTy rev_subst `fmap` mb_ty) hval n}
 500     where
 501   go tv ty a = do
 502     let monomorphic = not(isTyVarTy tv)   -- This is a convention. The ancestor tests for
 503                                          -- monomorphism and passes a type instead of a tv
 504     clos <- trIO $ getClosureData a
 505     case tipe clos of
 506 -- Thunks we may want to force
 507       Thunk _ | force -> seq a $ go tv ty a
 508 -- We always follow indirections
 509       Indirection _ -> go tv ty $! (ptrs clos ! 0)
 510  -- The interesting case
 511       Constr -> do
 512         m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
 513         case m_dc of
 514           Nothing -> panic "Can't find the DataCon for a term"
 515           Just dc -> do
 516             let extra_args = length(dataConRepArgTys dc) - length(dataConOrigArgTys dc)
 517                 subTtypes  = matchSubTypes dc ty
 518                 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
 519             subTermTvs <- sequence
 520                  [ if isMonomorphic t then return t else (mkTyVarTy `fmap` newVar k)
 521                    | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
 522             -- It is vital for newtype reconstruction that the unification step is done
 523             --     right here, _before_ the subterms are RTTI reconstructed.
 524             when (not monomorphic) $ do
 525                   let myType = mkFunTys (reOrderTerms subTermTvs subTtypesNP subTtypes) tv
 526                   instScheme(dataConRepType dc) >>= addConstraint myType . fst
 527             subTermsP <- sequence $ drop extra_args -- all extra arguments are pointed
 528                   [ appArr (go tv t) (ptrs clos) i
 529                    | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
 530             let unboxeds   = extractUnboxed subTtypesNP (nonPtrs clos)
 531                 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
 532                 subTerms   = reOrderTerms subTermsP subTermsNP (drop extra_args subTtypes)
 533             return (Term tv dc a subTerms)
 534 -- The otherwise case: can be a Thunk,AP,PAP,etc.
 535       otherwise ->
 536          return (Suspension (tipe clos) (Just tv) a Nothing)
 537
 538 -- Access the array of pointers and recurse down. Needs to be done with
 539 -- care of no introducing a thunk! or go will fail to do its job
 540   appArr f arr (I# i#) = case arr of
 541                  (Array _ _ ptrs#) -> case indexArray# ptrs# i# of
 542                        (# e #) -> f e
 543
 544   matchSubTypes dc ty
 545     | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
 546     , null (dataConExTyVars dc)  --TODO Handle the case of extra existential tyvars
 547     = dataConInstArgTys dc ty_args
 548
 549     | otherwise = dataConRepArgTys dc
 550
 551 -- This is used to put together pointed and nonpointed subterms in the
 552 --  correct order.
 553   reOrderTerms _ _ [] = []
 554   reOrderTerms pointed unpointed (ty:tys)
 555    | isPointed ty = ASSERT2(not(null pointed)
 556                            , ptext SLIT("reOrderTerms") $$ (ppr pointed $$ ppr unpointed))
 557                     head pointed : reOrderTerms (tail pointed) unpointed tys
 558    | otherwise    = ASSERT2(not(null unpointed)
 559                            , ptext SLIT("reOrderTerms") $$ (ppr pointed $$ ppr unpointed))
 560                     head unpointed : reOrderTerms pointed (tail unpointed) tys
 561
 562 isMonomorphic = isEmptyVarSet . tyVarsOfType
 563
 564 zonkTerm :: Term -> TcM Term
 565 zonkTerm = foldTerm idTermFoldM {
 566               fTerm = \ty dc v tt -> sequence tt      >>= \tt ->
 567                                      zonkTcType ty    >>= \ty' ->
 568                                      return (Term ty' dc v tt)
 569              ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
 570                                           return (Suspension ct ty v b)}
 571
 572
 573 -- Is this defined elsewhere?
 574 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
 575 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
 576
 577 {-
 578 Example of Type Reconstruction
 579 --------------------------------
 580 Suppose we have an existential type such as
 581
 582 data Opaque = forall a. Opaque a
 583
 584 And we have a term built as:
 585
 586 t = Opaque (map Just [[1,1],[2,2]])
 587
 588 The type of t as far as the typechecker goes is t :: Opaque
 589 If we seq the head of t, we obtain:
 590
 591 t - O (_1::a)
 592
 593 seq _1 ()
 594
 595 t - O ( (_3::b) : (_4::[b]) )
 596
 597 seq _3 ()
 598
 599 t - O ( (Just (_5::c)) : (_4::[b]) )
 600
 601 At this point, we know that b = (Maybe c)
 602
 603 seq _5 ()
 604
 605 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[b]) )
 606
 607 At this point, we know that c = [d]
 608
 609 seq _6 ()
 610
 611 t - O ( (Just (1 : (_7::[d]) )) : (_4::[b]) )
 612
 613 At this point, we know that d = Integer
 614
 615 The fully reconstructed expressions, with propagation, would be:
 616
 617 t - O ( (Just (_5::c)) : (_4::[Maybe c]) )
 618 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[Maybe [d]]) )
 619 t - O ( (Just (1 : (_7::[Integer]) )) : (_4::[Maybe [Integer]]) )
 620
 621
 622 For reference, the type of the thing inside the opaque is
 623 map Just [[1,1],[2,2]] :: [Maybe [Integer]]
 624
 625 NOTE: (Num t) contexts have been manually replaced by Integer for clarity
 626 -}