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