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