compiler/ghci/RtClosureInspect.hs

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