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