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
  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
  66 import Control.Monad
  67 import Data.Maybe
  68 import Data.Array.Base
  69 import Data.List        ( partition, nub )
  70 import Foreign
  71
  72 ---------------------------------------------
  73 -- * A representation of semi evaluated Terms
  74 ---------------------------------------------
  75 {-
  76   A few examples in this representation:
  77
  78   > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
  79
  80   > (('a',_,_),_,('b',_,_)) =
  81       Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
  82           [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
  83           , Suspension
  84           , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
  85 -}
  86
  87 data Term = Term { ty        :: Type
  88                  , dc        :: DataCon
  89                  , val       :: HValue
  90                  , subTerms  :: [Term] }
  91
  92           | Prim { ty        :: Type
  93                  , value     :: [Word] }
  94
  95           | Suspension { ctype    :: ClosureType
  96                        , mb_ty    :: Maybe Type
  97                        , val      :: HValue
  98                        , bound_to :: Maybe Name   -- Useful for printing
  99                        }
 100
 101 isTerm Term{} = True
 102 isTerm   _    = False
 103 isSuspension Suspension{} = True
 104 isSuspension      _       = False
 105 isPrim Prim{} = True
 106 isPrim   _    = False
 107
 108 termType t@(Suspension {}) = mb_ty t
 109 termType t = Just$ ty t
 110
 111 isFullyEvaluatedTerm :: Term -> Bool
 112 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
 113 isFullyEvaluatedTerm Suspension {}      = False
 114 isFullyEvaluatedTerm Prim {}            = True
 115
 116 instance Outputable (Term) where
 117  ppr = head . cPprTerm cPprTermBase
 118
 119 -------------------------------------------------------------------------
 120 -- Runtime Closure Datatype and functions for retrieving closure related stuff
 121 -------------------------------------------------------------------------
 122 data ClosureType = Constr
 123                  | Fun
 124                  | Thunk Int
 125                  | ThunkSelector
 126                  | Blackhole
 127                  | AP
 128                  | PAP
 129                  | Indirection Int
 130                  | Other Int
 131  deriving (Show, Eq)
 132
 133 data Closure = Closure { tipe         :: ClosureType
 134                        , infoPtr      :: Ptr ()
 135                        , infoTable    :: StgInfoTable
 136                        , ptrs         :: Array Int HValue
 137                        , nonPtrs      :: [Word]
 138                        }
 139
 140 instance Outputable ClosureType where
 141   ppr = text . show
 142
 143 #include "../includes/ClosureTypes.h"
 144
 145 aP_CODE = AP
 146 pAP_CODE = PAP
 147 #undef AP
 148 #undef PAP
 149
 150 getClosureData :: a -> IO Closure
 151 getClosureData a =
 152    case unpackClosure# a of
 153      (# iptr, ptrs, nptrs #) -> do
 154            itbl <- peek (Ptr iptr)
 155            let tipe = readCType (BCI.tipe itbl)
 156                elems = BCI.ptrs itbl
 157                ptrsList = Array 0 (fromIntegral$ elems) ptrs
 158                nptrs_data = [W# (indexWordArray# nptrs i)
 159                               | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
 160            ptrsList `seq` return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
 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 extractUnboxed  :: [Type] -> Closure -> [[Word]]
 218 extractUnboxed tt clos = go tt (nonPtrs clos)
 219    where sizeofType t
 220            | Just (tycon,_) <- splitTyConApp_maybe t
 221            = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
 222            | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
 223          go [] _ = []
 224          go (t:tt) xx
 225            | (x, rest) <- splitAt (sizeofType t `div` wORD_SIZE) xx
 226            = x : go tt rest
 227
 228 sizeofTyCon = sizeofPrimRep . tyConPrimRep
 229
 230 -----------------------------------
 231 -- * Traversals for Terms
 232 -----------------------------------
 233
 234 data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a
 235                            , fPrim :: Type -> [Word] -> a
 236                            , fSuspension :: ClosureType -> Maybe Type -> HValue -> Maybe Name -> a
 237                            }
 238
 239 foldTerm :: TermFold a -> Term -> a
 240 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
 241 foldTerm tf (Prim ty    v   ) = fPrim tf ty v
 242 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
 243
 244 idTermFold :: TermFold Term
 245 idTermFold = TermFold {
 246               fTerm = Term,
 247               fPrim = Prim,
 248               fSuspension = Suspension
 249                       }
 250 idTermFoldM :: Monad m => TermFold (m Term)
 251 idTermFoldM = TermFold {
 252               fTerm       = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
 253               fPrim       = (return.). Prim,
 254               fSuspension = (((return.).).). Suspension
 255                        }
 256
 257 mapTermType f = foldTerm idTermFold {
 258           fTerm       = \ty dc hval tt -> Term (f ty) dc hval tt,
 259           fSuspension = \ct mb_ty hval n ->
 260                           Suspension ct (fmap f mb_ty) hval n }
 261
 262 termTyVars = foldTerm TermFold {
 263             fTerm       = \ty _ _ tt   ->
 264                           tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
 265             fSuspension = \_ mb_ty _ _ ->
 266                           maybe emptyVarEnv tyVarsOfType mb_ty,
 267             fPrim       = \ _ _ -> emptyVarEnv }
 268     where concatVarEnv = foldr plusVarEnv emptyVarEnv
 269 ----------------------------------
 270 -- Pretty printing of terms
 271 ----------------------------------
 272
 273 app_prec::Int
 274 app_prec = 10
 275
 276 pprTerm :: Int -> Term -> SDoc
 277 pprTerm p Term{dc=dc, subTerms=tt}
 278 {-  | dataConIsInfix dc, (t1:t2:tt') <- tt
 279   = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2)
 280     <+> hsep (map (pprTerm1 True) tt)
 281 -}
 282   | null tt   = ppr dc
 283   | otherwise = cparen (p >= app_prec)
 284                        (ppr dc <+> sep (map (pprTerm app_prec) tt))
 285
 286   where fixity   = undefined
 287
 288 pprTerm _ t = pprTerm1 t
 289
 290 pprTerm1 Prim{value=words, ty=ty} = text$ repPrim (tyConAppTyCon ty) words
 291 pprTerm1 t@Term{} = pprTerm 0 t
 292 pprTerm1 Suspension{bound_to=Nothing} =  char '_' -- <> ppr ct <> char '_'
 293 pprTerm1 Suspension{mb_ty=Just ty, bound_to=Just n}
 294   | Just _ <- splitFunTy_maybe ty = ptext SLIT("<function>")
 295   | otherwise = parens$ ppr n <> text "::" <> ppr ty
 296
 297
 298 cPprTerm :: forall m. Monad m => ((Int->Term->m SDoc)->[Int->Term->m (Maybe SDoc)]) -> Term -> m SDoc
 299 cPprTerm custom = go 0 where
 300   go prec t@Term{subTerms=tt, dc=dc} = do
 301     let mb_customDocs = map (($t) . ($prec)) (custom go) :: [m (Maybe SDoc)]
 302     first_success <- firstJustM mb_customDocs
 303     case first_success of
 304       Just doc -> return$ cparen (prec>app_prec+1) doc
 305 --    | dataConIsInfix dc, (t1:t2:tt') <- tt =
 306       Nothing  -> do pprSubterms <- mapM (go (app_prec+1)) tt
 307                      return$ cparen (prec >= app_prec)
 308                                     (ppr dc <+> sep pprSubterms)
 309   go _ t = return$ pprTerm1 t
 310   firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
 311   firstJustM [] = return Nothing
 312
 313 cPprTermBase :: Monad m => (Int->Term-> m SDoc)->[Int->Term->m (Maybe SDoc)]
 314 cPprTermBase pprP =
 315   [
 316     ifTerm isTupleDC            (\_ -> liftM (parens . hcat . punctuate comma)
 317                                  . mapM (pprP (-1)) . subTerms)
 318   , ifTerm (isDC consDataCon)   (\ p Term{subTerms=[h,t]} -> doList p h t)
 319   , ifTerm (isDC intDataCon)    (coerceShow$ \(a::Int)->a)
 320   , ifTerm (isDC charDataCon)   (coerceShow$ \(a::Char)->a)
 321 --  , ifTerm (isDC wordDataCon) (coerceShow$ \(a::Word)->a)
 322   , ifTerm (isDC floatDataCon)  (coerceShow$ \(a::Float)->a)
 323   , ifTerm (isDC doubleDataCon) (coerceShow$ \(a::Double)->a)
 324   , ifTerm isIntegerDC          (coerceShow$ \(a::Integer)->a)
 325   ]
 326      where ifTerm pred f p t = if pred t then liftM Just (f p t) else return Nothing
 327            isIntegerDC Term{dc=dc} =
 328               dataConName dc `elem` [ smallIntegerDataConName
 329                                     , largeIntegerDataConName]
 330            isTupleDC Term{dc=dc} = dc `elem` snd (unzip (elems boxedTupleArr))
 331            isDC a_dc Term{dc=dc} = a_dc == dc
 332            coerceShow f _ = return . text . show . f . unsafeCoerce# . val
 333            --TODO pprinting of list terms is not lazy
 334            doList p h t = do
 335                let elems = h : getListTerms t
 336                    isConsLast = termType(last elems) /= termType h
 337                print_elems <- mapM (pprP 5) elems
 338                return$ if isConsLast
 339                      then cparen (p >= 5) . hsep . punctuate (space<>colon)
 340                            $ print_elems
 341                      else brackets (hcat$ punctuate comma print_elems)
 342
 343                 where Just a /= Just b = not (a `coreEqType` b)
 344                       _      /=   _    = True
 345                       getListTerms Term{subTerms=[h,t]} = h : getListTerms t
 346                       getListTerms t@Term{subTerms=[]}  = []
 347                       getListTerms t@Suspension{}       = [t]
 348                       getListTerms t = pprPanic "getListTerms" (ppr t)
 349
 350 repPrim :: TyCon -> [Word] -> String
 351 repPrim t = rep where
 352    rep x
 353     | t == charPrimTyCon   = show (build x :: Char)
 354     | t == intPrimTyCon    = show (build x :: Int)
 355     | t == wordPrimTyCon   = show (build x :: Word)
 356     | t == floatPrimTyCon  = show (build x :: Float)
 357     | t == doublePrimTyCon = show (build x :: Double)
 358     | t == int32PrimTyCon  = show (build x :: Int32)
 359     | t == word32PrimTyCon = show (build x :: Word32)
 360     | t == int64PrimTyCon  = show (build x :: Int64)
 361     | t == word64PrimTyCon = show (build x :: Word64)
 362     | t == addrPrimTyCon   = show (nullPtr `plusPtr` build x)
 363     | t == stablePtrPrimTyCon  = "<stablePtr>"
 364     | t == stableNamePrimTyCon = "<stableName>"
 365     | t == statePrimTyCon      = "<statethread>"
 366     | t == realWorldTyCon      = "<realworld>"
 367     | t == threadIdPrimTyCon   = "<ThreadId>"
 368     | t == weakPrimTyCon       = "<Weak>"
 369     | t == arrayPrimTyCon      = "<array>"
 370     | t == byteArrayPrimTyCon  = "<bytearray>"
 371     | t == mutableArrayPrimTyCon = "<mutableArray>"
 372     | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
 373     | t == mutVarPrimTyCon= "<mutVar>"
 374     | t == mVarPrimTyCon  = "<mVar>"
 375     | t == tVarPrimTyCon  = "<tVar>"
 376     | otherwise = showSDoc (char '<' <> ppr t <> char '>')
 377     where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
 378 -----------------------------------
 379 -- Type Reconstruction
 380 -----------------------------------
 381
 382 -- The Type Reconstruction monad
 383 type TR a = TcM a
 384
 385 runTR :: HscEnv -> TR Term -> IO Term
 386 runTR hsc_env c = do
 387   mb_term <- initTcPrintErrors hsc_env iNTERACTIVE c
 388   case mb_term of
 389     Nothing -> panic "Can't unify"
 390     Just term -> return term
 391
 392 trIO :: IO a -> TR a
 393 trIO = liftTcM . ioToTcRn
 394
 395 addConstraint :: TcType -> TcType -> TR ()
 396 addConstraint t1 t2  = congruenceNewtypes t1 t2 >>= uncurry unifyType
 397
 398 {-
 399    A parallel fold over two Type values,
 400  compensating for missing newtypes on both sides.
 401  This is necessary because newtypes are not present
 402  in runtime, but since sometimes there is evidence
 403  available we do our best to reconstruct them.
 404    Evidence can come from DataCon signatures or
 405  from compile-time type inference.
 406    I am using the words congruence and rewriting
 407  because what we are doing here is an approximation
 408  of unification modulo a set of equations, which would
 409  come from newtype definitions. These should be the
 410  equality coercions seen in System Fc. Rewriting
 411  is performed, taking those equations as rules,
 412  before launching unification.
 413
 414    It doesn't make sense to rewrite everywhere,
 415  or we would end up with all newtypes. So we rewrite
 416  only in presence of evidence.
 417    The lhs comes from the heap structure of ptrs,nptrs.
 418    The rhs comes from a DataCon type signature.
 419  Rewriting in the rhs is restricted to the result type.
 420
 421    Note that it is very tricky to make this 'rewriting'
 422  work with the unification implemented by TcM, where
 423  substitutions are 'inlined'. The order in which
 424  constraints are unified is vital for this (or I am
 425  using TcM wrongly).
 426 -}
 427 congruenceNewtypes ::  TcType -> TcType -> TcM (TcType,TcType)
 428 congruenceNewtypes = go True
 429   where
 430    go rewriteRHS lhs rhs
 431  -- TyVar lhs inductive case
 432     | Just tv <- getTyVar_maybe lhs
 433     = recoverM (return (lhs,rhs)) $ do
 434          Indirect ty_v <- readMetaTyVar tv
 435          (lhs', rhs') <- go rewriteRHS ty_v rhs
 436          writeMutVar (metaTvRef tv) (Indirect lhs')
 437          return (lhs, rhs')
 438  -- TyVar rhs inductive case
 439     | Just tv <- getTyVar_maybe rhs
 440     = recoverM (return (lhs,rhs)) $ do
 441          Indirect ty_v <- readMetaTyVar tv
 442          (lhs', rhs') <- go rewriteRHS lhs ty_v
 443          writeMutVar (metaTvRef tv) (Indirect rhs')
 444          return (lhs', rhs)
 445 -- FunTy inductive case
 446     | Just (l1,l2) <- splitFunTy_maybe lhs
 447     , Just (r1,r2) <- splitFunTy_maybe rhs
 448     = do (l2',r2') <- go True l2 r2
 449          (l1',r1') <- go False l1 r1
 450          return (mkFunTy l1' l2', mkFunTy r1' r2')
 451 -- TyconApp Inductive case; this is the interesting bit.
 452     | Just (tycon_l, args_l) <- splitNewTyConApp_maybe lhs
 453     , Just (tycon_r, args_r) <- splitNewTyConApp_maybe rhs = do
 454
 455       let (tycon_l',args_l') = if isNewTyCon tycon_r && not(isNewTyCon tycon_l)
 456                                 then (tycon_r, rewrite tycon_r lhs)
 457                                 else (tycon_l, args_l)
 458           (tycon_r',args_r') = if rewriteRHS && isNewTyCon tycon_l && not(isNewTyCon tycon_r)
 459                                 then (tycon_l, rewrite tycon_l rhs)
 460                                 else (tycon_r, args_r)
 461       (args_l'', args_r'') <- unzip `liftM` zipWithM (go rewriteRHS) args_l' args_r'
 462       return (mkTyConApp tycon_l' args_l'', mkTyConApp tycon_r' args_r'')
 463
 464     | otherwise = return (lhs,rhs)
 465
 466     where rewrite newtyped_tc lame_tipe
 467            | (tvs, tipe) <- newTyConRep newtyped_tc
 468            = case tcUnifyTys (const BindMe) [tipe] [lame_tipe] of
 469                Just subst -> substTys subst (map mkTyVarTy tvs)
 470                otherwise  -> panic "congruenceNewtypes: Can't unify a newtype"
 471
 472 newVar :: Kind -> TR TcTyVar
 473 newVar = liftTcM . newFlexiTyVar
 474
 475 liftTcM = id
 476
 477 -- | Returns the instantiated type scheme ty', and the substitution sigma
 478 --   such that sigma(ty') = ty
 479 instScheme :: Type -> TR (TcType, TvSubst)
 480 instScheme ty | (tvs, rho) <- tcSplitForAllTys ty = liftTcM$ do
 481    (tvs',theta,ty') <- tcInstType (mapM tcInstTyVar) ty
 482    return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
 483
 484 cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
 485 cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
 486    tv <- liftM mkTyVarTy (newVar argTypeKind)
 487    case mb_ty of
 488      Nothing -> go tv tv hval >>= zonkTerm
 489      Just ty | isMonomorphic ty -> go ty ty hval >>= zonkTerm
 490      Just ty -> do
 491               (ty',rev_subst) <- instScheme (sigmaType ty)
 492               addConstraint tv ty'
 493               term <- go tv tv hval >>= zonkTerm
 494               --restore original Tyvars
 495               return$ mapTermType (substTy rev_subst) term
 496     where
 497   go tv ty a = do
 498     let monomorphic = not(isTyVarTy tv)   -- This is a convention. The ancestor tests for
 499                                          -- monomorphism and passes a type instead of a tv
 500     clos <- trIO $ getClosureData a
 501     case tipe clos of
 502 -- Thunks we may want to force
 503 -- NB. this won't attempt to force a BLACKHOLE.  Even with :force, we never
 504 -- force blackholes, because it would almost certainly result in deadlock,
 505 -- and showing the '_' is more useful.
 506       t | isThunk t && 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 . fst
 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 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 ty | isForAllTy ty = False
 562 isMonomorphic ty = (isEmptyVarSet . tyVarsOfType) ty
 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 -}