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