compiler/ghci/RtClosureInspect.hs

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