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