compiler/ghci/RtClosureInspect.hs

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