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
 521 -- A (non-mutable) tau type containing
 522 -- existentially quantified tyvars.
 523 --    (since GHC type language currently does not support
 524 --     existentials, we leave these variables unquantified)
 525 type RttiType = Type
 526
 527 -- An incomplete type as stored in GHCi:
 528 --  no polymorphism: no quantifiers & all tyvars are skolem.
 529 type GhciType = Type
 530
 531
 532 -- The Type Reconstruction monad
 533 --------------------------------
 534 type TR a = TcM a
 535
 536 runTR :: HscEnv -> TR a -> IO a
 537 runTR hsc_env thing = do
 538   mb_val <- runTR_maybe hsc_env thing
 539   case mb_val of
 540     Nothing -> error "unable to :print the term"
 541     Just x  -> return x
 542
 543 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
 544 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False  iNTERACTIVE
 545
 546 traceTR :: SDoc -> TR ()
 547 traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti
 548
 549
 550 -- Semantically different to recoverM in TcRnMonad
 551 -- recoverM retains the errors in the first action,
 552 --  whereas recoverTc here does not
 553 recoverTR :: TR a -> TR a -> TR a
 554 recoverTR recover thing = do
 555   (_,mb_res) <- tryTcErrs thing
 556   case mb_res of
 557     Nothing  -> recover
 558     Just res -> return res
 559
 560 trIO :: IO a -> TR a
 561 trIO = liftTcM . liftIO
 562
 563 liftTcM :: TcM a -> TR a
 564 liftTcM = id
 565
 566 newVar :: Kind -> TR TcType
 567 newVar = liftTcM . liftM mkTyVarTy . newBoxyTyVar
 568
 569 -- | Returns the instantiated type scheme ty', and the substitution sigma
 570 --   such that sigma(ty') = ty
 571 instScheme :: Type -> TR (TcType, TvSubst)
 572 instScheme ty = liftTcM$ do
 573    (tvs, _, _)      <- tcInstType return ty
 574    (tvs',_,ty') <- tcInstType (mapM tcInstTyVar) ty
 575    return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
 576
 577 -- Adds a constraint of the form t1 == t2
 578 -- t1 is expected to come from walking the heap
 579 -- t2 is expected to come from a datacon signature
 580 -- Before unification, congruenceNewtypes needs to
 581 -- do its magic.
 582 addConstraint :: TcType -> TcType -> TR ()
 583 addConstraint actual expected = do
 584     traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected])
 585     recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
 586                                     text "with", ppr expected])
 587               (congruenceNewtypes actual expected >>=
 588                            (getLIE . uncurry boxyUnify) >> return ())
 589      -- TOMDO: what about the coercion?
 590      -- we should consider family instances
 591
 592
 593 -- Type & Term reconstruction
 594 ------------------------------
 595 cvObtainTerm :: HscEnv -> Int -> Bool -> RttiType -> HValue -> IO Term
 596 cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
 597   -- we quantify existential tyvars as universal,
 598   -- as this is needed to be able to manipulate
 599   -- them properly
 600    let sigma_old_ty = sigmaType old_ty
 601    traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)
 602    term <-
 603      if isMonomorphic sigma_old_ty
 604       then do
 605         new_ty <- go max_depth sigma_old_ty sigma_old_ty hval >>= zonkTerm
 606         return $ fixFunDictionaries $ expandNewtypes new_ty
 607       else do
 608               (old_ty', rev_subst) <- instScheme sigma_old_ty
 609               my_ty <- newVar argTypeKind
 610               when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
 611                                           addConstraint my_ty old_ty')
 612               term  <- go max_depth my_ty sigma_old_ty hval
 613               zterm <- zonkTerm term
 614               let new_ty = termType zterm
 615               if isMonomorphic new_ty || check2 (sigmaType new_ty) sigma_old_ty
 616                  then do
 617                       traceTR (text "check2 passed")
 618                       addConstraint (termType term) old_ty'
 619                       zterm' <- zonkTerm term
 620                       return ((fixFunDictionaries . expandNewtypes . mapTermType (substTy rev_subst)) zterm')
 621                  else do
 622                       traceTR (text "check2 failed" <+> parens
 623                                        (ppr zterm <+> text "::" <+> ppr new_ty))
 624                       -- we have unsound types. Replace constructor types in
 625                       -- subterms with tyvars
 626                       zterm' <- mapTermTypeM
 627                                  (\ty -> case tcSplitTyConApp_maybe ty of
 628                                            Just (tc, _:_) | tc /= funTyCon
 629                                                -> newVar argTypeKind
 630                                            _   -> return ty)
 631                                  zterm
 632                       zonkTerm zterm'
 633    traceTR (text "Term reconstruction completed." $$
 634             text "Term obtained: " <> ppr term $$
 635             text "Type obtained: " <> ppr (termType term))
 636    return term
 637     where
 638   go :: Int -> Type -> Type -> HValue -> TcM Term
 639   go max_depth _ _ _ | seq max_depth False = undefined
 640   go 0 my_ty _old_ty a = do
 641     traceTR (text "Gave up reconstructing a term after" <>
 642                   int max_depth <> text " steps")
 643     clos <- trIO $ getClosureData a
 644     return (Suspension (tipe clos) my_ty a Nothing)
 645   go max_depth my_ty old_ty a = do
 646     let monomorphic = not(isTyVarTy my_ty)
 647     -- This ^^^ is a convention. The ancestor tests for
 648     -- monomorphism and passes a type instead of a tv
 649     clos <- trIO $ getClosureData a
 650     case tipe clos of
 651 -- Thunks we may want to force
 652 -- NB. this won't attempt to force a BLACKHOLE.  Even with :force, we never
 653 -- force blackholes, because it would almost certainly result in deadlock,
 654 -- and showing the '_' is more useful.
 655       t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
 656                                 seq a (go (pred max_depth) my_ty old_ty a)
 657 -- We always follow indirections
 658       Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) )
 659                           go max_depth my_ty old_ty $! (ptrs clos ! 0)
 660 -- We also follow references
 661       MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
 662              -> do
 663                   -- Deal with the MutVar# primitive
 664                   -- It does not have a constructor at all,
 665                   -- so we simulate the following one
 666                   -- MutVar# :: contents_ty -> MutVar# s contents_ty
 667          traceTR (text "Following a MutVar")
 668          contents_tv <- newVar liftedTypeKind
 669          contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
 670          ASSERT(isUnliftedTypeKind $ typeKind my_ty) return ()
 671          (mutvar_ty,_) <- instScheme $ sigmaType $ mkFunTy
 672                             contents_ty (mkTyConApp tycon [world,contents_ty])
 673          addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
 674          x <- go (pred max_depth) contents_tv contents_ty contents
 675          return (RefWrap my_ty x)
 676
 677  -- The interesting case
 678       Constr -> do
 679         traceTR (text "entering a constructor " <>
 680                       if monomorphic
 681                         then parens (text "already monomorphic: " <> ppr my_ty)
 682                         else Outputable.empty)
 683         Right dcname <- dataConInfoPtrToName (infoPtr clos)
 684         (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
 685         case mb_dc of
 686           Nothing -> do -- This can happen for private constructors compiled -O0
 687                         -- where the .hi descriptor does not export them
 688                         -- In such case, we return a best approximation:
 689                         --  ignore the unpointed args, and recover the pointeds
 690                         -- This preserves laziness, and should be safe.
 691                        let tag = showSDoc (ppr dcname)
 692                        vars     <- replicateM (length$ elems$ ptrs clos)
 693                                               (newVar (liftedTypeKind))
 694                        subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
 695                                               | (i, tv) <- zip [0..] vars]
 696                        return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
 697           Just dc -> do
 698             let subTtypes  = matchSubTypes dc old_ty
 699             subTermTvs    <- mapMif (not . isMonomorphic)
 700                                     (\t -> newVar (typeKind t))
 701                                     subTtypes
 702             let (subTermsP, subTermsNP) = partition (\(ty,_) -> isLifted ty
 703                                                              || isRefType ty)
 704                                                     (zip subTtypes subTermTvs)
 705                 (subTtypesP,   subTermTvsP ) = unzip subTermsP
 706                 (subTtypesNP, _subTermTvsNP) = unzip subTermsNP
 707
 708             -- When we already have all the information, avoid solving
 709             -- unnecessary constraints. Propagation of type information
 710             -- to subterms is already being done via matching.
 711             when (not monomorphic) $ do
 712                let myType = mkFunTys subTermTvs my_ty
 713                (signatureType,_) <- instScheme (rttiView $ dataConUserType dc)
 714             -- It is vital for newtype reconstruction that the unification step
 715             -- is done right here, _before_ the subterms are RTTI reconstructed
 716                addConstraint myType signatureType
 717             subTermsP <- sequence
 718                   [ appArr (go (pred max_depth) tv t) (ptrs clos) i
 719                    | (i,tv,t) <- zip3 [0..] subTermTvsP subTtypesP]
 720             let unboxeds   = extractUnboxed subTtypesNP clos
 721                 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
 722                 subTerms   = reOrderTerms subTermsP subTermsNP subTtypes
 723             return (Term my_ty (Right dc) a subTerms)
 724 -- The otherwise case: can be a Thunk,AP,PAP,etc.
 725       tipe_clos ->
 726          return (Suspension tipe_clos my_ty a Nothing)
 727
 728   matchSubTypes dc ty
 729     | ty' <- repType ty     -- look through newtypes
 730     , Just (tc,ty_args) <- tcSplitTyConApp_maybe ty'
 731     , dc `elem` tyConDataCons tc
 732       -- It is necessary to check that dc is actually a constructor for tycon tc,
 733       -- because it may be the case that tc is a recursive newtype and tcSplitTyConApp
 734       -- has not removed it. In that case, we happily give up and don't match
 735     = myDataConInstArgTys dc ty_args
 736     | otherwise = dataConRepArgTys dc
 737
 738   -- put together pointed and nonpointed subterms in the
 739   --  correct order.
 740   reOrderTerms _ _ [] = []
 741   reOrderTerms pointed unpointed (ty:tys)
 742    | isLifted ty || isRefType ty
 743                   = ASSERT2(not(null pointed)
 744                             , ptext (sLit "reOrderTerms") $$
 745                                         (ppr pointed $$ ppr unpointed))
 746                     let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
 747    | otherwise    = ASSERT2(not(null unpointed)
 748                            , ptext (sLit "reOrderTerms") $$
 749                                        (ppr pointed $$ ppr unpointed))
 750                     let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
 751
 752   -- insert NewtypeWraps around newtypes
 753   expandNewtypes = foldTerm idTermFold { fTerm = worker } where
 754    worker ty dc hval tt
 755      | Just (tc, args) <- tcSplitTyConApp_maybe ty
 756      , isNewTyCon tc
 757      , wrapped_type    <- newTyConInstRhs tc args
 758      , Just dc'        <- tyConSingleDataCon_maybe tc
 759      , t'              <- worker wrapped_type dc hval tt
 760      = NewtypeWrap ty (Right dc') t'
 761      | otherwise = Term ty dc hval tt
 762
 763
 764    -- Avoid returning types where predicates have been expanded to dictionaries.
 765   fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where
 766       worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
 767                           | otherwise  = Suspension ct ty hval n
 768
 769
 770 -- Fast, breadth-first Type reconstruction
 771 ------------------------------------------
 772 cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type)
 773 cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
 774    traceTR (text "RTTI started with initial type " <> ppr old_ty)
 775    let sigma_old_ty = sigmaType old_ty
 776    new_ty <-
 777        if isMonomorphic sigma_old_ty
 778         then return old_ty
 779         else do
 780           (old_ty', rev_subst) <- instScheme sigma_old_ty
 781           my_ty <- newVar argTypeKind
 782           when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
 783                                       addConstraint my_ty old_ty')
 784           search (isMonomorphic `fmap` zonkTcType my_ty)
 785                  (\(ty,a) -> go ty a)
 786                  (Seq.singleton (my_ty, hval))
 787                  max_depth
 788           new_ty <- zonkTcType my_ty
 789           if isMonomorphic new_ty || check2 (sigmaType new_ty) sigma_old_ty
 790             then do
 791                  traceTR (text "check2 passed")
 792                  addConstraint my_ty old_ty'
 793                  new_ty' <- zonkTcType my_ty
 794                  return (substTy rev_subst new_ty')
 795             else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >>
 796                  return old_ty
 797    traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
 798    return new_ty
 799     where
 800 --  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
 801   search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
 802                                 int max_depth <> text " steps")
 803   search stop expand l d =
 804     case viewl l of
 805       EmptyL  -> return ()
 806       x :< xx -> unlessM stop $ do
 807                   new <- expand x
 808                   search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
 809
 810    -- returns unification tasks,since we are going to want a breadth-first search
 811   go :: Type -> HValue -> TR [(Type, HValue)]
 812   go my_ty a = do
 813     clos <- trIO $ getClosureData a
 814     case tipe clos of
 815       Indirection _ -> go my_ty $! (ptrs clos ! 0)
 816       MutVar _ -> do
 817          contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
 818          tv'   <- newVar liftedTypeKind
 819          world <- newVar liftedTypeKind
 820          addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
 821          return [(tv', contents)]
 822       Constr -> do
 823         Right dcname <- dataConInfoPtrToName (infoPtr clos)
 824         (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
 825         case mb_dc of
 826           Nothing-> do
 827                      --  TODO: Check this case
 828             forM [0..length (elems $ ptrs clos)] $ \i -> do
 829                         tv <- newVar liftedTypeKind
 830                         return$ appArr (\e->(tv,e)) (ptrs clos) i
 831
 832           Just dc -> do
 833             subTtypes <- mapMif (not . isMonomorphic)
 834                                 (\t -> newVar (typeKind t))
 835                                 (dataConRepArgTys dc)
 836
 837             -- It is vital for newtype reconstruction that the unification step
 838             -- is done right here, _before_ the subterms are RTTI reconstructed
 839             let myType         = mkFunTys subTtypes my_ty
 840             (signatureType,_) <- instScheme(rttiView $ dataConUserType dc)
 841             addConstraint myType signatureType
 842             return $ [ appArr (\e->(t,e)) (ptrs clos) i
 843                        | (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)]
 844       _ -> return []
 845
 846 -- Compute the difference between a base type and the type found by RTTI
 847 -- improveType <base_type> <rtti_type>
 848 -- The types can contain skolem type variables, which need to be treated as normal vars.
 849 -- In particular, we want them to unify with things.
 850 improveRTTIType :: HscEnv -> RttiType -> RttiType -> IO (Maybe TvSubst)
 851 improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do
 852     traceTR $ fsep [text "improveRttiType", ppr _ty, ppr rtti_ty]
 853     (ty_tvs,  _, _)   <- tcInstType return ty
 854     (ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty
 855     (_, _, rtti_ty')  <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty)
 856     getLIE(boxyUnify rtti_ty' ty')
 857     tvs1_contents     <- zonkTcTyVars ty_tvs'
 858     let subst = (uncurry zipTopTvSubst . unzip)
 859                  [(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents
 860                           , getTyVar_maybe ty /= Just tv
 861                           --, not(isTyVarTy ty)
 862                           ]
 863     return subst
 864  where ty = sigmaType _ty
 865
 866 myDataConInstArgTys :: DataCon -> [Type] -> [Type]
 867 myDataConInstArgTys dc args
 868     | null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args
 869     | otherwise = dataConRepArgTys dc
 870
 871 isRefType :: Type -> Bool
 872 isRefType ty
 873    | Just (tc, _) <- tcSplitTyConApp_maybe ty' = isRefTyCon tc
 874    | otherwise = False
 875   where ty'= repType ty
 876
 877 isRefTyCon :: TyCon -> Bool
 878 isRefTyCon tc = tc `elem` [mutVarPrimTyCon, mVarPrimTyCon, tVarPrimTyCon]
 879
 880 -- Soundness checks
 881 --------------------
 882 {-
 883 This is not formalized anywhere, so hold to your seats!
 884 RTTI in the presence of newtypes can be a tricky and unsound business.
 885
 886 Example:
 887 ~~~~~~~~~
 888 Suppose we are doing RTTI for a partially evaluated
 889 closure t, the real type of which is t :: MkT Int, for
 890
 891    newtype MkT a = MkT [Maybe a]
 892
 893 The table below shows the results of RTTI and the improvement
 894 calculated for different combinations of evaluatedness and :type t.
 895 Regard the two first columns as input and the next two as output.
 896
 897   # |     t     |  :type t  | rtti(t)  | improv.    | result
 898     ------------------------------------------------------------
 899   1 |     _     |    t b    |    a     | none       | OK
 900   2 |     _     |   MkT b   |    a     | none       | OK
 901   3 |     _     |   t Int   |    a     | none       | OK
 902
 903   If t is not evaluated at *all*, we are safe.
 904
 905   4 |  (_ : _)  |    t b    |   [a]    | t = []     | UNSOUND
 906   5 |  (_ : _)  |   MkT b   |  MkT a   | none       | OK (compensating for the missing newtype)
 907   6 |  (_ : _)  |   t Int   |  [Int]   | t = []     | UNSOUND
 908
 909   If a is a minimal whnf, we run into trouble. Note that
 910   row 5 above does newtype enrichment on the ty_rtty parameter.
 911
 912   7 | (Just _:_)|    t b    |[Maybe a] | t = [],    | UNSOUND
 913     |                       |          | b = Maybe a|
 914
 915   8 | (Just _:_)|   MkT b   |  MkT a   |  none      | OK
 916   9 | (Just _:_)|   t Int   |   FAIL   |  none      | OK
 917
 918   And if t is any more evaluated than whnf, we are still in trouble.
 919   Because constraints are solved in top-down order, when we reach the
 920   Maybe subterm what we got is already unsound. This explains why the
 921   row 9 fails to complete.
 922
 923   10 | (Just _:_)|  t Int  | [Maybe a]   |  FAIL    | OK
 924   11 | (Just 1:_)|  t Int  | [Maybe Int] |  FAIL    | OK
 925
 926   We can undo the failure in row 9 by leaving out the constraint
 927   coming from the type signature of t (i.e., the 2nd column).
 928   Note that this type information is still used
 929   to calculate the improvement. But we fail
 930   when trying to calculate the improvement, as there is no unifier for
 931   t Int = [Maybe a] or t Int = [Maybe Int].
 932
 933
 934   Another set of examples with t :: [MkT (Maybe Int)]  \equiv  [[Maybe (Maybe Int)]]
 935
 936   # |     t     |    :type t    |  rtti(t)    | improvement | result
 937     ---------------------------------------------------------------------
 938   1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = []      |
 939     |           |               |             | b = Maybe a |
 940
 941 The checks:
 942 ~~~~~~~~~~~
 943 Consider a function obtainType that takes a value and a type and produces
 944 the Term representation and a substitution (the improvement).
 945 Assume an auxiliar rtti' function which does the actual job if recovering
 946 the type, but which may produce a false type.
 947
 948 In pseudocode:
 949
 950   rtti' :: a -> IO Type  -- Does not use the static type information
 951
 952   obtainType :: a -> Type -> IO (Maybe (Term, Improvement))
 953   obtainType v old_ty = do
 954        rtti_ty <- rtti' v
 955        if monomorphic rtti_ty || (check rtti_ty old_ty)
 956         then ...
 957          else return Nothing
 958   where check rtti_ty old_ty = check1 rtti_ty &&
 959                               check2 rtti_ty old_ty
 960
 961   check1 :: Type -> Bool
 962   check2 :: Type -> Type -> Bool
 963
 964 Now, if rtti' returns a monomorphic type, we are safe.
 965 If that is not the case, then we consider two conditions.
 966
 967
 968 1. To prevent the class of unsoundness displayed by
 969    rows 4 and 7 in the example: no higher kind tyvars
 970    accepted.
 971
 972   check1 (t a)   = NO
 973   check1 (t Int) = NO
 974   check1 ([] a)  = YES
 975
 976 2. To prevent the class of unsoundness shown by row 6,
 977    the rtti type should be structurally more
 978    defined than the old type we are comparing it to.
 979   check2 :: NewType -> OldType -> Bool
 980   check2 a  _        = True
 981   check2 [a] a       = True
 982   check2 [a] (t Int) = False
 983   check2 [a] (t a)   = False  -- By check1 we never reach this equation
 984   check2 [Int] a     = True
 985   check2 [Int] (t Int) = True
 986   check2 [Maybe a]   (t Int) = False
 987   check2 [Maybe Int] (t Int) = True
 988   check2 (Maybe [a])   (m [Int]) = False
 989   check2 (Maybe [Int]) (m [Int]) = True
 990
 991 -}
 992
 993 check1 :: Type -> Bool
 994 check1 ty | (tvs, _, _) <- tcSplitSigmaTy ty = not $ any isHigherKind (map tyVarKind tvs)
 995  where
 996    isHigherKind = not . null . fst . splitKindFunTys
 997
 998 check2 :: Type -> Type -> Bool
 999 check2 sigma_rtti_ty sigma_old_ty
1000   | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty
1001   = case () of
1002       _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty
1003         -> and$ zipWith check2 rttis olds
1004       _ | Just _ <- splitAppTy_maybe old_ty
1005         -> isMonomorphicOnNonPhantomArgs rtti_ty
1006       _ -> True
1007   | otherwise = True
1008   where (_, _ , rtti_ty) = tcSplitSigmaTy sigma_rtti_ty
1009         (_, _ , old_ty)  = tcSplitSigmaTy sigma_old_ty
1010
1011
1012 -- Dealing with newtypes
1013 --------------------------
1014 {-
1015  congruenceNewtypes does a parallel fold over two Type values,
1016  compensating for missing newtypes on both sides.
1017  This is necessary because newtypes are not present
1018  in runtime, but sometimes there is evidence available.
1019    Evidence can come from DataCon signatures or
1020  from compile-time type inference.
1021  What we are doing here is an approximation
1022  of unification modulo a set of equations derived
1023  from newtype definitions. These equations should be the
1024  same as the equality coercions generated for newtypes
1025  in System Fc. The idea is to perform a sort of rewriting,
1026  taking those equations as rules, before launching unification.
1027
1028  The caller must ensure the following.
1029  The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
1030  The 2nd type (rhs) comes from a DataCon type signature.
1031  Rewriting (i.e. adding/removing a newtype wrapper) can happen
1032  in both types, but in the rhs it is restricted to the result type.
1033
1034    Note that it is very tricky to make this 'rewriting'
1035  work with the unification implemented by TcM, where
1036  substitutions are operationally inlined. The order in which
1037  constraints are unified is vital as we cannot modify
1038  anything that has been touched by a previous unification step.
1039 Therefore, congruenceNewtypes is sound only if the types
1040 recovered by the RTTI mechanism are unified Top-Down.
1041 -}
1042 congruenceNewtypes ::  TcType -> TcType -> TR (TcType,TcType)
1043 congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
1044  where
1045    go l r
1046  -- TyVar lhs inductive case
1047     | Just tv <- getTyVar_maybe l
1048     = recoverTR (return r) $ do
1049          Indirect ty_v <- readMetaTyVar tv
1050          traceTR $ fsep [text "(congruence) Following indirect tyvar:",
1051                           ppr tv, equals, ppr ty_v]
1052          go ty_v r
1053 -- FunTy inductive case
1054     | Just (l1,l2) <- splitFunTy_maybe l
1055     , Just (r1,r2) <- splitFunTy_maybe r
1056     = do r2' <- go l2 r2
1057          r1' <- go l1 r1
1058          return (mkFunTy r1' r2')
1059 -- TyconApp Inductive case; this is the interesting bit.
1060     | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
1061     , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
1062     , tycon_l /= tycon_r
1063     = upgrade tycon_l r
1064
1065     | otherwise = return r
1066
1067     where upgrade :: TyCon -> Type -> TR Type
1068           upgrade new_tycon ty
1069             | not (isNewTyCon new_tycon) = do
1070               traceTR (text "(Upgrade) Not matching newtype evidence: " <>
1071                        ppr new_tycon <> text " for " <> ppr ty)
1072               return ty
1073             | otherwise = do
1074                traceTR (text "(Upgrade) upgraded " <> ppr ty <>
1075                         text " in presence of newtype evidence " <> ppr new_tycon)
1076                vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
1077                let ty' = mkTyConApp new_tycon vars
1078                liftTcM (boxyUnify ty (repType ty'))
1079         -- assumes that reptype doesn't ^^^^ touch tyconApp args
1080                return ty'
1081
1082
1083 zonkTerm :: Term -> TcM Term
1084 zonkTerm = foldTermM TermFoldM{
1085               fTermM = \ty dc v tt -> zonkTcType ty    >>= \ty' ->
1086                                       return (Term ty' dc v tt)
1087              ,fSuspensionM = \ct ty v b -> zonkTcType ty >>= \ty ->
1088                                            return (Suspension ct ty v b)
1089              ,fNewtypeWrapM= \ty dc t -> zonkTcType ty >>= \ty' ->
1090                                          return$ NewtypeWrap ty' dc t
1091              ,fRefWrapM    = \ty t ->
1092                                return RefWrap `ap` zonkTcType ty `ap` return t
1093              ,fPrimM       = (return.) . Prim
1094              }
1095
1096 --------------------------------------------------------------------------------
1097 -- representation types for thetas
1098 rttiView :: Type -> Type
1099 rttiView ty | Just ty' <- coreView ty  = rttiView ty'
1100 rttiView ty
1101   | (tvs, theta, tau) <- tcSplitSigmaTy ty
1102   =  mkForAllTys tvs (mkFunTys [predTypeRep p | p <- theta, isClassPred p] tau)
1103
1104 -- Restore Class predicates out of a representation type
1105 dictsView :: Type -> Type
1106 -- dictsView ty = ty
1107 dictsView (FunTy (TyConApp tc_dict args) ty)
1108   | Just c <- tyConClass_maybe tc_dict
1109   = FunTy (PredTy (ClassP c args)) (dictsView ty)
1110 dictsView ty
1111   | Just (tc_fun, [TyConApp tc_dict args, ty2]) <- tcSplitTyConApp_maybe ty
1112   , Just c <- tyConClass_maybe tc_dict
1113   = mkTyConApp tc_fun [PredTy (ClassP c args), dictsView ty2]
1114 dictsView ty = ty
1115
1116
1117 -- Use only for RTTI types
1118 isMonomorphic :: RttiType -> Bool
1119 isMonomorphic ty = noExistentials && noUniversals
1120  where (tvs, _, ty')     = tcSplitSigmaTy ty
1121        noExistentials = isEmptyVarSet (tyVarsOfType ty')
1122        noUniversals   = null tvs
1123
1124 -- Use only for RTTI types
1125 isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
1126 isMonomorphicOnNonPhantomArgs ty
1127   | Just (tc, all_args) <- tcSplitTyConApp_maybe (repType ty)
1128   , phantom_vars  <- tyConPhantomTyVars tc
1129   , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args
1130                            , tyv `notElem` phantom_vars]
1131   = all isMonomorphicOnNonPhantomArgs concrete_args
1132   | Just (ty1, ty2) <- splitFunTy_maybe ty
1133   = all isMonomorphicOnNonPhantomArgs [ty1,ty2]
1134   | otherwise = isMonomorphic ty
1135
1136 tyConPhantomTyVars :: TyCon -> [TyVar]
1137 tyConPhantomTyVars tc
1138   | isAlgTyCon tc
1139   , Just dcs <- tyConDataCons_maybe tc
1140   , dc_vars  <- concatMap dataConUnivTyVars dcs
1141   = tyConTyVars tc \\ dc_vars
1142 tyConPhantomTyVars _ = []
1143
1144 -- Is this defined elsewhere?
1145 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
1146 sigmaType :: Type -> Type
1147 sigmaType ty = mkSigmaTy (varSetElems$ tyVarsOfType ty) [] ty
1148
1149
1150 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
1151 mapMif pred f xx = sequence $ mapMif_ pred f xx
1152   where
1153    mapMif_ _ _ []     = []
1154    mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
1155
1156 unlessM :: Monad m => m Bool -> m () -> m ()
1157 unlessM condM acc = condM >>= \c -> unless c acc
1158
1159
1160 -- Strict application of f at index i
1161 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
1162 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
1163  = ASSERT2 (i < length(elems a), ppr(length$ elems a, i))
1164    case indexArray# ptrs# i# of
1165        (# e #) -> f e
1166
1167 amap' :: (t -> b) -> Array Int t -> [b]
1168 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
1169     where g (I# i#) = case indexArray# arr# i# of
1170                           (# e #) -> f e
1171
1172
1173 isLifted :: Type -> Bool
1174 isLifted =  not . isUnLiftedType
1175
1176 extractUnboxed  :: [Type] -> Closure -> [[Word]]
1177 extractUnboxed tt clos = go tt (nonPtrs clos)
1178    where sizeofType t
1179            | Just (tycon,_) <- tcSplitTyConApp_maybe t
1180            = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
1181            | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
1182          go [] _ = []
1183          go (t:tt) xx
1184            | (x, rest) <- splitAt (sizeofType t) xx
1185            = x : go tt rest
1186
1187 sizeofTyCon :: TyCon -> Int -- in *words*
1188 sizeofTyCon = primRepSizeW . tyConPrimRep
1189
1190
1191 (|.|) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
1192 (f |.| g) x = f x || g x