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