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