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      Term(..),
  14      pprTerm,
  15      cPprTerm,
  16      cPprTermBase,
  17      termType,
  18      foldTerm,
  19      TermFold(..),
  20      idTermFold,
  21      idTermFoldM,
  22      isFullyEvaluated,
  23      isPointed,
  24      isFullyEvaluatedTerm,
  25      mapTermType,
  26      termTyVars,
  27 --     unsafeDeepSeq,
  28      cvReconstructType
  29  ) where
  30
  31 #include "HsVersions.h"
  32
  33 import ByteCodeItbls    ( StgInfoTable )
  34 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
  35 import ByteCodeLink     ( HValue )
  36 import HscTypes         ( HscEnv )
  37
  38 import DataCon
  39 import Type
  40 import TcRnMonad        ( TcM, initTcPrintErrors, ioToTcRn, recoverM)
  41 import TcType
  42 import TcMType
  43 import TcUnify
  44 import TcGadt
  45 import TcEnv
  46 import TyCon
  47 import Var
  48 import Name
  49 import VarEnv
  50 import OccName
  51 import Util
  52 import VarSet
  53 import {-#SOURCE#-} TcRnDriver ( tcRnRecoverDataCon )
  54
  55 import TysPrim
  56 import PrelNames
  57 import TysWiredIn
  58
  59 import Constants
  60 import Outputable
  61 import Maybes
  62 import Panic
  63 import FiniteMap
  64
  65 import GHC.Arr          ( Array(..) )
  66 import GHC.Ptr          ( Ptr(..), castPtr )
  67 import GHC.Exts
  68
  69 import Control.Monad
  70 import Data.Maybe
  71 import Data.Array.Base
  72 import Data.List        ( partition, nub )
  73 import Foreign
  74 import System.IO.Unsafe
  75
  76 ---------------------------------------------
  77 -- * A representation of semi evaluated Terms
  78 ---------------------------------------------
  79 {-
  80   A few examples in this representation:
  81
  82   > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
  83
  84   > (('a',_,_),_,('b',_,_)) =
  85       Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
  86           [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
  87           , Suspension
  88           , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
  89 -}
  90
  91 data Term = Term { ty        :: Type
  92                  , dc        :: DataCon  -- The heap datacon. If ty is a newtype,
  93                                          -- this is NOT the newtype datacon
  94                  , val       :: HValue
  95                  , subTerms  :: [Term] }
  96
  97           | Prim { ty        :: Type
  98                  , value     :: [Word] }
  99
 100           | Suspension { ctype    :: ClosureType
 101                        , mb_ty    :: Maybe Type
 102                        , val      :: HValue
 103                        , bound_to :: Maybe Name   -- Useful for printing
 104                        }
 105
 106 isTerm, isSuspension, isPrim :: Term -> Bool
 107 isTerm Term{} = True
 108 isTerm   _    = False
 109 isSuspension Suspension{} = True
 110 isSuspension      _       = False
 111 isPrim Prim{} = True
 112 isPrim   _    = False
 113
 114 termType :: Term -> Maybe Type
 115 termType t@(Suspension {}) = mb_ty t
 116 termType t = Just$ ty t
 117
 118 isFullyEvaluatedTerm :: Term -> Bool
 119 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
 120 isFullyEvaluatedTerm Suspension {}      = False
 121 isFullyEvaluatedTerm Prim {}            = True
 122
 123 instance Outputable (Term) where
 124  ppr = head . cPprTerm cPprTermBase
 125
 126 -------------------------------------------------------------------------
 127 -- Runtime Closure Datatype and functions for retrieving closure related stuff
 128 -------------------------------------------------------------------------
 129 data ClosureType = Constr
 130                  | Fun
 131                  | Thunk Int
 132                  | ThunkSelector
 133                  | Blackhole
 134                  | AP
 135                  | PAP
 136                  | Indirection Int
 137                  | Other Int
 138  deriving (Show, Eq)
 139
 140 data Closure = Closure { tipe         :: ClosureType
 141                        , infoPtr      :: Ptr ()
 142                        , infoTable    :: StgInfoTable
 143                        , ptrs         :: Array Int HValue
 144                        , nonPtrs      :: [Word]
 145                        }
 146
 147 instance Outputable ClosureType where
 148   ppr = text . show
 149
 150 #include "../includes/ClosureTypes.h"
 151
 152 aP_CODE = AP
 153 pAP_CODE = PAP
 154 #undef AP
 155 #undef PAP
 156
 157 getClosureData :: a -> IO Closure
 158 getClosureData a =
 159    case unpackClosure# a of
 160      (# iptr, ptrs, nptrs #) -> do
 161            itbl <- peek (Ptr iptr)
 162            let tipe = readCType (BCI.tipe itbl)
 163                elems = BCI.ptrs itbl
 164                ptrsList = Array 0 ((fromIntegral elems) - 1) ptrs
 165                nptrs_data = [W# (indexWordArray# nptrs i)
 166                               | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
 167            ASSERT(fromIntegral elems >= 0) return ()
 168            ptrsList `seq`
 169             return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
 170
 171 readCType :: Integral a => a -> ClosureType
 172 readCType i
 173  | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
 174  | i >= FUN    && i <= FUN_STATIC          = Fun
 175  | i >= THUNK  && i < THUNK_SELECTOR       = Thunk (fromIntegral i)
 176  | i == THUNK_SELECTOR                     = ThunkSelector
 177  | i == BLACKHOLE                          = Blackhole
 178  | i >= IND    && i <= IND_STATIC          = Indirection (fromIntegral i)
 179  | fromIntegral i == aP_CODE               = AP
 180  | i == AP_STACK                           = AP
 181  | fromIntegral i == pAP_CODE              = PAP
 182  | otherwise                               = Other (fromIntegral i)
 183
 184 isConstr, isIndirection, isThunk :: ClosureType -> Bool
 185 isConstr Constr = True
 186 isConstr    _   = False
 187
 188 isIndirection (Indirection _) = True
 189 --isIndirection ThunkSelector = True
 190 isIndirection _ = False
 191
 192 isThunk (Thunk _)     = True
 193 isThunk ThunkSelector = True
 194 isThunk AP            = True
 195 isThunk _             = False
 196
 197 isFullyEvaluated :: a -> IO Bool
 198 isFullyEvaluated a = do
 199   closure <- getClosureData a
 200   case tipe closure of
 201     Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
 202                  return$ and are_subs_evaluated
 203     otherwise -> return False
 204   where amapM f = sequence . amap' f
 205
 206 amap' f (Array i0 i arr#) = map (\(I# i#) -> case indexArray# arr# i# of
 207                                    (# e #) -> f e)
 208                                 [0 .. i - i0]
 209
 210 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
 211 {-
 212 unsafeDeepSeq :: a -> b -> b
 213 unsafeDeepSeq = unsafeDeepSeq1 2
 214  where unsafeDeepSeq1 0 a b = seq a $! b
 215        unsafeDeepSeq1 i a b   -- 1st case avoids infinite loops for non reducible thunks
 216         | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
 217      -- | unsafePerformIO (isFullyEvaluated a) = b
 218         | otherwise = case unsafePerformIO (getClosureData a) of
 219                         closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
 220         where tipe = unsafePerformIO (getClosureType a)
 221 -}
 222 isPointed :: Type -> Bool
 223 isPointed t | Just (t, _) <- splitTyConApp_maybe t
 224             = not$ isUnliftedTypeKind (tyConKind t)
 225 isPointed _ = True
 226
 227 extractUnboxed  :: [Type] -> Closure -> [[Word]]
 228 extractUnboxed tt clos = go tt (nonPtrs clos)
 229    where sizeofType t
 230            | Just (tycon,_) <- splitTyConApp_maybe t
 231            = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
 232            | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
 233          go [] _ = []
 234          go (t:tt) xx
 235            | (x, rest) <- splitAt (sizeofType t `div` wORD_SIZE) xx
 236            = x : go tt rest
 237
 238 sizeofTyCon = sizeofPrimRep . tyConPrimRep
 239
 240 -----------------------------------
 241 -- * Traversals for Terms
 242 -----------------------------------
 243
 244 data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a
 245                            , fPrim :: Type -> [Word] -> a
 246                            , fSuspension :: ClosureType -> Maybe Type -> HValue
 247                                            -> Maybe Name -> a
 248                            }
 249
 250 foldTerm :: TermFold a -> Term -> a
 251 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
 252 foldTerm tf (Prim ty    v   ) = fPrim tf ty v
 253 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
 254
 255 idTermFold :: TermFold Term
 256 idTermFold = TermFold {
 257               fTerm = Term,
 258               fPrim = Prim,
 259               fSuspension = Suspension
 260                       }
 261 idTermFoldM :: Monad m => TermFold (m Term)
 262 idTermFoldM = TermFold {
 263               fTerm       = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
 264               fPrim       = (return.). Prim,
 265               fSuspension = (((return.).).). Suspension
 266                        }
 267
 268 mapTermType :: (Type -> Type) -> Term -> Term
 269 mapTermType f = foldTerm idTermFold {
 270           fTerm       = \ty dc hval tt -> Term (f ty) dc hval tt,
 271           fSuspension = \ct mb_ty hval n ->
 272                           Suspension ct (fmap f mb_ty) hval n }
 273
 274 termTyVars :: Term -> TyVarSet
 275 termTyVars = foldTerm TermFold {
 276             fTerm       = \ty _ _ tt   ->
 277                           tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
 278             fSuspension = \_ mb_ty _ _ ->
 279                           maybe emptyVarEnv tyVarsOfType mb_ty,
 280             fPrim       = \ _ _ -> emptyVarEnv }
 281     where concatVarEnv = foldr plusVarEnv emptyVarEnv
 282 ----------------------------------
 283 -- Pretty printing of terms
 284 ----------------------------------
 285
 286 app_prec,cons_prec ::Int
 287 app_prec = 10
 288 cons_prec = 5 -- TODO Extract this info from GHC itself
 289
 290 pprTerm y p t | Just doc <- pprTermM y p t = doc
 291
 292 pprTermM :: Monad m => (Int -> Term -> m SDoc) -> Int -> Term -> m SDoc
 293 pprTermM y p t@Term{dc=dc, subTerms=tt, ty=ty}
 294 {-  | dataConIsInfix dc, (t1:t2:tt') <- tt  --TODO fixity
 295   = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2)
 296     <+> hsep (map (pprTerm1 True) tt)
 297 -}
 298   | null tt   = return$ ppr dc
 299   | Just (tc,_) <- splitNewTyConApp_maybe ty
 300   , isNewTyCon tc
 301   , Just new_dc <- maybeTyConSingleCon tc = do
 302          real_value <- y 10 t{ty=repType ty}
 303          return$ cparen (p >= app_prec) (ppr new_dc <+> real_value)
 304   | otherwise = do
 305          tt_docs <- mapM (y app_prec) tt
 306          return$ cparen (p >= app_prec) (ppr dc <+> sep tt_docs)
 307
 308 pprTermM y _ t = pprTermM1 y t
 309
 310 pprTermM1 _ Prim{value=words, ty=ty} = return$ text$ repPrim (tyConAppTyCon ty)
 311                                                              words
 312 pprTermM1 y t@Term{} = panic "pprTermM1 - unreachable"
 313 pprTermM1 _ Suspension{bound_to=Nothing} = return$ char '_'
 314 pprTermM1 _ Suspension{mb_ty=Just ty, bound_to=Just n}
 315   | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
 316   | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
 317
 318 -- Takes a list of custom printers with a explicit recursion knot and a term,
 319 -- and returns the output of the first succesful printer, or the default printer
 320 cPprTerm :: forall m. Monad m =>
 321            ((Int->Term->m SDoc)->[Int->Term->m (Maybe SDoc)]) -> Term -> m SDoc
 322 cPprTerm custom = go 0 where
 323   go prec t@Term{} = do
 324     let default_ prec t = Just `liftM` pprTermM go prec t
 325         mb_customDocs = [pp prec t | pp <- custom go ++ [default_]]
 326     Just doc <- firstJustM mb_customDocs
 327     return$ cparen (prec>app_prec+1) doc
 328   go _ t = pprTermM1 go t
 329   firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
 330   firstJustM [] = return Nothing
 331
 332 -- Default set of custom printers. Note that the recursion knot is explicit
 333 cPprTermBase :: Monad m => (Int->Term-> m SDoc)->[Int->Term->m (Maybe SDoc)]
 334 cPprTermBase y =
 335   [
 336     ifTerm isTupleTy             (\_ -> liftM (parens . hcat . punctuate comma)
 337                                  . mapM (y (-1)) . subTerms)
 338   , ifTerm (\t -> isTyCon listTyCon t && subTerms t `lengthIs` 2)
 339                                  (\ p Term{subTerms=[h,t]} -> doList p h t)
 340   , ifTerm (isTyCon intTyCon)    (coerceShow$ \(a::Int)->a)
 341   , ifTerm (isTyCon charTyCon)   (coerceShow$ \(a::Char)->a)
 342 --  , ifTerm (isTyCon wordTyCon) (coerceShow$ \(a::Word)->a)
 343   , ifTerm (isTyCon floatTyCon)  (coerceShow$ \(a::Float)->a)
 344   , ifTerm (isTyCon doubleTyCon) (coerceShow$ \(a::Double)->a)
 345   , ifTerm isIntegerTy           (coerceShow$ \(a::Integer)->a)
 346   ]
 347      where ifTerm pred f p t@Term{} | pred t    = liftM Just (f p t)
 348                                     | otherwise = return Nothing
 349            isIntegerTy Term{ty=ty}  | Just (tc,_) <- splitTyConApp_maybe ty
 350                                     = tyConName tc == integerTyConName
 351            isTupleTy Term{ty=ty}    | Just (tc,_) <- splitTyConApp_maybe ty
 352                                     = tc `elem` (fst.unzip.elems) boxedTupleArr
 353            isTyCon a_tc Term{ty=ty} | Just (tc,_) <- splitTyConApp_maybe ty
 354                                     = a_tc == tc
 355            coerceShow f _ = return . text . show . f . unsafeCoerce# . val
 356            --TODO pprinting of list terms is not lazy
 357            doList p h t = do
 358                let elems = h : getListTerms t
 359                    isConsLast = termType(last elems) /= termType h
 360                print_elems <- mapM (y cons_prec) elems
 361                return$ if isConsLast
 362                      then cparen (p >= cons_prec) . hsep . punctuate (space<>colon)
 363                            $ print_elems
 364                      else brackets (hcat$ punctuate comma print_elems)
 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 repPrim :: TyCon -> [Word] -> String
 375 repPrim t = rep where
 376    rep x
 377     | t == charPrimTyCon   = show (build x :: Char)
 378     | t == intPrimTyCon    = show (build x :: Int)
 379     | t == wordPrimTyCon   = show (build x :: Word)
 380     | t == floatPrimTyCon  = show (build x :: Float)
 381     | t == doublePrimTyCon = show (build x :: Double)
 382     | t == int32PrimTyCon  = show (build x :: Int32)
 383     | t == word32PrimTyCon = show (build x :: Word32)
 384     | t == int64PrimTyCon  = show (build x :: Int64)
 385     | t == word64PrimTyCon = show (build x :: Word64)
 386     | t == addrPrimTyCon   = show (nullPtr `plusPtr` build x)
 387     | t == stablePtrPrimTyCon  = "<stablePtr>"
 388     | t == stableNamePrimTyCon = "<stableName>"
 389     | t == statePrimTyCon      = "<statethread>"
 390     | t == realWorldTyCon      = "<realworld>"
 391     | t == threadIdPrimTyCon   = "<ThreadId>"
 392     | t == weakPrimTyCon       = "<Weak>"
 393     | t == arrayPrimTyCon      = "<array>"
 394     | t == byteArrayPrimTyCon  = "<bytearray>"
 395     | t == mutableArrayPrimTyCon = "<mutableArray>"
 396     | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
 397     | t == mutVarPrimTyCon= "<mutVar>"
 398     | t == mVarPrimTyCon  = "<mVar>"
 399     | t == tVarPrimTyCon  = "<tVar>"
 400     | otherwise = showSDoc (char '<' <> ppr t <> char '>')
 401     where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
 402 --   This ^^^ relies on the representation of Haskell heap values being
 403 --   the same as in a C array.
 404
 405 -----------------------------------
 406 -- Type Reconstruction
 407 -----------------------------------
 408 {-
 409 Type Reconstruction is type inference done on heap closures.
 410 The algorithm walks the heap generating a set of equations, which
 411 are solved with syntactic unification.
 412 A type reconstruction equation looks like:
 413
 414   <datacon reptype>  =  <actual heap contents>
 415
 416 The full equation set is generated by traversing all the subterms, starting
 417 from a given term.
 418
 419 The only difficult part is that newtypes are only found in the lhs of equations.
 420 Right hand sides are missing them. We can either (a) drop them from the lhs, or
 421 (b) reconstruct them in the rhs when possible.
 422
 423 The function congruenceNewtypes takes a shot at (b)
 424 -}
 425
 426 -- The Type Reconstruction monad
 427 type TR a = TcM a
 428
 429 runTR :: HscEnv -> TR a -> IO a
 430 runTR hsc_env c = do
 431   mb_term <- initTcPrintErrors hsc_env iNTERACTIVE c
 432   case mb_term of
 433     Nothing -> panic "Can't unify"
 434     Just x -> return x
 435
 436 trIO :: IO a -> TR a
 437 trIO = liftTcM . ioToTcRn
 438
 439 liftTcM :: TcM a -> TR a
 440 liftTcM = id
 441
 442 newVar :: Kind -> TR TcTyVar
 443 newVar = liftTcM . newFlexiTyVar
 444
 445 -- | Returns the instantiated type scheme ty', and the substitution sigma
 446 --   such that sigma(ty') = ty
 447 instScheme :: Type -> TR (TcType, TvSubst)
 448 instScheme ty | (tvs, rho) <- tcSplitForAllTys ty = liftTcM$ do
 449    (tvs',theta,ty') <- tcInstType (mapM tcInstTyVar) ty
 450    return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
 451
 452 -- Adds a constraint of the form t1 == t2
 453 -- t1 is expected to come from walking the heap
 454 -- t2 is expected to come from a datacon signature
 455 -- Before unification, congruenceNewtypes needs to
 456 -- do its magic.
 457 addConstraint :: TcType -> TcType -> TR ()
 458 addConstraint t1 t2  = congruenceNewtypes t1 t2 >>= uncurry unifyType
 459
 460
 461
 462 -- Type & Term reconstruction
 463 cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
 464 cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
 465    tv <- liftM mkTyVarTy (newVar argTypeKind)
 466    case mb_ty of
 467      Nothing -> go tv tv hval >>= zonkTerm
 468      Just ty | isMonomorphic ty -> go ty ty hval >>= zonkTerm
 469      Just ty -> do
 470               (ty',rev_subst) <- instScheme (sigmaType ty)
 471               addConstraint tv ty'
 472               term <- go tv tv hval >>= zonkTerm
 473               --restore original Tyvars
 474               return$ mapTermType (substTy rev_subst) term
 475     where
 476   go tv ty a = do
 477     let monomorphic = not(isTyVarTy tv)
 478     -- This ^^^ is a convention. The ancestor tests for
 479     -- monomorphism and passes a type instead of a tv
 480     clos <- trIO $ getClosureData a
 481     case tipe clos of
 482 -- Thunks we may want to force
 483 -- NB. this won't attempt to force a BLACKHOLE.  Even with :force, we never
 484 -- force blackholes, because it would almost certainly result in deadlock,
 485 -- and showing the '_' is more useful.
 486       t | isThunk t && force -> seq a $ go tv ty a
 487 -- We always follow indirections
 488       Indirection _ -> go tv ty $! (ptrs clos ! 0)
 489  -- The interesting case
 490       Constr -> do
 491         m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
 492         case m_dc of
 493           Nothing -> panic "Can't find the DataCon for a term"
 494           Just dc -> do
 495             let extra_args = length(dataConRepArgTys dc) -
 496                              length(dataConOrigArgTys dc)
 497                 subTtypes  = matchSubTypes dc ty
 498                 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
 499             subTermTvs <- sequence
 500                  [ if isMonomorphic t then return t
 501                                       else (mkTyVarTy `fmap` newVar k)
 502                    | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
 503             -- It is vital for newtype reconstruction that the unification step
 504             --  is done right here, _before_ the subterms are RTTI reconstructed
 505             when (not monomorphic) $ do
 506                   let myType = mkFunTys (reOrderTerms subTermTvs
 507                                                       subTtypesNP
 508                                                       subTtypes)
 509                                         tv
 510                   (signatureType,_) <- instScheme(dataConRepType dc)
 511                   addConstraint myType signatureType
 512             subTermsP <- sequence $ drop extra_args
 513                                  -- ^^^  all extra arguments are pointed
 514                   [ appArr (go tv t) (ptrs clos) i
 515                    | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
 516             let unboxeds   = extractUnboxed subTtypesNP clos
 517                 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
 518                 subTerms   = reOrderTerms subTermsP subTermsNP
 519                                 (drop extra_args subTtypes)
 520             return (Term tv dc a subTerms)
 521 -- The otherwise case: can be a Thunk,AP,PAP,etc.
 522       otherwise ->
 523          return (Suspension (tipe clos) (Just tv) a Nothing)
 524
 525   matchSubTypes dc ty
 526     | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
 527     , isVanillaDataCon dc  --TODO non-vanilla case
 528     = dataConInstArgTys dc ty_args
 529 --     assumes that newtypes are looked ^^^ through
 530     | otherwise = dataConRepArgTys dc
 531
 532 -- This is used to put together pointed and nonpointed subterms in the
 533 --  correct order.
 534   reOrderTerms _ _ [] = []
 535   reOrderTerms pointed unpointed (ty:tys)
 536    | isPointed ty = ASSERT2(not(null pointed)
 537                             , ptext SLIT("reOrderTerms") $$
 538                                         (ppr pointed $$ ppr unpointed))
 539                     head pointed : reOrderTerms (tail pointed) unpointed tys
 540    | otherwise    = ASSERT2(not(null unpointed)
 541                            , ptext SLIT("reOrderTerms") $$
 542                                        (ppr pointed $$ ppr unpointed))
 543                     head unpointed : reOrderTerms pointed (tail unpointed) tys
 544
 545
 546
 547 -- Fast, breadth-first Type reconstruction
 548 max_depth = 10 :: Int
 549 cvReconstructType :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Type
 550 cvReconstructType hsc_env force mb_ty hval = runTR hsc_env $ do
 551    tv <- liftM mkTyVarTy (newVar argTypeKind)
 552    case mb_ty of
 553      Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
 554                           (uncurry go)
 555                           [(tv, hval)]
 556                           max_depth
 557                    zonkTcType tv  -- TODO untested!
 558      Just ty | isMonomorphic ty -> return ty
 559      Just ty -> do
 560               (ty',rev_subst) <- instScheme (sigmaType ty)
 561               addConstraint tv ty'
 562               search (isMonomorphic `fmap` zonkTcType tv)
 563                      (uncurry go)
 564                      [(tv, hval)]
 565                      max_depth
 566               substTy rev_subst `fmap` zonkTcType tv
 567     where
 568 --  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
 569   search stop expand [] depth  = return ()
 570   search stop expand x 0 = fail$ "Failed to reconstruct a type after " ++
 571                                 show max_depth ++ " steps"
 572   search stop expand (x:xx) d  = do
 573     new <- expand x
 574     unlessM stop $ search stop expand (xx ++ new) $! (pred d)
 575
 576    -- returns unification tasks,since we are going to want a breadth-first search
 577   go :: Type -> HValue -> TR [(Type, HValue)]
 578   go tv a = do
 579     clos <- trIO $ getClosureData a
 580     case tipe clos of
 581       Indirection _ -> go tv $! (ptrs clos ! 0)
 582       Constr -> do
 583         m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
 584         case m_dc of
 585           Nothing -> panic "Can't find the DataCon for a term"
 586           Just dc -> do
 587             let extra_args = length(dataConRepArgTys dc) -
 588                              length(dataConOrigArgTys dc)
 589             subTtypes <- mapMif (not . isMonomorphic)
 590                                 (\t -> mkTyVarTy `fmap` newVar (typeKind t))
 591                                 (dataConRepArgTys dc)
 592             -- It is vital for newtype reconstruction that the unification step
 593             -- is done right here, _before_ the subterms are RTTI reconstructed
 594             let myType         = mkFunTys subTtypes tv
 595             (signatureType,_) <- instScheme(dataConRepType dc)
 596             addConstraint myType signatureType
 597             return $ [ appArr (\e->(t,e)) (ptrs clos) i
 598                        | (i,t) <- drop extra_args $ zip [0..] subTtypes]
 599       otherwise -> return []
 600
 601
 602 -- Dealing with newtypes
 603 {-
 604    A parallel fold over two Type values,
 605  compensating for missing newtypes on both sides.
 606  This is necessary because newtypes are not present
 607  in runtime, but since sometimes there is evidence
 608  available we do our best to reconstruct them.
 609    Evidence can come from DataCon signatures or
 610  from compile-time type inference.
 611    I am using the words congruence and rewriting
 612  because what we are doing here is an approximation
 613  of unification modulo a set of equations, which would
 614  come from newtype definitions. These should be the
 615  equality coercions seen in System Fc. Rewriting
 616  is performed, taking those equations as rules,
 617  before launching unification.
 618
 619    It doesn't make sense to rewrite everywhere,
 620  or we would end up with all newtypes. So we rewrite
 621  only in presence of evidence.
 622    The lhs comes from the heap structure of ptrs,nptrs.
 623    The rhs comes from a DataCon type signature.
 624  Rewriting in the rhs is restricted to the result type.
 625
 626    Note that it is very tricky to make this 'rewriting'
 627  work with the unification implemented by TcM, where
 628  substitutions are 'inlined'. The order in which
 629  constraints are unified is vital for this (or I am
 630  using TcM wrongly).
 631 -}
 632 congruenceNewtypes ::  TcType -> TcType -> TcM (TcType,TcType)
 633 congruenceNewtypes lhs rhs
 634  -- TyVar lhs inductive case
 635     | Just tv <- getTyVar_maybe lhs
 636     = recoverM (return (lhs,rhs)) $ do
 637          Indirect ty_v <- readMetaTyVar tv
 638          (lhs1, rhs1) <- congruenceNewtypes ty_v rhs
 639          return (lhs, rhs1)
 640 -- FunTy inductive case
 641     | Just (l1,l2) <- splitFunTy_maybe lhs
 642     , Just (r1,r2) <- splitFunTy_maybe rhs
 643     = do (l2',r2') <- congruenceNewtypes l2 r2
 644          (l1',r1') <- congruenceNewtypes l1 r1
 645          return (mkFunTy l1' l2', mkFunTy r1' r2')
 646 -- TyconApp Inductive case; this is the interesting bit.
 647     | Just (tycon_l, args_l) <- splitNewTyConApp_maybe lhs
 648     , Just (tycon_r, args_r) <- splitNewTyConApp_maybe rhs
 649     , tycon_l /= tycon_r
 650     = return (lhs, upgrade tycon_l rhs)
 651
 652     | otherwise = return (lhs,rhs)
 653
 654     where upgrade :: TyCon -> Type -> Type
 655           upgrade new_tycon ty
 656             | not (isNewTyCon new_tycon) = ty
 657             | ty' <- mkTyConApp new_tycon (map mkTyVarTy $ tyConTyVars new_tycon)
 658             , Just subst <- tcUnifyTys (const BindMe) [ty] [repType ty']
 659             = substTy subst ty'
 660         -- assumes that reptype doesn't touch tyconApp args ^^^
 661
 662
 663 --------------------------------------------------------------------------------
 664
 665 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
 666                  = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
 667
 668 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
 669 mapMif pred f xx = sequence $ mapMif_ pred f xx
 670 mapMif_ pred f []     = []
 671 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
 672
 673 unlessM condM acc = condM >>= \c -> unless c acc
 674
 675 -- Strict application of f at index i
 676 appArr f (Array _ _ ptrs#) (I# i#) = case indexArray# ptrs# i# of
 677                                        (# e #) -> f e
 678
 679 zonkTerm :: Term -> TcM Term
 680 zonkTerm = foldTerm idTermFoldM {
 681               fTerm = \ty dc v tt -> sequence tt      >>= \tt ->
 682                                      zonkTcType ty    >>= \ty' ->
 683                                      return (Term ty' dc v tt)
 684              ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
 685                                           return (Suspension ct ty v b)}
 686
 687
 688 -- Is this defined elsewhere?
 689 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
 690 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
 691
 692