compiler/ghci/RtClosureInspect.hs

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