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      cvObtainTerm,      -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
  11      cvReconstructType,
  12      improveRTTIType,
  13
  14      Term(..),
  15      isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap,
  16      isFullyEvaluated, isFullyEvaluatedTerm,
  17      termType, mapTermType, termTyVars,
  18      foldTerm, TermFold(..), foldTermM, TermFoldM(..), idTermFold,
  19      pprTerm, cPprTerm, cPprTermBase, CustomTermPrinter,
  20
  21 --     unsafeDeepSeq,
  22
  23      Closure(..), getClosureData, ClosureType(..), isConstr, isIndirection,
  24
  25      sigmaType
  26  ) where
  27
  28 #include "HsVersions.h"
  29
  30 import ByteCodeItbls    ( StgInfoTable )
  31 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
  32 import HscTypes
  33 import Linker
  34
  35 import DataCon
  36 import Type
  37 import TypeRep         -- I know I know, this is cheating
  38 import Var
  39 import TcRnMonad
  40 import TcType
  41 import TcMType
  42 import TcUnify
  43 import TcEnv
  44
  45 import TyCon
  46 import Name
  47 import VarEnv
  48 import Util
  49 import ListSetOps
  50 import VarSet
  51 import TysPrim
  52 import PrelNames
  53 import TysWiredIn
  54 import DynFlags
  55 import Outputable
  56 import FastString
  57 import Panic
  58
  59 import Constants        ( wORD_SIZE )
  60
  61 import GHC.Arr          ( Array(..) )
  62 import GHC.Exts
  63 import GHC.IOBase ( IO(IO) )
  64
  65 import Control.Monad
  66 import Data.Maybe
  67 import Data.Array.Base
  68 import Data.Ix
  69 import Data.List
  70 import qualified Data.Sequence as Seq
  71 import Data.Monoid
  72 import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
  73 import Foreign
  74 import System.IO.Unsafe
  75
  76 import System.IO
  77 ---------------------------------------------
  78 -- * A representation of semi evaluated Terms
  79 ---------------------------------------------
  80
  81 data Term = Term { ty        :: RttiType
  82                  , dc        :: Either String DataCon
  83                                -- Carries a text representation if the datacon is
  84                                -- not exported by the .hi file, which is the case
  85                                -- for private constructors in -O0 compiled libraries
  86                  , val       :: HValue
  87                  , subTerms  :: [Term] }
  88
  89           | Prim { ty        :: RttiType
  90                  , value     :: [Word] }
  91
  92           | Suspension { ctype    :: ClosureType
  93                        , ty       :: RttiType
  94                        , val      :: HValue
  95                        , bound_to :: Maybe Name   -- Useful for printing
  96                        }
  97           | NewtypeWrap{       -- At runtime there are no newtypes, and hence no
  98                                -- newtype constructors. A NewtypeWrap is just a
  99                                -- made-up tag saying "heads up, there used to be
 100                                -- a newtype constructor here".
 101                          ty           :: RttiType
 102                        , dc           :: Either String DataCon
 103                        , wrapped_term :: Term }
 104           | RefWrap    {       -- The contents of a reference
 105                          ty           :: RttiType
 106                        , wrapped_term :: Term }
 107
 108 isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap :: Term -> Bool
 109 isTerm Term{} = True
 110 isTerm   _    = False
 111 isSuspension Suspension{} = True
 112 isSuspension      _       = False
 113 isPrim Prim{} = True
 114 isPrim   _    = False
 115 isNewtypeWrap NewtypeWrap{} = True
 116 isNewtypeWrap _             = False
 117
 118 isFun Suspension{ctype=Fun} = True
 119 isFun _ = False
 120
 121 isFunLike s@Suspension{ty=ty} = isFun s || isFunTy ty
 122 isFunLike _ = False
 123
 124 termType :: Term -> RttiType
 125 termType t = ty t
 126
 127 isFullyEvaluatedTerm :: Term -> Bool
 128 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
 129 isFullyEvaluatedTerm Prim {}            = True
 130 isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
 131 isFullyEvaluatedTerm RefWrap{wrapped_term=t}     = isFullyEvaluatedTerm t
 132 isFullyEvaluatedTerm _                  = False
 133
 134 instance Outputable (Term) where
 135  ppr t | Just doc <- cPprTerm cPprTermBase t = doc
 136        | otherwise = panic "Outputable Term instance"
 137
 138 -------------------------------------------------------------------------
 139 -- Runtime Closure Datatype and functions for retrieving closure related stuff
 140 -------------------------------------------------------------------------
 141 data ClosureType = Constr
 142                  | Fun
 143                  | Thunk Int
 144                  | ThunkSelector
 145                  | Blackhole
 146                  | AP
 147                  | PAP
 148                  | Indirection Int
 149                  | MutVar Int
 150                  | MVar   Int
 151                  | Other  Int
 152  deriving (Show, Eq)
 153
 154 data Closure = Closure { tipe         :: ClosureType
 155                        , infoPtr      :: Ptr ()
 156                        , infoTable    :: StgInfoTable
 157                        , ptrs         :: Array Int HValue
 158                        , nonPtrs      :: [Word]
 159                        }
 160
 161 instance Outputable ClosureType where
 162   ppr = text . show
 163
 164 #include "../includes/ClosureTypes.h"
 165
 166 aP_CODE, pAP_CODE :: Int
 167 aP_CODE = AP
 168 pAP_CODE = PAP
 169 #undef AP
 170 #undef PAP
 171
 172 getClosureData :: a -> IO Closure
 173 getClosureData a =
 174    case unpackClosure# a of
 175      (# iptr, ptrs, nptrs #) -> do
 176            let iptr'
 177                 | ghciTablesNextToCode =
 178                    Ptr iptr
 179                 | otherwise =
 180                    -- the info pointer we get back from unpackClosure#
 181                    -- is to the beginning of the standard info table,
 182                    -- but the Storable instance for info tables takes
 183                    -- into account the extra entry pointer when
 184                    -- !ghciTablesNextToCode, so we must adjust here:
 185                    Ptr iptr `plusPtr` negate wORD_SIZE
 186            itbl <- peek iptr'
 187            let tipe = readCType (BCI.tipe itbl)
 188                elems = fromIntegral (BCI.ptrs itbl)
 189                ptrsList = Array 0 (elems - 1) elems ptrs
 190                nptrs_data = [W# (indexWordArray# nptrs i)
 191                               | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
 192            ASSERT(elems >= 0) return ()
 193            ptrsList `seq`
 194             return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
 195
 196 readCType :: Integral a => a -> ClosureType
 197 readCType i
 198  | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
 199  | i >= FUN    && i <= FUN_STATIC          = Fun
 200  | i >= THUNK  && i < THUNK_SELECTOR       = Thunk i'
 201  | i == THUNK_SELECTOR                     = ThunkSelector
 202  | i == BLACKHOLE                          = Blackhole
 203  | i >= IND    && i <= IND_STATIC          = Indirection i'
 204  | i' == aP_CODE                           = AP
 205  | i == AP_STACK                           = AP
 206  | i' == pAP_CODE                          = PAP
 207  | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY= MutVar i'
 208  | i == MVAR_CLEAN    || i == MVAR_DIRTY   = MVar i'
 209  | otherwise                               = Other  i'
 210   where i' = fromIntegral i
 211
 212 isConstr, isIndirection, isThunk :: ClosureType -> Bool
 213 isConstr Constr = True
 214 isConstr    _   = False
 215
 216 isIndirection (Indirection _) = True
 217 isIndirection _ = False
 218
 219 isThunk (Thunk _)     = True
 220 isThunk ThunkSelector = True
 221 isThunk AP            = True
 222 isThunk _             = False
 223
 224 isFullyEvaluated :: a -> IO Bool
 225 isFullyEvaluated a = do
 226   closure <- getClosureData a
 227   case tipe closure of
 228     Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
 229                  return$ and are_subs_evaluated
 230     _      -> return False
 231   where amapM f = sequence . amap' f
 232
 233 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
 234 {-
 235 unsafeDeepSeq :: a -> b -> b
 236 unsafeDeepSeq = unsafeDeepSeq1 2
 237  where unsafeDeepSeq1 0 a b = seq a $! b
 238        unsafeDeepSeq1 i a b   -- 1st case avoids infinite loops for non reducible thunks
 239         | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
 240      -- | unsafePerformIO (isFullyEvaluated a) = b
 241         | otherwise = case unsafePerformIO (getClosureData a) of
 242                         closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
 243         where tipe = unsafePerformIO (getClosureType a)
 244 -}
 245
 246 -----------------------------------
 247 -- * Traversals for Terms
 248 -----------------------------------
 249 type TermProcessor a b = RttiType -> Either String DataCon -> HValue -> [a] -> b
 250
 251 data TermFold a = TermFold { fTerm        :: TermProcessor a a
 252                            , fPrim        :: RttiType -> [Word] -> a
 253                            , fSuspension  :: ClosureType -> RttiType -> HValue
 254                                             -> Maybe Name -> a
 255                            , fNewtypeWrap :: RttiType -> Either String DataCon
 256                                             -> a -> a
 257                            , fRefWrap     :: RttiType -> a -> a
 258                            }
 259
 260
 261 data TermFoldM m a =
 262                    TermFoldM {fTermM        :: TermProcessor a (m a)
 263                             , fPrimM        :: RttiType -> [Word] -> m a
 264                             , fSuspensionM  :: ClosureType -> RttiType -> HValue
 265                                              -> Maybe Name -> m a
 266                             , fNewtypeWrapM :: RttiType -> Either String DataCon
 267                                             -> a -> m a
 268                             , fRefWrapM     :: RttiType -> a -> m a
 269                            }
 270
 271 foldTerm :: TermFold a -> Term -> a
 272 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
 273 foldTerm tf (Prim ty    v   ) = fPrim tf ty v
 274 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
 275 foldTerm tf (NewtypeWrap ty dc t)  = fNewtypeWrap tf ty dc (foldTerm tf t)
 276 foldTerm tf (RefWrap ty t)         = fRefWrap tf ty (foldTerm tf t)
 277
 278
 279 foldTermM :: Monad m => TermFoldM m a -> Term -> m a
 280 foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v
 281 foldTermM tf (Prim ty    v   ) = fPrimM tf ty v
 282 foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b
 283 foldTermM tf (NewtypeWrap ty dc t)  = foldTermM tf t >>=  fNewtypeWrapM tf ty dc
 284 foldTermM tf (RefWrap ty t)         = foldTermM tf t >>= fRefWrapM tf ty
 285
 286 idTermFold :: TermFold Term
 287 idTermFold = TermFold {
 288               fTerm = Term,
 289               fPrim = Prim,
 290               fSuspension  = Suspension,
 291               fNewtypeWrap = NewtypeWrap,
 292               fRefWrap = RefWrap
 293                       }
 294
 295 mapTermType :: (RttiType -> Type) -> Term -> Term
 296 mapTermType f = foldTerm idTermFold {
 297           fTerm       = \ty dc hval tt -> Term (f ty) dc hval tt,
 298           fSuspension = \ct ty hval n ->
 299                           Suspension ct (f ty) hval n,
 300           fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
 301           fRefWrap    = \ty t -> RefWrap (f ty) t}
 302
 303 mapTermTypeM :: Monad m =>  (RttiType -> m Type) -> Term -> m Term
 304 mapTermTypeM f = foldTermM TermFoldM {
 305           fTermM       = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty'  dc hval tt,
 306           fPrimM       = (return.) . Prim,
 307           fSuspensionM = \ct ty hval n ->
 308                           f ty >>= \ty' -> return $ Suspension ct ty' hval n,
 309           fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t,
 310           fRefWrapM    = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t}
 311
 312 termTyVars :: Term -> TyVarSet
 313 termTyVars = foldTerm TermFold {
 314             fTerm       = \ty _ _ tt   ->
 315                           tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
 316             fSuspension = \_ ty _ _ -> tyVarsOfType ty,
 317             fPrim       = \ _ _ -> emptyVarEnv,
 318             fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t,
 319             fRefWrap    = \ty t -> tyVarsOfType ty `plusVarEnv` t}
 320     where concatVarEnv = foldr plusVarEnv emptyVarEnv
 321
 322 ----------------------------------
 323 -- Pretty printing of terms
 324 ----------------------------------
 325
 326 type Precedence        = Int
 327 type TermPrinter       = Precedence -> Term ->   SDoc
 328 type TermPrinterM m    = Precedence -> Term -> m SDoc
 329
 330 app_prec,cons_prec, max_prec ::Int
 331 max_prec  = 10
 332 app_prec  = max_prec
 333 cons_prec = 5 -- TODO Extract this info from GHC itself
 334
 335 pprTerm :: TermPrinter -> TermPrinter
 336 pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
 337 pprTerm _ _ _ = panic "pprTerm"
 338
 339 pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
 340 pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
 341
 342 ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
 343   tt_docs <- mapM (y app_prec) tt
 344   return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
 345
 346 ppr_termM y p Term{dc=Right dc, subTerms=tt}
 347 {-  | dataConIsInfix dc, (t1:t2:tt') <- tt  --TODO fixity
 348   = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
 349     <+> hsep (map (ppr_term1 True) tt)
 350 -} -- TODO Printing infix constructors properly
 351   | null tt   = return$ ppr dc
 352   | otherwise = do
 353          tt_docs <- mapM (y app_prec) tt
 354          return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
 355
 356 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
 357 ppr_termM y p RefWrap{wrapped_term=t}  = do
 358   contents <- y app_prec t
 359   return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
 360   -- The constructor name is wired in here ^^^ for the sake of simplicity.
 361   -- I don't think mutvars are going to change in a near future.
 362   -- In any case this is solely a presentation matter: MutVar# is
 363   -- a datatype with no constructors, implemented by the RTS
 364   -- (hence there is no way to obtain a datacon and print it).
 365 ppr_termM _ _ t = ppr_termM1 t
 366
 367
 368 ppr_termM1 :: Monad m => Term -> m SDoc
 369 ppr_termM1 Prim{value=words, ty=ty} =
 370     return$ text$ repPrim (tyConAppTyCon ty) words
 371 ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
 372     return (char '_' <+> ifPprDebug (text "::" <> ppr ty))
 373 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
 374 --  | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")
 375   | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
 376 ppr_termM1 Term{}        = panic "ppr_termM1 - Term"
 377 ppr_termM1 RefWrap{}     = panic "ppr_termM1 - RefWrap"
 378 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
 379
 380 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
 381   | Just (tc,_) <- tcSplitTyConApp_maybe ty
 382   , ASSERT(isNewTyCon tc) True
 383   , Just new_dc <- tyConSingleDataCon_maybe tc = do
 384          real_term <- y max_prec t
 385          return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
 386 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
 387
 388 -------------------------------------------------------
 389 -- Custom Term Pretty Printers
 390 -------------------------------------------------------
 391
 392 -- We can want to customize the representation of a
 393 --  term depending on its type.
 394 -- However, note that custom printers have to work with
 395 --  type representations, instead of directly with types.
 396 -- We cannot use type classes here, unless we employ some
 397 --  typerep trickery (e.g. Weirich's RepLib tricks),
 398 --  which I didn't. Therefore, this code replicates a lot
 399 --  of what type classes provide for free.
 400
 401 type CustomTermPrinter m = TermPrinterM m
 402                          -> [Precedence -> Term -> (m (Maybe SDoc))]
 403
 404 -- | Takes a list of custom printers with a explicit recursion knot and a term,
 405 -- and returns the output of the first succesful printer, or the default printer
 406 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
 407 cPprTerm printers_ = go 0 where
 408   printers = printers_ go
 409   go prec t = do
 410     let default_ = Just `liftM` pprTermM go prec t
 411         mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
 412     Just doc <- firstJustM mb_customDocs
 413     return$ cparen (prec>app_prec+1) doc
 414
 415   firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
 416   firstJustM [] = return Nothing
 417
 418 -- Default set of custom printers. Note that the recursion knot is explicit
 419 cPprTermBase :: Monad m => CustomTermPrinter m
 420 cPprTermBase y =
 421   [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
 422                                       . mapM (y (-1))
 423                                       . subTerms)
 424   , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
 425            (\ p Term{subTerms=[h,t]} -> doList p h t)
 426   , ifTerm (isTyCon intTyCon    . ty) (coerceShow$ \(a::Int)->a)
 427   , ifTerm (isTyCon charTyCon   . ty) (coerceShow$ \(a::Char)->a)
 428   , ifTerm (isTyCon floatTyCon  . ty) (coerceShow$ \(a::Float)->a)
 429   , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
 430   , ifTerm (isIntegerTy         . ty) (coerceShow$ \(a::Integer)->a)
 431   ]
 432      where ifTerm pred f prec t@Term{}
 433                | pred t    = Just `liftM` f prec t
 434            ifTerm _ _ _ _  = return Nothing
 435
 436            isIntegerTy ty  = fromMaybe False $ do
 437              (tc,_) <- tcSplitTyConApp_maybe ty
 438              return (tyConName tc == integerTyConName)
 439
 440            isTupleTy ty    = fromMaybe False $ do
 441              (tc,_) <- tcSplitTyConApp_maybe ty
 442              return (isBoxedTupleTyCon tc)
 443
 444            isTyCon a_tc ty = fromMaybe False $ do
 445              (tc,_) <- tcSplitTyConApp_maybe ty
 446              return (a_tc == tc)
 447
 448            coerceShow f _p = return . text . show . f . unsafeCoerce# . val
 449
 450            --Note pprinting of list terms is not lazy
 451            doList p h t = do
 452                let elems      = h : getListTerms t
 453                    isConsLast = not(termType(last elems) `coreEqType` termType h)
 454                print_elems <- mapM (y cons_prec) elems
 455                return$ if isConsLast
 456                      then cparen (p >= cons_prec)
 457                         . pprDeeperList fsep
 458                         . punctuate (space<>colon)
 459                         $ print_elems
 460                      else brackets (pprDeeperList fcat$
 461                                          punctuate comma print_elems)
 462
 463                 where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
 464                       getListTerms Term{subTerms=[]}    = []
 465                       getListTerms t@Suspension{}       = [t]
 466                       getListTerms t = pprPanic "getListTerms" (ppr t)
 467
 468
 469 repPrim :: TyCon -> [Word] -> String
 470 repPrim t = rep where
 471    rep x
 472     | t == charPrimTyCon   = show (build x :: Char)
 473     | t == intPrimTyCon    = show (build x :: Int)
 474     | t == wordPrimTyCon   = show (build x :: Word)
 475     | t == floatPrimTyCon  = show (build x :: Float)
 476     | t == doublePrimTyCon = show (build x :: Double)
 477     | t == int32PrimTyCon  = show (build x :: Int32)
 478     | t == word32PrimTyCon = show (build x :: Word32)
 479     | t == int64PrimTyCon  = show (build x :: Int64)
 480     | t == word64PrimTyCon = show (build x :: Word64)
 481     | t == addrPrimTyCon   = show (nullPtr `plusPtr` build x)
 482     | t == stablePtrPrimTyCon  = "<stablePtr>"
 483     | t == stableNamePrimTyCon = "<stableName>"
 484     | t == statePrimTyCon      = "<statethread>"
 485     | t == realWorldTyCon      = "<realworld>"
 486     | t == threadIdPrimTyCon   = "<ThreadId>"
 487     | t == weakPrimTyCon       = "<Weak>"
 488     | t == arrayPrimTyCon      = "<array>"
 489     | t == byteArrayPrimTyCon  = "<bytearray>"
 490     | t == mutableArrayPrimTyCon = "<mutableArray>"
 491     | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
 492     | t == mutVarPrimTyCon= "<mutVar>"
 493     | t == mVarPrimTyCon  = "<mVar>"
 494     | t == tVarPrimTyCon  = "<tVar>"
 495     | otherwise = showSDoc (char '<' <> ppr t <> char '>')
 496     where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
 497 --   This ^^^ relies on the representation of Haskell heap values being
 498 --   the same as in a C array.
 499
 500 -----------------------------------
 501 -- Type Reconstruction
 502 -----------------------------------
 503 {-
 504 Type Reconstruction is type inference done on heap closures.
 505 The algorithm walks the heap generating a set of equations, which
 506 are solved with syntactic unification.
 507 A type reconstruction equation looks like:
 508
 509   <datacon reptype>  =  <actual heap contents>
 510
 511 The full equation set is generated by traversing all the subterms, starting
 512 from a given term.
 513
 514 The only difficult part is that newtypes are only found in the lhs of equations.
 515 Right hand sides are missing them. We can either (a) drop them from the lhs, or
 516 (b) reconstruct them in the rhs when possible.
 517
 518 The function congruenceNewtypes takes a shot at (b)
 519 -}
 520
 521
 522 -- A (non-mutable) tau type containing
 523 -- existentially quantified tyvars.
 524 --    (since GHC type language currently does not support
 525 --     existentials, we leave these variables unquantified)
 526 type RttiType = Type
 527
 528 -- An incomplete type as stored in GHCi:
 529 --  no polymorphism: no quantifiers & all tyvars are skolem.
 530 type GhciType = Type
 531
 532
 533 -- The Type Reconstruction monad
 534 --------------------------------
 535 type TR a = TcM a
 536
 537 runTR :: HscEnv -> TR a -> IO a
 538 runTR hsc_env thing = do
 539   mb_val <- runTR_maybe hsc_env thing
 540   case mb_val of
 541     Nothing -> error "unable to :print the term"
 542     Just x  -> return x
 543
 544 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
 545 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False  iNTERACTIVE
 546
 547 traceTR :: SDoc -> TR ()
 548 traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti
 549
 550
 551 -- Semantically different to recoverM in TcRnMonad
 552 -- recoverM retains the errors in the first action,
 553 --  whereas recoverTc here does not
 554 recoverTR :: TR a -> TR a -> TR a
 555 recoverTR recover thing = do
 556   (_,mb_res) <- tryTcErrs thing
 557   case mb_res of
 558     Nothing  -> recover
 559     Just res -> return res
 560
 561 trIO :: IO a -> TR a
 562 trIO = liftTcM . liftIO
 563
 564 liftTcM :: TcM a -> TR a
 565 liftTcM = id
 566
 567 newVar :: Kind -> TR TcType
 568 newVar = liftTcM . liftM mkTyVarTy . newBoxyTyVar
 569
 570 -- | Returns the instantiated type scheme ty', and the substitution sigma
 571 --   such that sigma(ty') = ty
 572 instScheme :: Type -> TR (TcType, TvSubst)
 573 instScheme ty = liftTcM$ do
 574    (tvs, _, _)      <- tcInstType return ty
 575    (tvs',_,ty') <- tcInstType (mapM tcInstTyVar) ty
 576    return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
 577
 578 -- Adds a constraint of the form t1 == t2
 579 -- t1 is expected to come from walking the heap
 580 -- t2 is expected to come from a datacon signature
 581 -- Before unification, congruenceNewtypes needs to
 582 -- do its magic.
 583 addConstraint :: TcType -> TcType -> TR ()
 584 addConstraint actual expected = do
 585     traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected])
 586     recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
 587                                     text "with", ppr expected])
 588               (congruenceNewtypes actual expected >>=
 589                            (getLIE . uncurry boxyUnify) >> return ())
 590      -- TOMDO: what about the coercion?
 591      -- we should consider family instances
 592
 593
 594 -- Type & Term reconstruction
 595 ------------------------------
 596 cvObtainTerm :: HscEnv -> Int -> Bool -> RttiType -> HValue -> IO Term
 597 cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
 598   -- we quantify existential tyvars as universal,
 599   -- as this is needed to be able to manipulate
 600   -- them properly
 601    let sigma_old_ty = sigmaType old_ty
 602    traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)
 603    term <-
 604      if isMonomorphic sigma_old_ty
 605       then do
 606         new_ty <- go max_depth sigma_old_ty sigma_old_ty hval >>= zonkTerm
 607         return $ fixFunDictionaries $ expandNewtypes new_ty
 608       else do
 609               (old_ty', rev_subst) <- instScheme sigma_old_ty
 610               my_ty <- newVar argTypeKind
 611               when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
 612                                           addConstraint my_ty old_ty')
 613               term  <- go max_depth my_ty sigma_old_ty hval
 614               zterm <- zonkTerm term
 615               let new_ty = termType zterm
 616               if isMonomorphic new_ty || check2 (sigmaType new_ty) sigma_old_ty
 617                  then do
 618                       traceTR (text "check2 passed")
 619                       addConstraint (termType term) old_ty'
 620                       zterm' <- zonkTerm term
 621                       return ((fixFunDictionaries . expandNewtypes . mapTermType (substTy rev_subst)) zterm')
 622                  else do
 623                       traceTR (text "check2 failed" <+> parens
 624                                        (ppr zterm <+> text "::" <+> ppr new_ty))
 625                       -- we have unsound types. Replace constructor types in
 626                       -- subterms with tyvars
 627                       zterm' <- mapTermTypeM
 628                                  (\ty -> case tcSplitTyConApp_maybe ty of
 629                                            Just (tc, _:_) | tc /= funTyCon
 630                                                -> newVar argTypeKind
 631                                            _   -> return ty)
 632                                  zterm
 633                       zonkTerm zterm'
 634    traceTR (text "Term reconstruction completed." $$
 635             text "Term obtained: " <> ppr term $$
 636             text "Type obtained: " <> ppr (termType term))
 637    return term
 638     where
 639   go :: Int -> Type -> Type -> HValue -> TcM Term
 640   go max_depth _ _ _ | seq max_depth False = undefined
 641   go 0 my_ty _old_ty a = do
 642     traceTR (text "Gave up reconstructing a term after" <>
 643                   int max_depth <> text " steps")
 644     clos <- trIO $ getClosureData a
 645     return (Suspension (tipe clos) my_ty a Nothing)
 646   go max_depth my_ty old_ty a = do
 647     let monomorphic = not(isTyVarTy my_ty)
 648     -- This ^^^ is a convention. The ancestor tests for
 649     -- monomorphism and passes a type instead of a tv
 650     clos <- trIO $ getClosureData a
 651     case tipe clos of
 652 -- Thunks we may want to force
 653 -- NB. this won't attempt to force a BLACKHOLE.  Even with :force, we never
 654 -- force blackholes, because it would almost certainly result in deadlock,
 655 -- and showing the '_' is more useful.
 656       t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
 657                                 seq a (go (pred max_depth) my_ty old_ty a)
 658 -- We always follow indirections
 659       Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) )
 660                           go max_depth my_ty old_ty $! (ptrs clos ! 0)
 661 -- We also follow references
 662       MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
 663              -> do
 664                   -- Deal with the MutVar# primitive
 665                   -- It does not have a constructor at all,
 666                   -- so we simulate the following one
 667                   -- MutVar# :: contents_ty -> MutVar# s contents_ty
 668          traceTR (text "Following a MutVar")
 669          contents_tv <- newVar liftedTypeKind
 670          contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
 671          ASSERT(isUnliftedTypeKind $ typeKind my_ty) return ()
 672          (mutvar_ty,_) <- instScheme $ sigmaType $ mkFunTy
 673                             contents_ty (mkTyConApp tycon [world,contents_ty])
 674          addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
 675          x <- go (pred max_depth) contents_tv contents_ty contents
 676          return (RefWrap my_ty x)
 677
 678  -- The interesting case
 679       Constr -> do
 680         traceTR (text "entering a constructor " <>
 681                       if monomorphic
 682                         then parens (text "already monomorphic: " <> ppr my_ty)
 683                         else Outputable.empty)
 684         Right dcname <- dataConInfoPtrToName (infoPtr clos)
 685         (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
 686         case mb_dc of
 687           Nothing -> do -- This can happen for private constructors compiled -O0
 688                         -- where the .hi descriptor does not export them
 689                         -- In such case, we return a best approximation:
 690                         --  ignore the unpointed args, and recover the pointeds
 691                         -- This preserves laziness, and should be safe.
 692                        let tag = showSDoc (ppr dcname)
 693                        vars     <- replicateM (length$ elems$ ptrs clos)
 694                                               (newVar (liftedTypeKind))
 695                        subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
 696                                               | (i, tv) <- zip [0..] vars]
 697                        return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
 698           Just dc -> do
 699             let subTtypes  = matchSubTypes dc old_ty
 700             subTermTvs    <- mapMif (not . isMonomorphic)
 701                                     (\t -> newVar (typeKind t))
 702                                     subTtypes
 703             let (subTermsP, subTermsNP) = partition (\(ty,_) -> isLifted ty
 704                                                              || isRefType ty)
 705                                                     (zip subTtypes subTermTvs)
 706                 (subTtypesP,   subTermTvsP ) = unzip subTermsP
 707                 (subTtypesNP, _subTermTvsNP) = unzip subTermsNP
 708
 709             -- When we already have all the information, avoid solving
 710             -- unnecessary constraints. Propagation of type information
 711             -- to subterms is already being done via matching.
 712             when (not monomorphic) $ do
 713                let myType = mkFunTys subTermTvs my_ty
 714                (signatureType,_) <- instScheme (mydataConType dc)
 715             -- It is vital for newtype reconstruction that the unification step
 716             -- is done right here, _before_ the subterms are RTTI reconstructed
 717                addConstraint myType signatureType
 718             subTermsP <- sequence
 719                   [ appArr (go (pred max_depth) tv t) (ptrs clos) i
 720                    | (i,tv,t) <- zip3 [0..] subTermTvsP subTtypesP]
 721             let unboxeds   = extractUnboxed subTtypesNP clos
 722                 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
 723                 subTerms   = reOrderTerms subTermsP subTermsNP subTtypes
 724             return (Term my_ty (Right dc) a subTerms)
 725 -- The otherwise case: can be a Thunk,AP,PAP,etc.
 726       tipe_clos ->
 727          return (Suspension tipe_clos my_ty a Nothing)
 728
 729   matchSubTypes dc ty
 730     | ty' <- repType ty     -- look through newtypes
 731     , Just (tc,ty_args) <- tcSplitTyConApp_maybe ty'
 732     , dc `elem` tyConDataCons tc
 733       -- It is necessary to check that dc is actually a constructor for tycon tc,
 734       -- because it may be the case that tc is a recursive newtype and tcSplitTyConApp
 735       -- has not removed it. In that case, we happily give up and don't match
 736     = myDataConInstArgTys dc ty_args
 737     | otherwise = dataConRepArgTys dc
 738
 739   -- put together pointed and nonpointed subterms in the
 740   --  correct order.
 741   reOrderTerms _ _ [] = []
 742   reOrderTerms pointed unpointed (ty:tys)
 743    | isLifted ty || isRefType ty
 744                   = ASSERT2(not(null pointed)
 745                             , ptext (sLit "reOrderTerms") $$
 746                                         (ppr pointed $$ ppr unpointed))
 747                     let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
 748    | otherwise    = ASSERT2(not(null unpointed)
 749                            , ptext (sLit "reOrderTerms") $$
 750                                        (ppr pointed $$ ppr unpointed))
 751                     let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
 752
 753   -- insert NewtypeWraps around newtypes
 754   expandNewtypes = foldTerm idTermFold { fTerm = worker } where
 755    worker ty dc hval tt
 756      | Just (tc, args) <- tcSplitTyConApp_maybe ty
 757      , isNewTyCon tc
 758      , wrapped_type    <- newTyConInstRhs tc args
 759      , Just dc'        <- tyConSingleDataCon_maybe tc
 760      , t'              <- worker wrapped_type dc hval tt
 761      = NewtypeWrap ty (Right dc') t'
 762      | otherwise = Term ty dc hval tt
 763
 764
 765    -- Avoid returning types where predicates have been expanded to dictionaries.
 766   fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where
 767       worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
 768                           | otherwise  = Suspension ct ty hval n
 769
 770
 771 -- Fast, breadth-first Type reconstruction
 772 ------------------------------------------
 773 cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type)
 774 cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
 775    traceTR (text "RTTI started with initial type " <> ppr old_ty)
 776    let sigma_old_ty = sigmaType old_ty
 777    new_ty <-
 778        if isMonomorphic sigma_old_ty
 779         then return old_ty
 780         else do
 781           (old_ty', rev_subst) <- instScheme sigma_old_ty
 782           my_ty <- newVar argTypeKind
 783           when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
 784                                       addConstraint my_ty old_ty')
 785           search (isMonomorphic `fmap` zonkTcType my_ty)
 786                  (\(ty,a) -> go ty a)
 787                  (Seq.singleton (my_ty, hval))
 788                  max_depth
 789           new_ty <- zonkTcType my_ty
 790           if isMonomorphic new_ty || check2 (sigmaType new_ty) sigma_old_ty
 791             then do
 792                  traceTR (text "check2 passed")
 793                  addConstraint my_ty old_ty'
 794                  new_ty' <- zonkTcType my_ty
 795                  return (substTy rev_subst new_ty')
 796             else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >>
 797                  return old_ty
 798    traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
 799    return new_ty
 800     where
 801 --  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
 802   search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
 803                                 int max_depth <> text " steps")
 804   search stop expand l d =
 805     case viewl l of
 806       EmptyL  -> return ()
 807       x :< xx -> unlessM stop $ do
 808                   new <- expand x
 809                   search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
 810
 811    -- returns unification tasks,since we are going to want a breadth-first search
 812   go :: Type -> HValue -> TR [(Type, HValue)]
 813   go my_ty a = do
 814     clos <- trIO $ getClosureData a
 815     case tipe clos of
 816       Indirection _ -> go my_ty $! (ptrs clos ! 0)
 817       MutVar _ -> do
 818          contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
 819          tv'   <- newVar liftedTypeKind
 820          world <- newVar liftedTypeKind
 821          addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
 822          return [(tv', contents)]
 823       Constr -> do
 824         Right dcname <- dataConInfoPtrToName (infoPtr clos)
 825         (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
 826         case mb_dc of
 827           Nothing-> do
 828                      --  TODO: Check this case
 829             forM [0..length (elems $ ptrs clos)] $ \i -> do
 830                         tv <- newVar liftedTypeKind
 831                         return$ appArr (\e->(tv,e)) (ptrs clos) i
 832
 833           Just dc -> do
 834             subTtypes <- mapMif (not . isMonomorphic)
 835                                 (\t -> newVar (typeKind t))
 836                                 (dataConRepArgTys dc)
 837
 838             -- It is vital for newtype reconstruction that the unification step
 839             -- is done right here, _before_ the subterms are RTTI reconstructed
 840             let myType         = mkFunTys subTtypes my_ty
 841             (signatureType,_) <- instScheme(mydataConType dc)
 842             addConstraint myType signatureType
 843             return $ [ appArr (\e->(t,e)) (ptrs clos) i
 844                        | (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)]
 845       _ -> return []
 846
 847 -- Compute the difference between a base type and the type found by RTTI
 848 -- improveType <base_type> <rtti_type>
 849 -- The types can contain skolem type variables, which need to be treated as normal vars.
 850 -- In particular, we want them to unify with things.
 851 improveRTTIType :: HscEnv -> RttiType -> RttiType -> IO (Maybe TvSubst)
 852 improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do
 853     traceTR (text "improveRttiType" <+> fsep [ppr _ty, ppr rtti_ty])
 854     (ty_tvs,  _, _)   <- tcInstType return ty
 855     (ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty
 856     (_, _, rtti_ty')  <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty)
 857     getLIE(boxyUnify rtti_ty' ty')
 858     tvs1_contents     <- zonkTcTyVars ty_tvs'
 859     let subst = (uncurry zipTopTvSubst . unzip)
 860                  [(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents
 861                           , getTyVar_maybe ty /= Just tv
 862                           --, not(isTyVarTy ty)
 863                           ]
 864     return subst
 865  where ty = sigmaType _ty
 866
 867 myDataConInstArgTys :: DataCon -> [Type] -> [Type]
 868 myDataConInstArgTys dc args
 869     | null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args
 870     | otherwise = dataConRepArgTys dc
 871
 872 mydataConType :: DataCon -> Type
 873 -- ^ Custom version of DataCon.dataConUserType where we
 874 --    - remove the equality constraints
 875 --    - use the representation types for arguments, including dictionaries
 876 --    - keep the original result type
 877 mydataConType  dc
 878   = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
 879     mkFunTys arg_tys $
 880     res_ty
 881   where univ_tvs   = dataConUnivTyVars dc
 882         ex_tvs     = dataConExTyVars dc
 883         eq_spec    = dataConEqSpec dc
 884         arg_tys    = [case a of
 885                         PredTy p -> predTypeRep p
 886                         _        -> a
 887                      | a <- dataConRepArgTys dc]
 888         res_ty     = dataConOrigResTy dc
 889
 890 isRefType :: Type -> Bool
 891 isRefType ty
 892    | Just (tc, _) <- tcSplitTyConApp_maybe ty' = isRefTyCon tc
 893    | otherwise = False
 894   where ty'= repType ty
 895
 896 isRefTyCon :: TyCon -> Bool
 897 isRefTyCon tc = tc `elem` [mutVarPrimTyCon, mVarPrimTyCon, tVarPrimTyCon]
 898
 899 -- Soundness checks
 900 --------------------
 901 {-
 902 This is not formalized anywhere, so hold to your seats!
 903 RTTI in the presence of newtypes can be a tricky and unsound business.
 904
 905 Example:
 906 ~~~~~~~~~
 907 Suppose we are doing RTTI for a partially evaluated
 908 closure t, the real type of which is t :: MkT Int, for
 909
 910    newtype MkT a = MkT [Maybe a]
 911
 912 The table below shows the results of RTTI and the improvement
 913 calculated for different combinations of evaluatedness and :type t.
 914 Regard the two first columns as input and the next two as output.
 915
 916   # |     t     |  :type t  | rtti(t)  | improv.    | result
 917     ------------------------------------------------------------
 918   1 |     _     |    t b    |    a     | none       | OK
 919   2 |     _     |   MkT b   |    a     | none       | OK
 920   3 |     _     |   t Int   |    a     | none       | OK
 921
 922   If t is not evaluated at *all*, we are safe.
 923
 924   4 |  (_ : _)  |    t b    |   [a]    | t = []     | UNSOUND
 925   5 |  (_ : _)  |   MkT b   |  MkT a   | none       | OK (compensating for the missing newtype)
 926   6 |  (_ : _)  |   t Int   |  [Int]   | t = []     | UNSOUND
 927
 928   If a is a minimal whnf, we run into trouble. Note that
 929   row 5 above does newtype enrichment on the ty_rtty parameter.
 930
 931   7 | (Just _:_)|    t b    |[Maybe a] | t = [],    | UNSOUND
 932     |                       |          | b = Maybe a|
 933
 934   8 | (Just _:_)|   MkT b   |  MkT a   |  none      | OK
 935   9 | (Just _:_)|   t Int   |   FAIL   |  none      | OK
 936
 937   And if t is any more evaluated than whnf, we are still in trouble.
 938   Because constraints are solved in top-down order, when we reach the
 939   Maybe subterm what we got is already unsound. This explains why the
 940   row 9 fails to complete.
 941
 942   10 | (Just _:_)|  t Int  | [Maybe a]   |  FAIL    | OK
 943   11 | (Just 1:_)|  t Int  | [Maybe Int] |  FAIL    | OK
 944
 945   We can undo the failure in row 9 by leaving out the constraint
 946   coming from the type signature of t (i.e., the 2nd column).
 947   Note that this type information is still used
 948   to calculate the improvement. But we fail
 949   when trying to calculate the improvement, as there is no unifier for
 950   t Int = [Maybe a] or t Int = [Maybe Int].
 951
 952
 953   Another set of examples with t :: [MkT (Maybe Int)]  \equiv  [[Maybe (Maybe Int)]]
 954
 955   # |     t     |    :type t    |  rtti(t)    | improvement | result
 956     ---------------------------------------------------------------------
 957   1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = []      |
 958     |           |               |             | b = Maybe a |
 959
 960 The checks:
 961 ~~~~~~~~~~~
 962 Consider a function obtainType that takes a value and a type and produces
 963 the Term representation and a substitution (the improvement).
 964 Assume an auxiliar rtti' function which does the actual job if recovering
 965 the type, but which may produce a false type.
 966
 967 In pseudocode:
 968
 969   rtti' :: a -> IO Type  -- Does not use the static type information
 970
 971   obtainType :: a -> Type -> IO (Maybe (Term, Improvement))
 972   obtainType v old_ty = do
 973        rtti_ty <- rtti' v
 974        if monomorphic rtti_ty || (check rtti_ty old_ty)
 975         then ...
 976          else return Nothing
 977   where check rtti_ty old_ty = check1 rtti_ty &&
 978                               check2 rtti_ty old_ty
 979
 980   check1 :: Type -> Bool
 981   check2 :: Type -> Type -> Bool
 982
 983 Now, if rtti' returns a monomorphic type, we are safe.
 984 If that is not the case, then we consider two conditions.
 985
 986
 987 1. To prevent the class of unsoundness displayed by
 988    rows 4 and 7 in the example: no higher kind tyvars
 989    accepted.
 990
 991   check1 (t a)   = NO
 992   check1 (t Int) = NO
 993   check1 ([] a)  = YES
 994
 995 2. To prevent the class of unsoundness shown by row 6,
 996    the rtti type should be structurally more
 997    defined than the old type we are comparing it to.
 998   check2 :: NewType -> OldType -> Bool
 999   check2 a  _        = True
1000   check2 [a] a       = True
1001   check2 [a] (t Int) = False
1002   check2 [a] (t a)   = False  -- By check1 we never reach this equation
1003   check2 [Int] a     = True
1004   check2 [Int] (t Int) = True
1005   check2 [Maybe a]   (t Int) = False
1006   check2 [Maybe Int] (t Int) = True
1007   check2 (Maybe [a])   (m [Int]) = False
1008   check2 (Maybe [Int]) (m [Int]) = True
1009
1010 -}
1011
1012 check1 :: Type -> Bool
1013 check1 ty | (tvs, _, _) <- tcSplitSigmaTy ty = not $ any isHigherKind (map tyVarKind tvs)
1014  where
1015    isHigherKind = not . null . fst . splitKindFunTys
1016
1017 check2 :: Type -> Type -> Bool
1018 check2 sigma_rtti_ty sigma_old_ty
1019   | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty
1020   = case () of
1021       _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty
1022         -> and$ zipWith check2 rttis olds
1023       _ | Just _ <- splitAppTy_maybe old_ty
1024         -> isMonomorphicOnNonPhantomArgs rtti_ty
1025       _ -> True
1026   | otherwise = True
1027   where (_, _ , rtti_ty) = tcSplitSigmaTy sigma_rtti_ty
1028         (_, _ , old_ty)  = tcSplitSigmaTy sigma_old_ty
1029
1030
1031 -- Dealing with newtypes
1032 --------------------------
1033 {-
1034  congruenceNewtypes does a parallel fold over two Type values,
1035  compensating for missing newtypes on both sides.
1036  This is necessary because newtypes are not present
1037  in runtime, but sometimes there is evidence available.
1038    Evidence can come from DataCon signatures or
1039  from compile-time type inference.
1040  What we are doing here is an approximation
1041  of unification modulo a set of equations derived
1042  from newtype definitions. These equations should be the
1043  same as the equality coercions generated for newtypes
1044  in System Fc. The idea is to perform a sort of rewriting,
1045  taking those equations as rules, before launching unification.
1046
1047  The caller must ensure the following.
1048  The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
1049  The 2nd type (rhs) comes from a DataCon type signature.
1050  Rewriting (i.e. adding/removing a newtype wrapper) can happen
1051  in both types, but in the rhs it is restricted to the result type.
1052
1053    Note that it is very tricky to make this 'rewriting'
1054  work with the unification implemented by TcM, where
1055  substitutions are operationally inlined. The order in which
1056  constraints are unified is vital as we cannot modify
1057  anything that has been touched by a previous unification step.
1058 Therefore, congruenceNewtypes is sound only if the types
1059 recovered by the RTTI mechanism are unified Top-Down.
1060 -}
1061 congruenceNewtypes ::  TcType -> TcType -> TR (TcType,TcType)
1062 congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
1063  where
1064    go l r
1065  -- TyVar lhs inductive case
1066     | Just tv <- getTyVar_maybe l
1067     = recoverTR (return r) $ do
1068          Indirect ty_v <- readMetaTyVar tv
1069          traceTR $ fsep [text "(congruence) Following indirect tyvar:",
1070                           ppr tv, equals, ppr ty_v]
1071          go ty_v r
1072 -- FunTy inductive case
1073     | Just (l1,l2) <- splitFunTy_maybe l
1074     , Just (r1,r2) <- splitFunTy_maybe r
1075     = do r2' <- go l2 r2
1076          r1' <- go l1 r1
1077          return (mkFunTy r1' r2')
1078 -- TyconApp Inductive case; this is the interesting bit.
1079     | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
1080     , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
1081     , tycon_l /= tycon_r
1082     = upgrade tycon_l r
1083
1084     | otherwise = return r
1085
1086     where upgrade :: TyCon -> Type -> TR Type
1087           upgrade new_tycon ty
1088             | not (isNewTyCon new_tycon) = do
1089               traceTR (text "(Upgrade) Not matching newtype evidence: " <>
1090                        ppr new_tycon <> text " for " <> ppr ty)
1091               return ty
1092             | otherwise = do
1093                traceTR (text "(Upgrade) upgraded " <> ppr ty <>
1094                         text " in presence of newtype evidence " <> ppr new_tycon)
1095                vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
1096                let ty' = mkTyConApp new_tycon vars
1097                liftTcM (boxyUnify ty (repType ty'))
1098         -- assumes that reptype doesn't ^^^^ touch tyconApp args
1099                return ty'
1100
1101
1102 zonkTerm :: Term -> TcM Term
1103 zonkTerm = foldTermM TermFoldM{
1104               fTermM = \ty dc v tt -> zonkTcType ty    >>= \ty' ->
1105                                       return (Term ty' dc v tt)
1106              ,fSuspensionM = \ct ty v b -> zonkTcType ty >>= \ty ->
1107                                            return (Suspension ct ty v b)
1108              ,fNewtypeWrapM= \ty dc t -> zonkTcType ty >>= \ty' ->
1109                                          return$ NewtypeWrap ty' dc t
1110              ,fRefWrapM    = \ty t ->
1111                                return RefWrap `ap` zonkTcType ty `ap` return t
1112              ,fPrimM       = (return.) . Prim
1113              }
1114
1115 --------------------------------------------------------------------------------
1116 -- Restore Class predicates out of a representation type
1117 dictsView :: Type -> Type
1118 -- dictsView ty = ty
1119 dictsView (FunTy (TyConApp tc_dict args) ty)
1120   | Just c <- tyConClass_maybe tc_dict
1121   = FunTy (PredTy (ClassP c args)) (dictsView ty)
1122 dictsView ty
1123   | Just (tc_fun, [TyConApp tc_dict args, ty2]) <- tcSplitTyConApp_maybe ty
1124   , Just c <- tyConClass_maybe tc_dict
1125   = mkTyConApp tc_fun [PredTy (ClassP c args), dictsView ty2]
1126 dictsView ty = ty
1127
1128
1129 -- Use only for RTTI types
1130 isMonomorphic :: RttiType -> Bool
1131 isMonomorphic ty = noExistentials && noUniversals
1132  where (tvs, _, ty')     = tcSplitSigmaTy ty
1133        noExistentials = isEmptyVarSet (tyVarsOfType ty')
1134        noUniversals   = null tvs
1135
1136 -- Use only for RTTI types
1137 isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
1138 isMonomorphicOnNonPhantomArgs ty
1139   | Just (tc, all_args) <- tcSplitTyConApp_maybe (repType ty)
1140   , phantom_vars  <- tyConPhantomTyVars tc
1141   , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args
1142                            , tyv `notElem` phantom_vars]
1143   = all isMonomorphicOnNonPhantomArgs concrete_args
1144   | Just (ty1, ty2) <- splitFunTy_maybe ty
1145   = all isMonomorphicOnNonPhantomArgs [ty1,ty2]
1146   | otherwise = isMonomorphic ty
1147
1148 tyConPhantomTyVars :: TyCon -> [TyVar]
1149 tyConPhantomTyVars tc
1150   | isAlgTyCon tc
1151   , Just dcs <- tyConDataCons_maybe tc
1152   , dc_vars  <- concatMap dataConUnivTyVars dcs
1153   = tyConTyVars tc \\ dc_vars
1154 tyConPhantomTyVars _ = []
1155
1156 -- Is this defined elsewhere?
1157 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
1158 sigmaType :: Type -> Type
1159 sigmaType ty = mkSigmaTy (varSetElems$ tyVarsOfType ty) [] ty
1160
1161
1162 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
1163 mapMif pred f xx = sequence $ mapMif_ pred f xx
1164   where
1165    mapMif_ _ _ []     = []
1166    mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
1167
1168 unlessM :: Monad m => m Bool -> m () -> m ()
1169 unlessM condM acc = condM >>= \c -> unless c acc
1170
1171
1172 -- Strict application of f at index i
1173 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
1174 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
1175  = ASSERT2 (i < length(elems a), ppr(length$ elems a, i))
1176    case indexArray# ptrs# i# of
1177        (# e #) -> f e
1178
1179 amap' :: (t -> b) -> Array Int t -> [b]
1180 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
1181     where g (I# i#) = case indexArray# arr# i# of
1182                           (# e #) -> f e
1183
1184
1185 isLifted :: Type -> Bool
1186 isLifted =  not . isUnLiftedType
1187
1188 extractUnboxed  :: [Type] -> Closure -> [[Word]]
1189 extractUnboxed tt clos = go tt (nonPtrs clos)
1190    where sizeofType t
1191            | Just (tycon,_) <- tcSplitTyConApp_maybe t
1192            = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
1193            | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
1194          go [] _ = []
1195          go (t:tt) xx
1196            | (x, rest) <- splitAt (sizeofType t) xx
1197            = x : go tt rest
1198
1199 sizeofTyCon :: TyCon -> Int -- in *words*
1200 sizeofTyCon = primRepSizeW . tyConPrimRep
1201
1202
1203 (|.|) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
1204 (f |.| g) x = f x || g x