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