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   | Just _ <- splitFunTy_maybe ty = text "<function>"
 318   | otherwise = parens$ ppr n <> text "::" <> ppr ty
 319
 320 printTerm1 p Term{dc=dc, subTerms=tt}
 321 {-  | dataConIsInfix dc, (t1:t2:tt') <- tt
 322   = parens (printTerm1 True t1 <+> ppr dc <+> printTerm1 True ppr t2)
 323     <+> hsep (map (printTerm1 True) tt)
 324 -}
 325   | null tt   = ppr dc
 326   | otherwise = parensCond (p > app_prec)
 327                      (ppr dc <+> sep (map (printTerm1 (app_prec+1)) tt))
 328
 329   where fixity   = undefined
 330
 331 printTerm1 _ t = printTerm t
 332
 333 customPrintTerm :: Monad m => ((Int->Term->m SDoc)->[Term->m (Maybe SDoc)]) -> Term -> m SDoc
 334 customPrintTerm custom = let
 335 --  go :: Monad m => Int -> Term -> m SDoc
 336   go prec t@Term{subTerms=tt, dc=dc} = do
 337     mb_customDocs <- sequence$ sequence (custom go) t  -- Inner sequence is List monad
 338     case msum mb_customDocs of        -- msum is in Maybe monad
 339       Just doc -> return$ parensCond (prec>app_prec+1) doc
 340 --    | dataConIsInfix dc, (t1:t2:tt') <- tt =
 341       Nothing  -> do pprSubterms <- mapM (go (app_prec+1)) tt
 342                      return$ parensCond (prec>app_prec+1)
 343                                         (ppr dc <+> sep pprSubterms)
 344   go _ t = return$ printTerm t
 345   in go 0
 346    where fixity = undefined
 347
 348 customPrintTermBase :: Monad m => (Int->Term-> m SDoc)->[Term->m (Maybe SDoc)]
 349 customPrintTermBase showP =
 350   [
 351     test isTupleDC (liftM (parens . hcat . punctuate comma) . mapM (showP 0) . subTerms)
 352   , test (isDC consDataCon) (\Term{subTerms=[h,t]} -> doList h t)
 353   , test (isDC intDataCon)  (coerceShow$ \(a::Int)->a)
 354   , test (isDC charDataCon) (coerceShow$ \(a::Char)->a)
 355 --  , test (isDC wordDataCon) (coerceShow$ \(a::Word)->a)
 356   , test (isDC floatDataCon) (coerceShow$ \(a::Float)->a)
 357   , test (isDC doubleDataCon) (coerceShow$ \(a::Double)->a)
 358   , test isIntegerDC (coerceShow$ \(a::Integer)->a)
 359   ]
 360      where test pred f t = if pred t then liftM Just (f t) else return Nothing
 361            isIntegerDC Term{dc=dc} =
 362               dataConName dc `elem` [ smallIntegerDataConName
 363                                     , largeIntegerDataConName]
 364            isTupleDC Term{dc=dc}   = dc `elem` snd (unzip (elems boxedTupleArr))
 365            isDC a_dc Term{dc=dc}   = a_dc == dc
 366            coerceShow f = return . text . show . f . unsafeCoerce# . val
 367            --TODO pprinting of list terms is not lazy
 368            doList h t = do
 369                let elems = h : getListTerms t
 370                    isConsLast = isSuspension (last elems) &&
 371                                 (mb_ty$ last elems) /= (termType h)
 372                init <- mapM (showP 0) (init elems)
 373                last0 <- showP 0 (last elems)
 374                let last = case length elems of
 375                             1 -> last0
 376                             _ | isConsLast -> text " | " <> last0
 377                             _ -> comma <> last0
 378                return$ brackets (hcat (punctuate comma init ++ [last]))
 379
 380                 where Just a /= Just b = not (a `coreEqType` b)
 381                       _      /=   _    = True
 382                       getListTerms Term{subTerms=[h,t]} = h : getListTerms t
 383                       getListTerms t@Term{subTerms=[]}  = []
 384                       getListTerms t@Suspension{}       = [t]
 385                       getListTerms t = pprPanic "getListTerms" (ppr t)
 386
 387 -----------------------------------
 388 -- Type Reconstruction
 389 -----------------------------------
 390
 391 -- The Type Reconstruction monad
 392 type TR a = TcM a
 393
 394 runTR :: HscEnv -> TR Term -> IO Term
 395 runTR hsc_env c = do
 396   mb_term <- initTcPrintErrors hsc_env iNTERACTIVE (c >>= zonkTerm)
 397   case mb_term of
 398     Nothing -> panic "Can't unify"
 399     Just term -> return term
 400
 401 trIO :: IO a -> TR a
 402 trIO = liftTcM . ioToTcRn
 403
 404 addConstraint :: TcType -> TcType -> TR ()
 405 addConstraint t1 t2  = congruenceNewtypes t1 t2 >>= uncurry unifyType
 406
 407 {-
 408    A parallel fold over two Type values,
 409  compensating for missing newtypes on both sides.
 410  This is necessary because newtypes are not present
 411  in runtime, but since sometimes there is evidence
 412  available we do our best to reconstruct them.
 413    Evidence can come from DataCon signatures or
 414  from compile-time type inference.
 415    I am using the words congruence and rewriting
 416  because what we are doing here is an approximation
 417  of unification modulo a set of equations, which would
 418  come from newtype definitions. These should be the
 419  equality coercions seen in System Fc. Rewriting
 420  is performed, taking those equations as rules,
 421  before launching unification.
 422
 423    It doesn't make sense to rewrite everywhere,
 424  or we would end up with all newtypes. So we rewrite
 425  only in presence of evidence.
 426    The lhs comes from the heap structure of ptrs,nptrs.
 427    The rhs comes from a DataCon type signature.
 428  Rewriting in the rhs is restricted to the result type.
 429
 430    Note that it is very tricky to make this 'rewriting'
 431  work with the unification implemented by TcM, where
 432  substitutions are 'inlined'. The order in which
 433  constraints are unified is vital for this (or I am
 434  using TcM wrongly).
 435 -}
 436 congruenceNewtypes ::  TcType -> TcType -> TcM (TcType,TcType)
 437 congruenceNewtypes = go True
 438   where
 439    go rewriteRHS lhs rhs
 440  -- TyVar lhs inductive case
 441     | Just tv <- getTyVar_maybe lhs
 442     = recoverM (return (lhs,rhs)) $ do
 443          Indirect ty_v <- readMetaTyVar tv
 444          (lhs', rhs') <- go rewriteRHS ty_v rhs
 445          writeMutVar (metaTvRef tv) (Indirect lhs')
 446          return (lhs, rhs')
 447  -- TyVar rhs inductive case
 448     | Just tv <- getTyVar_maybe rhs
 449     = recoverM (return (lhs,rhs)) $ do
 450          Indirect ty_v <- readMetaTyVar tv
 451          (lhs', rhs') <- go rewriteRHS lhs ty_v
 452          writeMutVar (metaTvRef tv) (Indirect rhs')
 453          return (lhs', rhs)
 454 -- FunTy inductive case
 455     | Just (l1,l2) <- splitFunTy_maybe lhs
 456     , Just (r1,r2) <- splitFunTy_maybe rhs
 457     = do (l2',r2') <- go True l2 r2
 458          (l1',r1') <- go False l1 r1
 459          return (mkFunTy l1' l2', mkFunTy r1' r2')
 460 -- TyconApp Inductive case; this is the interesting bit.
 461     | Just (tycon_l, args_l) <- splitNewTyConApp_maybe lhs
 462     , Just (tycon_r, args_r) <- splitNewTyConApp_maybe rhs = do
 463
 464       let (tycon_l',args_l') = if isNewTyCon tycon_r && not(isNewTyCon tycon_l)
 465                                 then (tycon_r, rewrite tycon_r lhs)
 466                                 else (tycon_l, args_l)
 467           (tycon_r',args_r') = if rewriteRHS && isNewTyCon tycon_l && not(isNewTyCon tycon_r)
 468                                 then (tycon_l, rewrite tycon_l rhs)
 469                                 else (tycon_r, args_r)
 470       (args_l'', args_r'') <- unzip `liftM` zipWithM (go rewriteRHS) args_l' args_r'
 471       return (mkTyConApp tycon_l' args_l'', mkTyConApp tycon_r' args_r'')
 472
 473     | otherwise = return (lhs,rhs)
 474
 475     where rewrite newtyped_tc lame_tipe
 476            | (tvs, tipe) <- newTyConRep newtyped_tc
 477            = case tcUnifyTys (const BindMe) [tipe] [lame_tipe] of
 478                Just subst -> substTys subst (map mkTyVarTy tvs)
 479                otherwise  -> panic "congruenceNewtypes: Can't unify a newtype"
 480
 481 newVar :: Kind -> TR TcTyVar
 482 newVar = liftTcM . newFlexiTyVar
 483
 484 liftTcM = id
 485
 486 instScheme :: Type -> TR TcType
 487 instScheme ty = liftTcM$ liftM trd (tcInstType (liftM fst3 . tcInstTyVars) ty)
 488     where fst3 (x,y,z) = x
 489           trd  (x,y,z) = z
 490
 491 cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
 492 cvObtainTerm hsc_env force mb_ty a =
 493  -- Obtain the term and tidy the type before returning it
 494      cvObtainTerm1 hsc_env force mb_ty a >>= return . tidyTypes
 495    where
 496          tidyTypes = foldTerm idTermFold {
 497             fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt,
 498             fSuspension = \ct mb_ty hval n ->
 499                           Suspension ct (fmap tidy mb_ty) hval n
 500             }
 501          tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv ty) ty
 502          tidyVarEnv ty =
 503
 504              mkVarEnv$ [ (v, setTyVarName v (tyVarName tv))
 505                          | (tv,v) <- zip alphaTyVars vars]
 506              where vars = varSetElems$ tyVarsOfType ty
 507
 508 cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
 509 cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
 510    tv   <- liftM mkTyVarTy (newVar argTypeKind)
 511    when (isJust mb_ty) $
 512         instScheme (sigmaType$ fromJust mb_ty) >>= addConstraint tv
 513    go tv hval
 514     where
 515   go tv a = do
 516     ctype <- trIO$ getClosureType a
 517     case ctype of
 518 -- Thunks we may want to force
 519       Thunk _ | force -> seq a $ go tv a
 520 -- We always follow indirections
 521       _       | isIndirection ctype -> do
 522         clos   <- trIO$ getClosureData a
 523         (go tv $! (ptrs clos ! 0))
 524  -- The interesting case
 525       Constr -> do
 526         m_dc <- trIO$ tcRnRecoverDataCon hsc_env a
 527         case m_dc of
 528           Nothing -> panic "Can't find the DataCon for a term"
 529           Just dc -> do
 530             clos          <- trIO$ getClosureData a
 531             let extra_args = length(dataConRepArgTys dc) - length(dataConOrigArgTys dc)
 532                 subTtypes  = drop extra_args (dataConRepArgTys dc)
 533                 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
 534                 n_subtermsP= length subTtypesP
 535             subTermTvs    <- mapM (liftM mkTyVarTy . newVar ) (map typeKind subTtypesP)
 536             baseType      <- instScheme (dataConRepType dc)
 537             let myType     = mkFunTys (reOrderTerms subTermTvs subTtypesNP subTtypes) tv
 538             addConstraint myType baseType
 539             subTermsP <- sequence [ extractSubterm i tv (ptrs clos)
 540                                    | (i,tv) <- zip [extra_args..extra_args + n_subtermsP - 1]
 541                                                    subTermTvs ]
 542             let unboxeds   = extractUnboxed subTtypesNP (nonPtrs clos)
 543                 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
 544                 subTerms   = reOrderTerms subTermsP subTermsNP subTtypes
 545             return (Term tv dc a subTerms)
 546 -- The otherwise case: can be a Thunk,AP,PAP,etc.
 547       otherwise -> do
 548          return (Suspension ctype (Just tv) a Nothing)
 549
 550 -- Access the array of pointers and recurse down. Needs to be done with
 551 -- care of no introducing a thunk! or go will fail to do its job
 552   extractSubterm (I# i#) tv ptrs = case ptrs of
 553                  (Array _ _ ptrs#) -> case indexArray# ptrs# i# of
 554                        (# e #) -> go tv e
 555
 556 -- This is used to put together pointed and nonpointed subterms in the
 557 --  correct order.
 558   reOrderTerms _ _ [] = []
 559   reOrderTerms pointed unpointed (ty:tys)
 560    | isPointed ty = head pointed : reOrderTerms (tail pointed) unpointed tys
 561    | otherwise    = head unpointed : reOrderTerms pointed (tail unpointed) tys
 562
 563 zonkTerm :: Term -> TcM Term
 564 zonkTerm = foldTerm idTermFoldM {
 565               fTerm = \ty dc v tt -> sequence tt      >>= \tt ->
 566                                      zonkTcType ty    >>= \ty' ->
 567                                      return (Term ty' dc v tt)
 568              ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
 569                                           return (Suspension ct ty v b)}
 570
 571
 572 -- Is this defined elsewhere?
 573 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
 574 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
 575
 576 {-
 577 Example of Type Reconstruction
 578 --------------------------------
 579 Suppose we have an existential type such as
 580
 581 data Opaque = forall a. Opaque a
 582
 583 And we have a term built as:
 584
 585 t = Opaque (map Just [[1,1],[2,2]])
 586
 587 The type of t as far as the typechecker goes is t :: Opaque
 588 If we seq the head of t, we obtain:
 589
 590 t - O (_1::a)
 591
 592 seq _1 ()
 593
 594 t - O ( (_3::b) : (_4::[b]) )
 595
 596 seq _3 ()
 597
 598 t - O ( (Just (_5::c)) : (_4::[b]) )
 599
 600 At this point, we know that b = (Maybe c)
 601
 602 seq _5 ()
 603
 604 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[b]) )
 605
 606 At this point, we know that c = [d]
 607
 608 seq _6 ()
 609
 610 t - O ( (Just (1 : (_7::[d]) )) : (_4::[b]) )
 611
 612 At this point, we know that d = Integer
 613
 614 The fully reconstructed expressions, with propagation, would be:
 615
 616 t - O ( (Just (_5::c)) : (_4::[Maybe c]) )
 617 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[Maybe [d]]) )
 618 t - O ( (Just (1 : (_7::[Integer]) )) : (_4::[Maybe [Integer]]) )
 619
 620
 621 For reference, the type of the thing inside the opaque is
 622 map Just [[1,1],[2,2]] :: [Maybe [Integer]]
 623
 624 NOTE: (Num t) contexts have been manually replaced by Integer for clarity
 625 -}
 626
 627 --------------------------------------------------------------------
 628 -- The DataConEnv is used to store the addresses of datacons loaded
 629 -- via the dynamic linker
 630 --------------------------------------------------------------------
 631
 632 type DataConEnv   = AddressEnv StgInfoTable
 633
 634 -- Note that this AddressEnv and DataConEnv I wrote trying to follow
 635 -- conventions in ghc, but probably they make not much sense.
 636
 637 newtype AddressEnv a = AE {aenv:: FiniteMap (Ptr a) Name}
 638   deriving (Outputable)
 639
 640 emptyAddressEnv = AE emptyFM
 641
 642 extendAddressEnvList  :: AddressEnv a -> [(Ptr a, Name)] -> AddressEnv a
 643 elemAddressEnv        :: Ptr a -> AddressEnv a -> Bool
 644 delFromAddressEnv     :: AddressEnv a -> Ptr a -> AddressEnv a
 645 nullAddressEnv        :: AddressEnv a -> Bool
 646 lookupAddressEnv       :: AddressEnv a -> Ptr a -> Maybe Name
 647
 648 extendAddressEnvList  (AE env) = AE . addListToFM env
 649 elemAddressEnv   ptr  (AE env) = ptr `elemFM` env
 650 delFromAddressEnv     (AE env) = AE . delFromFM env
 651 nullAddressEnv                 = isEmptyFM . aenv
 652 lookupAddressEnv      (AE env) = lookupFM env
 653
 654
 655 instance Outputable (Ptr a) where
 656   ppr = text . show