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      ClosureType(..),
  14      getClosureData,     -- :: a -> IO Closure
  15      Closure ( tipe, infoPtr, ptrs, nonPtrs ),
  16      isConstr,           -- :: ClosureType -> Bool
  17      isIndirection,      -- :: ClosureType -> Bool
  18
  19      Term(..),
  20      pprTerm,
  21      cPprTerm,
  22      cPprTermBase,
  23      termType,
  24      foldTerm,
  25      TermFold(..),
  26      idTermFold,
  27      idTermFoldM,
  28      isFullyEvaluated,
  29      isPointed,
  30      isFullyEvaluatedTerm,
  31 --     unsafeDeepSeq,
  32  ) where
  33
  34 #include "HsVersions.h"
  35
  36 import ByteCodeItbls    ( StgInfoTable )
  37 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
  38 import ByteCodeLink     ( HValue )
  39 import HscTypes         ( HscEnv )
  40
  41 import DataCon
  42 import Type
  43 import TcRnMonad        ( TcM, initTcPrintErrors, ioToTcRn, recoverM, writeMutVar )
  44 import TcType
  45 import TcMType
  46 import TcUnify
  47 import TcGadt
  48 import TyCon
  49 import Var
  50 import Name
  51 import VarEnv
  52 import OccName
  53 import VarSet
  54 import {-#SOURCE#-} TcRnDriver ( tcRnRecoverDataCon )
  55
  56 import TysPrim
  57 import PrelNames
  58 import TysWiredIn
  59
  60 import Constants        ( wORD_SIZE )
  61 import Outputable
  62 import Maybes
  63 import Panic
  64 import FiniteMap
  65
  66 import GHC.Arr          ( Array(..) )
  67 import GHC.Ptr          ( Ptr(..), castPtr )
  68 import GHC.Exts
  69 import GHC.Int          ( Int32(..),  Int64(..) )
  70 import GHC.Word         ( Word32(..), Word64(..) )
  71
  72 import Control.Monad
  73 import Data.Maybe
  74 import Data.Array.Base
  75 import Data.List        ( partition )
  76 import Foreign.Storable
  77
  78 import IO
  79
  80 ---------------------------------------------
  81 -- * A representation of semi evaluated Terms
  82 ---------------------------------------------
  83 {-
  84   A few examples in this representation:
  85
  86   > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
  87
  88   > (('a',_,_),_,('b',_,_)) =
  89       Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
  90           [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
  91           , Suspension
  92           , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
  93 -}
  94
  95 data Term = Term { ty        :: Type
  96                  , dc        :: DataCon
  97                  , val       :: HValue
  98                  , subTerms  :: [Term] }
  99
 100           | Prim { ty        :: Type
 101                  , value     :: String }
 102
 103           | Suspension { ctype    :: ClosureType
 104                        , mb_ty    :: Maybe Type
 105                        , val      :: HValue
 106                        , bound_to :: Maybe Name   -- Useful for printing
 107                        }
 108
 109 isTerm Term{} = True
 110 isTerm   _    = False
 111 isSuspension Suspension{} = True
 112 isSuspension      _       = False
 113 isPrim Prim{} = True
 114 isPrim   _    = False
 115
 116 termType t@(Suspension {}) = mb_ty t
 117 termType t = Just$ ty t
 118
 119 isFullyEvaluatedTerm :: Term -> Bool
 120 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
 121 isFullyEvaluatedTerm Suspension {}      = False
 122 isFullyEvaluatedTerm Prim {}            = True
 123
 124 instance Outputable (Term) where
 125  ppr = head . cPprTerm cPprTermBase
 126
 127 -------------------------------------------------------------------------
 128 -- Runtime Closure Datatype and functions for retrieving closure related stuff
 129 -------------------------------------------------------------------------
 130 data ClosureType = Constr
 131                  | Fun
 132                  | Thunk Int
 133                  | ThunkSelector
 134                  | Blackhole
 135                  | AP
 136                  | PAP
 137                  | Indirection Int
 138                  | Other Int
 139  deriving (Show, Eq)
 140
 141 data Closure = Closure { tipe         :: ClosureType
 142                        , infoPtr      :: Ptr ()
 143                        , infoTable    :: StgInfoTable
 144                        , ptrs         :: Array Int HValue
 145                        , nonPtrs      :: ByteArray#
 146                        }
 147
 148 instance Outputable ClosureType where
 149   ppr = text . show
 150
 151 #include "../includes/ClosureTypes.h"
 152
 153 aP_CODE = AP
 154 pAP_CODE = PAP
 155 #undef AP
 156 #undef PAP
 157
 158 getClosureData :: a -> IO Closure
 159 getClosureData a =
 160    case unpackClosure# a of
 161      (# iptr, ptrs, nptrs #) -> do
 162            itbl <- peek (Ptr iptr)
 163            let tipe = readCType (BCI.tipe itbl)
 164                elems = BCI.ptrs itbl
 165                ptrsList = Array 0 (fromIntegral$ elems) ptrs
 166            ptrsList `seq` return (Closure tipe (Ptr iptr) itbl ptrsList nptrs)
 167
 168 readCType :: Integral a => a -> ClosureType
 169 readCType i
 170  | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
 171  | i >= FUN    && i <= FUN_STATIC          = Fun
 172  | i >= THUNK  && i < THUNK_SELECTOR       = Thunk (fromIntegral i)
 173  | i == THUNK_SELECTOR                     = ThunkSelector
 174  | i == BLACKHOLE                          = Blackhole
 175  | i >= IND    && i <= IND_STATIC          = Indirection (fromIntegral i)
 176  | fromIntegral i == aP_CODE               = AP
 177  | fromIntegral i == pAP_CODE              = PAP
 178  | otherwise                               = Other (fromIntegral i)
 179
 180 isConstr, isIndirection :: ClosureType -> Bool
 181 isConstr Constr = True
 182 isConstr    _   = False
 183
 184 isIndirection (Indirection _) = True
 185 --isIndirection ThunkSelector = True
 186 isIndirection _ = 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 instScheme :: Type -> TR TcType
 468 instScheme ty = liftTcM$ liftM trd (tcInstType (liftM fst3 . tcInstTyVars) ty)
 469     where fst3 (x,y,z) = x
 470           trd  (x,y,z) = z
 471
 472 cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
 473 cvObtainTerm hsc_env force mb_ty a = do
 474    -- Obtain the term and tidy the type before returning it
 475    term <- cvObtainTerm1 hsc_env force mb_ty a
 476    return $ tidyTypes term
 477    where
 478          tidyTypes = foldTerm idTermFold {
 479             fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt,
 480             fSuspension = \ct mb_ty hval n ->
 481                           Suspension ct (fmap tidy mb_ty) hval n
 482             }
 483          tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv ty) ty
 484          tidyVarEnv ty = mkVarEnv$
 485                          [ (v, setTyVarName v (tyVarName tv))
 486                            | (tv,v) <- zip alphaTyVars vars]
 487              where vars = varSetElems$ tyVarsOfType ty
 488
 489 cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
 490 cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
 491    tv <- case (isMonomorphic `fmap` mb_ty) of
 492           Just True -> return (fromJust mb_ty)
 493           _         -> do
 494             tv_ <- liftM mkTyVarTy (newVar argTypeKind)
 495             when (isJust mb_ty) $
 496                  instScheme (sigmaType$ fromJust mb_ty) >>= addConstraint tv_
 497             return tv_
 498    go tv (fromMaybe tv mb_ty) hval
 499     where
 500   go tv ty a = do
 501     let monomorphic = not(isTyVarTy tv)   -- This is a convention. The ancestor tests for
 502                                          -- monomorphism and passes a type instead of a tv
 503     clos <- trIO $ getClosureData a
 504     case tipe clos of
 505 -- Thunks we may want to force
 506       Thunk _ | force -> seq a $ go tv ty a
 507 -- We always follow indirections
 508       Indirection _ -> go tv ty $! (ptrs clos ! 0)
 509  -- The interesting case
 510       Constr -> do
 511         m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
 512         case m_dc of
 513           Nothing -> panic "Can't find the DataCon for a term"
 514           Just dc -> do
 515             let extra_args = length(dataConRepArgTys dc) - length(dataConOrigArgTys dc)
 516                 subTtypes  = matchSubTypes dc ty
 517                 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
 518             subTermTvs <- sequence
 519                  [ if isMonomorphic t then return t else (mkTyVarTy `fmap` newVar k)
 520                    | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
 521             -- It is vital for newtype reconstruction that the unification step is done
 522             --     right here, _before_ the subterms are RTTI reconstructed.
 523             when (not monomorphic) $ do
 524                   let myType = mkFunTys (reOrderTerms subTermTvs subTtypesNP subTtypes) tv
 525                   instScheme(dataConRepType dc) >>= addConstraint myType
 526             subTermsP <- sequence $ drop extra_args -- all extra arguments are pointed
 527                   [ appArr (go tv t) (ptrs clos) i
 528                    | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
 529             let unboxeds   = extractUnboxed subTtypesNP (nonPtrs clos)
 530                 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
 531                 subTerms   = reOrderTerms subTermsP subTermsNP (drop extra_args subTtypes)
 532             return (Term tv dc a subTerms)
 533 -- The otherwise case: can be a Thunk,AP,PAP,etc.
 534       otherwise ->
 535          return (Suspension (tipe clos) (Just tv) a Nothing)
 536
 537 -- Access the array of pointers and recurse down. Needs to be done with
 538 -- care of no introducing a thunk! or go will fail to do its job
 539   appArr f arr (I# i#) = case arr of
 540                  (Array _ _ ptrs#) -> case indexArray# ptrs# i# of
 541                        (# e #) -> f e
 542
 543   matchSubTypes dc ty
 544     | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
 545     , null (dataConExTyVars dc)  --TODO Handle the case of extra existential tyvars
 546     = dataConInstArgTys dc ty_args
 547
 548     | otherwise = dataConRepArgTys dc
 549
 550 -- This is used to put together pointed and nonpointed subterms in the
 551 --  correct order.
 552   reOrderTerms _ _ [] = []
 553   reOrderTerms pointed unpointed (ty:tys)
 554    | isPointed ty = ASSERT2(not(null pointed)
 555                            , ptext SLIT("reOrderTerms") $$ (ppr pointed $$ ppr unpointed))
 556                     head pointed : reOrderTerms (tail pointed) unpointed tys
 557    | otherwise    = ASSERT2(not(null unpointed)
 558                            , ptext SLIT("reOrderTerms") $$ (ppr pointed $$ ppr unpointed))
 559                     head unpointed : reOrderTerms pointed (tail unpointed) tys
 560
 561 isMonomorphic = isEmptyVarSet . tyVarsOfType
 562
 563 zonkTerm :: Term -> TcM Term
 564 zonkTerm = foldTerm idTermFoldM {
 565               fTerm = \ty dc v tt -> sequence tt      >>= \tt ->
 566                                      zonkTcType ty    >>= \ty' ->
 567                                      return (Term ty' dc v tt)
 568              ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
 569                                           return (Suspension ct ty v b)}
 570
 571
 572 -- Is this defined elsewhere?
 573 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
 574 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
 575
 576 {-
 577 Example of Type Reconstruction
 578 --------------------------------
 579 Suppose we have an existential type such as
 580
 581 data Opaque = forall a. Opaque a
 582
 583 And we have a term built as:
 584
 585 t = Opaque (map Just [[1,1],[2,2]])
 586
 587 The type of t as far as the typechecker goes is t :: Opaque
 588 If we seq the head of t, we obtain:
 589
 590 t - O (_1::a)
 591
 592 seq _1 ()
 593
 594 t - O ( (_3::b) : (_4::[b]) )
 595
 596 seq _3 ()
 597
 598 t - O ( (Just (_5::c)) : (_4::[b]) )
 599
 600 At this point, we know that b = (Maybe c)
 601
 602 seq _5 ()
 603
 604 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[b]) )
 605
 606 At this point, we know that c = [d]
 607
 608 seq _6 ()
 609
 610 t - O ( (Just (1 : (_7::[d]) )) : (_4::[b]) )
 611
 612 At this point, we know that d = Integer
 613
 614 The fully reconstructed expressions, with propagation, would be:
 615
 616 t - O ( (Just (_5::c)) : (_4::[Maybe c]) )
 617 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[Maybe [d]]) )
 618 t - O ( (Just (1 : (_7::[Integer]) )) : (_4::[Maybe [Integer]]) )
 619
 620
 621 For reference, the type of the thing inside the opaque is
 622 map Just [[1,1],[2,2]] :: [Maybe [Integer]]
 623
 624 NOTE: (Num t) contexts have been manually replaced by Integer for clarity
 625 -}