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