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