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
  11      cvObtainTerm,      -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
  12
  13      Term(..),
  14      isTerm,
  15      isSuspension,
  16      isPrim,
  17      isNewtypeWrap,
  18      pprTerm,
  19      cPprTerm,
  20      cPprTermBase,
  21      CustomTermPrinter,
  22      termType,
  23      foldTerm,
  24      TermFold(..),
  25      idTermFold,
  26      idTermFoldM,
  27      isFullyEvaluated,
  28      isPointed,
  29      isFullyEvaluatedTerm,
  30      mapTermType,
  31      termTyVars,
  32 --     unsafeDeepSeq,
  33      cvReconstructType,
  34      improveRTTIType,
  35      sigmaType,
  36      Closure(..),
  37      getClosureData,
  38      ClosureType(..),
  39      isConstr,
  40      isIndirection
  41  ) where
  42
  43 #include "HsVersions.h"
  44
  45 import ByteCodeItbls    ( StgInfoTable )
  46 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
  47 import HscTypes         ( HscEnv )
  48 import Linker
  49
  50 import DataCon
  51 import Type
  52 import Var
  53 import TcRnMonad
  54 import TcType
  55 import TcMType
  56 import TcUnify
  57 import TcEnv
  58 import DriverPhases
  59 import TyCon
  60 import Name
  61 import VarEnv
  62 import Util
  63 import VarSet
  64
  65 import TysPrim
  66 import PrelNames
  67 import TysWiredIn
  68
  69 import Outputable
  70 import FastString
  71 import Panic
  72
  73 import Constants        ( wORD_SIZE )
  74
  75 import GHC.Arr          ( Array(..) )
  76 import GHC.Exts
  77 import GHC.IOBase ( IO(IO) )
  78
  79 import Control.Monad
  80 import Data.Maybe
  81 import Data.Array.Base
  82 import Data.Ix
  83 import Data.List        ( partition )
  84 import qualified Data.Sequence as Seq
  85 import Data.Monoid
  86 import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
  87 import Foreign
  88 import System.IO.Unsafe
  89
  90 import System.IO
  91 ---------------------------------------------
  92 -- * A representation of semi evaluated Terms
  93 ---------------------------------------------
  94 {-
  95
  96 -}
  97
  98 data Term = Term { ty        :: Type
  99                  , dc        :: Either String DataCon
 100                                -- Carries a text representation if the datacon is
 101                                -- not exported by the .hi file, which is the case
 102                                -- for private constructors in -O0 compiled libraries
 103                  , val       :: HValue
 104                  , subTerms  :: [Term] }
 105
 106           | Prim { ty        :: Type
 107                  , value     :: [Word] }
 108
 109           | Suspension { ctype    :: ClosureType
 110                        , ty       :: Type
 111                        , val      :: HValue
 112                        , bound_to :: Maybe Name   -- Useful for printing
 113                        }
 114           | NewtypeWrap{ ty           :: Type
 115                        , dc           :: Either String DataCon
 116                        , wrapped_term :: Term }
 117           | RefWrap    { ty           :: Type
 118                        , wrapped_term :: Term }
 119
 120 isTerm, isSuspension, isPrim, isNewtypeWrap :: Term -> Bool
 121 isTerm Term{} = True
 122 isTerm   _    = False
 123 isSuspension Suspension{} = True
 124 isSuspension      _       = False
 125 isPrim Prim{} = True
 126 isPrim   _    = False
 127 isNewtypeWrap NewtypeWrap{} = True
 128 isNewtypeWrap _             = False
 129
 130 termType :: Term -> Type
 131 termType t = ty t
 132
 133 isFullyEvaluatedTerm :: Term -> Bool
 134 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
 135 isFullyEvaluatedTerm Prim {}            = True
 136 isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
 137 isFullyEvaluatedTerm RefWrap{wrapped_term=t}     = isFullyEvaluatedTerm t
 138 isFullyEvaluatedTerm _                  = False
 139
 140 instance Outputable (Term) where
 141  ppr t | Just doc <- cPprTerm cPprTermBase t = doc
 142        | otherwise = panic "Outputable Term instance"
 143
 144 -------------------------------------------------------------------------
 145 -- Runtime Closure Datatype and functions for retrieving closure related stuff
 146 -------------------------------------------------------------------------
 147 data ClosureType = Constr
 148                  | Fun
 149                  | Thunk Int
 150                  | ThunkSelector
 151                  | Blackhole
 152                  | AP
 153                  | PAP
 154                  | Indirection Int
 155                  | MutVar 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  | 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 amap' :: (t -> b) -> Array Int t -> [b]
 238 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
 239     where g (I# i#) = case indexArray# arr# i# of
 240                           (# e #) -> f e
 241
 242 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
 243 {-
 244 unsafeDeepSeq :: a -> b -> b
 245 unsafeDeepSeq = unsafeDeepSeq1 2
 246  where unsafeDeepSeq1 0 a b = seq a $! b
 247        unsafeDeepSeq1 i a b   -- 1st case avoids infinite loops for non reducible thunks
 248         | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
 249      -- | unsafePerformIO (isFullyEvaluated a) = b
 250         | otherwise = case unsafePerformIO (getClosureData a) of
 251                         closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
 252         where tipe = unsafePerformIO (getClosureType a)
 253 -}
 254 isPointed :: Type -> Bool
 255 isPointed t | Just (t, _) <- splitTyConApp_maybe t
 256             = not$ isUnliftedTypeKind (tyConKind t)
 257 isPointed _ = True
 258
 259 extractUnboxed  :: [Type] -> Closure -> [[Word]]
 260 extractUnboxed tt clos = go tt (nonPtrs clos)
 261    where sizeofType t
 262            | Just (tycon,_) <- splitTyConApp_maybe t
 263            = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
 264            | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
 265          go [] _ = []
 266          go (t:tt) xx
 267            | (x, rest) <- splitAt (sizeofType t) xx
 268            = x : go tt rest
 269
 270 sizeofTyCon :: TyCon -> Int -- in *words*
 271 sizeofTyCon = primRepSizeW . tyConPrimRep
 272
 273 -----------------------------------
 274 -- * Traversals for Terms
 275 -----------------------------------
 276 type TermProcessor a b = Type -> Either String DataCon -> HValue -> [a] -> b
 277
 278 data TermFold a = TermFold { fTerm        :: TermProcessor a a
 279                            , fPrim        :: Type -> [Word] -> a
 280                            , fSuspension  :: ClosureType -> Type -> HValue
 281                                             -> Maybe Name -> a
 282                            , fNewtypeWrap :: Type -> Either String DataCon
 283                                             -> a -> a
 284                            , fRefWrap     :: Type -> a -> a
 285                            }
 286
 287 foldTerm :: TermFold a -> Term -> a
 288 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
 289 foldTerm tf (Prim ty    v   ) = fPrim tf ty v
 290 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
 291 foldTerm tf (NewtypeWrap ty dc t)  = fNewtypeWrap tf ty dc (foldTerm tf t)
 292 foldTerm tf (RefWrap ty t)         = fRefWrap tf ty (foldTerm tf t)
 293
 294 idTermFold :: TermFold Term
 295 idTermFold = TermFold {
 296               fTerm = Term,
 297               fPrim = Prim,
 298               fSuspension  = Suspension,
 299               fNewtypeWrap = NewtypeWrap,
 300               fRefWrap = RefWrap
 301                       }
 302 idTermFoldM :: Monad m => TermFold (m Term)
 303 idTermFoldM = TermFold {
 304               fTerm       = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
 305               fPrim       = (return.). Prim,
 306               fSuspension = (((return.).).). Suspension,
 307               fNewtypeWrap= \ty dc t -> NewtypeWrap ty dc `liftM` t,
 308               fRefWrap    = \ty t -> RefWrap ty `liftM` t
 309                        }
 310
 311 mapTermType :: (Type -> Type) -> Term -> Term
 312 mapTermType f = foldTerm idTermFold {
 313           fTerm       = \ty dc hval tt -> Term (f ty) dc hval tt,
 314           fSuspension = \ct ty hval n ->
 315                           Suspension ct (f ty) hval n,
 316           fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
 317           fRefWrap    = \ty t -> RefWrap (f ty) t}
 318
 319 termTyVars :: Term -> TyVarSet
 320 termTyVars = foldTerm TermFold {
 321             fTerm       = \ty _ _ tt   ->
 322                           tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
 323             fSuspension = \_ ty _ _ -> tyVarsOfType ty,
 324             fPrim       = \ _ _ -> emptyVarEnv,
 325             fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t,
 326             fRefWrap    = \ty t -> tyVarsOfType ty `plusVarEnv` t}
 327     where concatVarEnv = foldr plusVarEnv emptyVarEnv
 328
 329 ----------------------------------
 330 -- Pretty printing of terms
 331 ----------------------------------
 332
 333 type Precedence        = Int
 334 type TermPrinter       = Precedence -> Term ->   SDoc
 335 type TermPrinterM m    = Precedence -> Term -> m SDoc
 336
 337 app_prec,cons_prec, max_prec ::Int
 338 max_prec  = 10
 339 app_prec  = max_prec
 340 cons_prec = 5 -- TODO Extract this info from GHC itself
 341
 342 pprTerm :: TermPrinter -> TermPrinter
 343 pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
 344 pprTerm _ _ _ = panic "pprTerm"
 345
 346 pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
 347 pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
 348
 349 ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
 350   tt_docs <- mapM (y app_prec) tt
 351   return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
 352
 353 ppr_termM y p Term{dc=Right dc, subTerms=tt}
 354 {-  | dataConIsInfix dc, (t1:t2:tt') <- tt  --TODO fixity
 355   = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
 356     <+> hsep (map (ppr_term1 True) tt)
 357 -} -- TODO Printing infix constructors properly
 358   | null tt   = return$ ppr dc
 359   | otherwise = do
 360          tt_docs <- mapM (y app_prec) tt
 361          return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
 362
 363 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
 364 ppr_termM y p RefWrap{wrapped_term=t}  = do
 365   contents <- y app_prec t
 366   return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
 367   -- The constructor name is wired in here ^^^ for the sake of simplicity.
 368   -- I don't think mutvars are going to change in a near future.
 369   -- In any case this is solely a presentation matter: MutVar# is
 370   -- a datatype with no constructors, implemented by the RTS
 371   -- (hence there is no way to obtain a datacon and print it).
 372 ppr_termM _ _ t = ppr_termM1 t
 373
 374
 375 ppr_termM1 :: Monad m => Term -> m SDoc
 376 ppr_termM1 Prim{value=words, ty=ty} =
 377     return$ text$ repPrim (tyConAppTyCon ty) words
 378 ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
 379 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
 380   | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit "<function>")
 381   | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
 382 ppr_termM1 Term{}        = panic "ppr_termM1 - Term"
 383 ppr_termM1 RefWrap{}     = panic "ppr_termM1 - RefWrap"
 384 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
 385
 386 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
 387   | Just (tc,_) <- splitNewTyConApp_maybe ty
 388   , ASSERT(isNewTyCon tc) True
 389   , Just new_dc <- tyConSingleDataCon_maybe tc = do
 390          real_term <- y max_prec t
 391          return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
 392 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
 393
 394 -------------------------------------------------------
 395 -- Custom Term Pretty Printers
 396 -------------------------------------------------------
 397
 398 -- We can want to customize the representation of a
 399 --  term depending on its type.
 400 -- However, note that custom printers have to work with
 401 --  type representations, instead of directly with types.
 402 -- We cannot use type classes here, unless we employ some
 403 --  typerep trickery (e.g. Weirich's RepLib tricks),
 404 --  which I didn't. Therefore, this code replicates a lot
 405 --  of what type classes provide for free.
 406
 407 type CustomTermPrinter m = TermPrinterM m
 408                          -> [Precedence -> Term -> (m (Maybe SDoc))]
 409
 410 -- | Takes a list of custom printers with a explicit recursion knot and a term,
 411 -- and returns the output of the first succesful printer, or the default printer
 412 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
 413 cPprTerm printers_ = go 0 where
 414   printers = printers_ go
 415   go prec t = do
 416     let default_ = Just `liftM` pprTermM go prec t
 417         mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
 418     Just doc <- firstJustM mb_customDocs
 419     return$ cparen (prec>app_prec+1) doc
 420
 421   firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
 422   firstJustM [] = return Nothing
 423
 424 -- Default set of custom printers. Note that the recursion knot is explicit
 425 cPprTermBase :: Monad m => CustomTermPrinter m
 426 cPprTermBase y =
 427   [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
 428                                       . mapM (y (-1))
 429                                       . subTerms)
 430   , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
 431            (\ p Term{subTerms=[h,t]} -> doList p h t)
 432   , ifTerm (isTyCon intTyCon    . ty) (coerceShow$ \(a::Int)->a)
 433   , ifTerm (isTyCon charTyCon   . ty) (coerceShow$ \(a::Char)->a)
 434   , ifTerm (isTyCon floatTyCon  . ty) (coerceShow$ \(a::Float)->a)
 435   , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
 436   , ifTerm (isIntegerTy         . ty) (coerceShow$ \(a::Integer)->a)
 437   ]
 438      where ifTerm pred f prec t@Term{}
 439                | pred t    = Just `liftM` f prec t
 440            ifTerm _ _ _ _  = return Nothing
 441
 442            isIntegerTy ty  = fromMaybe False $ do
 443              (tc,_) <- splitTyConApp_maybe ty
 444              return (tyConName tc == integerTyConName)
 445
 446            isTupleTy ty    = fromMaybe False $ do
 447              (tc,_) <- splitTyConApp_maybe ty
 448              return (isBoxedTupleTyCon tc)
 449
 450            isTyCon a_tc ty = fromMaybe False $ do
 451              (tc,_) <- splitTyConApp_maybe ty
 452              return (a_tc == tc)
 453
 454            coerceShow f _p = return . text . show . f . unsafeCoerce# . val
 455
 456            --Note pprinting of list terms is not lazy
 457            doList p h t = do
 458                let elems      = h : getListTerms t
 459                    isConsLast = not(termType(last elems) `coreEqType` termType h)
 460                print_elems <- mapM (y cons_prec) elems
 461                return$ if isConsLast
 462                      then cparen (p >= cons_prec)
 463                         . pprDeeperList fsep
 464                         . punctuate (space<>colon)
 465                         $ print_elems
 466                      else brackets (pprDeeperList fcat$
 467                                          punctuate comma print_elems)
 468
 469                 where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
 470                       getListTerms Term{subTerms=[]}    = []
 471                       getListTerms t@Suspension{}       = [t]
 472                       getListTerms t = pprPanic "getListTerms" (ppr t)
 473
 474
 475 repPrim :: TyCon -> [Word] -> String
 476 repPrim t = rep where
 477    rep x
 478     | t == charPrimTyCon   = show (build x :: Char)
 479     | t == intPrimTyCon    = show (build x :: Int)
 480     | t == wordPrimTyCon   = show (build x :: Word)
 481     | t == floatPrimTyCon  = show (build x :: Float)
 482     | t == doublePrimTyCon = show (build x :: Double)
 483     | t == int32PrimTyCon  = show (build x :: Int32)
 484     | t == word32PrimTyCon = show (build x :: Word32)
 485     | t == int64PrimTyCon  = show (build x :: Int64)
 486     | t == word64PrimTyCon = show (build x :: Word64)
 487     | t == addrPrimTyCon   = show (nullPtr `plusPtr` build x)
 488     | t == stablePtrPrimTyCon  = "<stablePtr>"
 489     | t == stableNamePrimTyCon = "<stableName>"
 490     | t == statePrimTyCon      = "<statethread>"
 491     | t == realWorldTyCon      = "<realworld>"
 492     | t == threadIdPrimTyCon   = "<ThreadId>"
 493     | t == weakPrimTyCon       = "<Weak>"
 494     | t == arrayPrimTyCon      = "<array>"
 495     | t == byteArrayPrimTyCon  = "<bytearray>"
 496     | t == mutableArrayPrimTyCon = "<mutableArray>"
 497     | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
 498     | t == mutVarPrimTyCon= "<mutVar>"
 499     | t == mVarPrimTyCon  = "<mVar>"
 500     | t == tVarPrimTyCon  = "<tVar>"
 501     | otherwise = showSDoc (char '<' <> ppr t <> char '>')
 502     where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
 503 --   This ^^^ relies on the representation of Haskell heap values being
 504 --   the same as in a C array.
 505
 506 -----------------------------------
 507 -- Type Reconstruction
 508 -----------------------------------
 509 {-
 510 Type Reconstruction is type inference done on heap closures.
 511 The algorithm walks the heap generating a set of equations, which
 512 are solved with syntactic unification.
 513 A type reconstruction equation looks like:
 514
 515   <datacon reptype>  =  <actual heap contents>
 516
 517 The full equation set is generated by traversing all the subterms, starting
 518 from a given term.
 519
 520 The only difficult part is that newtypes are only found in the lhs of equations.
 521 Right hand sides are missing them. We can either (a) drop them from the lhs, or
 522 (b) reconstruct them in the rhs when possible.
 523
 524 The function congruenceNewtypes takes a shot at (b)
 525 -}
 526
 527 -- The Type Reconstruction monad
 528 type TR a = TcM a
 529
 530 runTR :: HscEnv -> TR a -> IO a
 531 runTR hsc_env c = do
 532   mb_term <- runTR_maybe hsc_env c
 533   case mb_term of
 534     Nothing -> panic "Can't unify"
 535     Just x  -> return x
 536
 537 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
 538 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False  iNTERACTIVE
 539
 540 traceTR :: SDoc -> TR ()
 541 traceTR = liftTcM . traceTc
 542
 543 trIO :: IO a -> TR a
 544 trIO = liftTcM . liftIO
 545
 546 liftTcM :: TcM a -> TR a
 547 liftTcM = id
 548
 549 newVar :: Kind -> TR TcType
 550 newVar = liftTcM . fmap mkTyVarTy . newBoxyTyVar
 551
 552 -- | Returns the instantiated type scheme ty', and the substitution sigma
 553 --   such that sigma(ty') = ty
 554 instScheme :: Type -> TR (TcType, TvSubst)
 555 instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
 556    (tvs',_theta,ty') <- tcInstType (mapM tcInstTyVar) ty
 557    return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
 558
 559 -- Adds a constraint of the form t1 == t2
 560 -- t1 is expected to come from walking the heap
 561 -- t2 is expected to come from a datacon signature
 562 -- Before unification, congruenceNewtypes needs to
 563 -- do its magic.
 564 addConstraint :: TcType -> TcType -> TR ()
 565 addConstraint t1 t2  = congruenceNewtypes t1 t2 >>= uncurry boxyUnify
 566                        >> return () -- TOMDO: what about the coercion?
 567                                     -- we should consider family instances
 568
 569 -- Type & Term reconstruction
 570 cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
 571 cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
 572    tv <- newVar argTypeKind
 573    case mb_ty of
 574      Nothing ->      go bound tv tv hval
 575                 >>= zonkTerm
 576                 >>= return . expandNewtypes
 577      Just ty | isMonomorphic ty ->     go bound ty ty hval
 578                                    >>= zonkTerm
 579                                    >>= return . expandNewtypes
 580      Just ty -> do
 581               (ty',rev_subst) <- instScheme (sigmaType ty)
 582               addConstraint tv ty'
 583               term <- go bound tv tv hval >>= zonkTerm
 584               --restore original Tyvars
 585               return$ expandNewtypes $ mapTermType (substTy rev_subst) term
 586     where
 587   go bound _ _ _ | seq bound False = undefined
 588   go 0 tv _ty a = do
 589     clos <- trIO $ getClosureData a
 590     return (Suspension (tipe clos) tv a Nothing)
 591   go bound tv ty a = do
 592     let monomorphic = not(isTyVarTy tv)
 593     -- This ^^^ is a convention. The ancestor tests for
 594     -- monomorphism and passes a type instead of a tv
 595     clos <- trIO $ getClosureData a
 596     case tipe clos of
 597 -- Thunks we may want to force
 598 -- NB. this won't attempt to force a BLACKHOLE.  Even with :force, we never
 599 -- force blackholes, because it would almost certainly result in deadlock,
 600 -- and showing the '_' is more useful.
 601       t | isThunk t && force -> seq a $ go (pred bound) tv ty a
 602 -- We always follow indirections
 603       Indirection _ -> go bound tv ty $! (ptrs clos ! 0)
 604 -- We also follow references
 605       MutVar _ | Just (tycon,[world,ty_contents]) <- splitTyConApp_maybe ty
 606                 -- , tycon == mutVarPrimTyCon
 607              -> do
 608          contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
 609          tv' <- newVar liftedTypeKind
 610          addConstraint tv (mkTyConApp tycon [world,tv'])
 611          x <- go bound tv' ty_contents contents
 612          return (RefWrap ty x)
 613
 614  -- The interesting case
 615       Constr -> do
 616         Right dcname <- dataConInfoPtrToName (infoPtr clos)
 617         (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
 618         case mb_dc of
 619           Nothing -> do -- This can happen for private constructors compiled -O0
 620                         -- where the .hi descriptor does not export them
 621                         -- In such case, we return a best approximation:
 622                         --  ignore the unpointed args, and recover the pointeds
 623                         -- This preserves laziness, and should be safe.
 624                        let tag = showSDoc (ppr dcname)
 625                        vars     <- replicateM (length$ elems$ ptrs clos)
 626                                               (newVar (liftedTypeKind))
 627                        subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
 628                                               | (i, tv) <- zip [0..] vars]
 629                        return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
 630           Just dc -> do
 631             let extra_args = length(dataConRepArgTys dc) -
 632                              length(dataConOrigArgTys dc)
 633                 subTtypes  = matchSubTypes dc ty
 634                 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
 635             subTermTvs <- sequence
 636                  [ if isMonomorphic t then return t
 637                                       else (newVar k)
 638                    | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
 639             -- It is vital for newtype reconstruction that the unification step
 640             --  is done right here, _before_ the subterms are RTTI reconstructed
 641             when (not monomorphic) $ do
 642                   let myType = mkFunTys (reOrderTerms subTermTvs
 643                                                       subTtypesNP
 644                                                       subTtypes)
 645                                         tv
 646                   (signatureType,_) <- instScheme(dataConRepType dc)
 647                   addConstraint myType signatureType
 648             subTermsP <- sequence $ drop extra_args
 649                                 -- \^^^  all extra arguments are pointed
 650                   [ appArr (go (pred bound) tv t) (ptrs clos) i
 651                    | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
 652             let unboxeds   = extractUnboxed subTtypesNP clos
 653                 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
 654                 subTerms   = reOrderTerms subTermsP subTermsNP
 655                                 (drop extra_args subTtypes)
 656             return (Term tv (Right dc) a subTerms)
 657 -- The otherwise case: can be a Thunk,AP,PAP,etc.
 658       tipe_clos ->
 659          return (Suspension tipe_clos tv a Nothing)
 660
 661   matchSubTypes dc ty
 662     | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
 663 --     assumption:             ^^^ looks through newtypes
 664     , isVanillaDataCon dc  --TODO non-vanilla case
 665     = dataConInstArgTys dc ty_args
 666     | otherwise = dataConRepArgTys dc
 667
 668 -- This is used to put together pointed and nonpointed subterms in the
 669 --  correct order.
 670   reOrderTerms _ _ [] = []
 671   reOrderTerms pointed unpointed (ty:tys)
 672    | isPointed ty = ASSERT2(not(null pointed)
 673                             , ptext (sLit "reOrderTerms") $$
 674                                         (ppr pointed $$ ppr unpointed))
 675                     let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
 676    | otherwise    = ASSERT2(not(null unpointed)
 677                            , ptext (sLit "reOrderTerms") $$
 678                                        (ppr pointed $$ ppr unpointed))
 679                     let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
 680
 681   expandNewtypes t@Term{ ty=ty, subTerms=tt }
 682    | Just (tc, args) <- splitNewTyConApp_maybe ty
 683    , isNewTyCon tc
 684    , wrapped_type    <- newTyConInstRhs tc args
 685    , Just dc         <- tyConSingleDataCon_maybe tc
 686    , t'              <- expandNewtypes t{ ty = wrapped_type
 687                                         , subTerms = map expandNewtypes tt }
 688    = NewtypeWrap ty (Right dc) t'
 689
 690    | otherwise = t{ subTerms = map expandNewtypes tt }
 691
 692   expandNewtypes t = t
 693
 694
 695 -- Fast, breadth-first Type reconstruction
 696 cvReconstructType :: HscEnv -> Int -> Maybe Type -> HValue -> IO (Maybe Type)
 697 cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
 698    tv <- newVar argTypeKind
 699    case mb_ty of
 700      Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
 701                           (uncurry go)
 702                           (Seq.singleton (tv, hval))
 703                           max_depth
 704                    zonkTcType tv  -- TODO untested!
 705      Just ty | isMonomorphic ty -> return ty
 706      Just ty -> do
 707               (ty',rev_subst) <- instScheme (sigmaType ty)
 708               addConstraint tv ty'
 709               search (isMonomorphic `fmap` zonkTcType tv)
 710                      (\(ty,a) -> go ty a)
 711                      (Seq.singleton (tv, hval))
 712                      max_depth
 713               substTy rev_subst `fmap` zonkTcType tv
 714     where
 715 --  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
 716   search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
 717                                 int max_depth <> text " steps")
 718   search stop expand l d =
 719     case viewl l of
 720       EmptyL  -> return ()
 721       x :< xx -> unlessM stop $ do
 722                   new <- expand x
 723                   search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
 724
 725    -- returns unification tasks,since we are going to want a breadth-first search
 726   go :: Type -> HValue -> TR [(Type, HValue)]
 727   go tv a = do
 728     clos <- trIO $ getClosureData a
 729     case tipe clos of
 730       Indirection _ -> go tv $! (ptrs clos ! 0)
 731       MutVar _ -> do
 732          contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
 733          tv'   <- newVar liftedTypeKind
 734          world <- newVar liftedTypeKind
 735          addConstraint tv (mkTyConApp mutVarPrimTyCon [world,tv'])
 736 --         x <- go tv' ty_contents contents
 737          return [(tv', contents)]
 738       Constr -> do
 739         Right dcname <- dataConInfoPtrToName (infoPtr clos)
 740         (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
 741         case mb_dc of
 742           Nothing-> do
 743                      --  TODO: Check this case
 744             forM [0..length (elems $ ptrs clos)] $ \i -> do
 745                         tv <- newVar liftedTypeKind
 746                         return$ appArr (\e->(tv,e)) (ptrs clos) i
 747
 748           Just dc -> do
 749             let extra_args = length(dataConRepArgTys dc) -
 750                              length(dataConOrigArgTys dc)
 751             subTtypes <- mapMif (not . isMonomorphic)
 752                                 (\t -> newVar (typeKind t))
 753                                 (dataConRepArgTys dc)
 754
 755             -- It is vital for newtype reconstruction that the unification step
 756             -- is done right here, _before_ the subterms are RTTI reconstructed
 757             let myType         = mkFunTys subTtypes tv
 758             (signatureType,_) <- instScheme(dataConRepType dc)
 759             addConstraint myType signatureType
 760             return $ [ appArr (\e->(t,e)) (ptrs clos) i
 761                        | (i,t) <- drop extra_args $
 762                                      zip [0..] (filter isPointed subTtypes)]
 763       _ -> return []
 764
 765 -- Compute the difference between a base type and the type found by RTTI
 766 -- improveType <base_type> <rtti_type>
 767 -- The types can contain skolem type variables, which need to be treated as normal vars.
 768 -- In particular, we want them to unify with things.
 769 improveRTTIType :: HscEnv -> Type -> Type -> IO (Maybe TvSubst)
 770 improveRTTIType hsc_env ty rtti_ty = runTR_maybe hsc_env $ do
 771     let (_,ty0)     = splitForAllTys ty
 772         ty_tvs      = varSetElems $ tyVarsOfType ty0
 773     let (_,rtti_ty0)= splitForAllTys rtti_ty
 774         rtti_tvs    = varSetElems $ tyVarsOfType rtti_ty0
 775     (ty_tvs',_,ty')<- tcInstType (mapM tcInstTyVar) (mkSigmaTy ty_tvs   [] ty0)
 776     (_,_,rtti_ty') <- tcInstType (mapM tcInstTyVar) (mkSigmaTy rtti_tvs [] rtti_ty0)
 777     boxyUnify rtti_ty' ty'
 778     tvs1_contents  <- zonkTcTyVars ty_tvs'
 779     let subst = uncurry zipTopTvSubst
 780                   (unzip [(tv,ty) | tv <- ty_tvs, ty <- tvs1_contents
 781                                   , getTyVar_maybe ty /= Just tv
 782                                   , not(isTyVarTy ty)])
 783 --    liftIO $ hPutStrLn stderr $ showSDocDebug $ text "unify " <+> sep [ppr ty, ppr rtti_ty, equals, ppr subst ]
 784     return subst
 785
 786 -- Dealing with newtypes
 787 {-
 788  congruenceNewtypes does a parallel fold over two Type values,
 789  compensating for missing newtypes on both sides.
 790  This is necessary because newtypes are not present
 791  in runtime, but sometimes there is evidence available.
 792    Evidence can come from DataCon signatures or
 793  from compile-time type inference.
 794  What we are doing here is an approximation
 795  of unification modulo a set of equations derived
 796  from newtype definitions. These equations should be the
 797  same as the equality coercions generated for newtypes
 798  in System Fc. The idea is to perform a sort of rewriting,
 799  taking those equations as rules, before launching unification.
 800
 801  The caller must ensure the following.
 802  The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
 803  The 2nd type (rhs) comes from a DataCon type signature.
 804  Rewriting (i.e. adding/removing a newtype wrapper) can happen
 805  in both types, but in the rhs it is restricted to the result type.
 806
 807    Note that it is very tricky to make this 'rewriting'
 808  work with the unification implemented by TcM, where
 809  substitutions are operationally inlined. The order in which
 810  constraints are unified is vital as we cannot modify
 811  anything that has been touched by a previous unification step.
 812 Therefore, congruenceNewtypes is sound only if the types
 813 recovered by the RTTI mechanism are unified Top-Down.
 814 -}
 815 congruenceNewtypes ::  TcType -> TcType -> TR (TcType,TcType)
 816 congruenceNewtypes lhs rhs
 817  -- TyVar lhs inductive case
 818     | Just tv <- getTyVar_maybe lhs
 819     = recoverTc (return (lhs,rhs)) $ do
 820          Indirect ty_v <- readMetaTyVar tv
 821          (_lhs1, rhs1) <- congruenceNewtypes ty_v rhs
 822          return (lhs, rhs1)
 823 -- FunTy inductive case
 824     | Just (l1,l2) <- splitFunTy_maybe lhs
 825     , Just (r1,r2) <- splitFunTy_maybe rhs
 826     = do (l2',r2') <- congruenceNewtypes l2 r2
 827          (l1',r1') <- congruenceNewtypes l1 r1
 828          return (mkFunTy l1' l2', mkFunTy r1' r2')
 829 -- TyconApp Inductive case; this is the interesting bit.
 830     | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
 831     , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
 832     , tycon_l /= tycon_r
 833     = do rhs' <- upgrade tycon_l rhs
 834          return (lhs, rhs')
 835
 836     | otherwise = return (lhs,rhs)
 837
 838     where upgrade :: TyCon -> Type -> TR Type
 839           upgrade new_tycon ty
 840             | not (isNewTyCon new_tycon) = return ty
 841             | otherwise = do
 842                vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
 843                let ty' = mkTyConApp new_tycon vars
 844                liftTcM (unifyType ty (repType ty'))
 845         -- assumes that reptype doesn't ^^^^ touch tyconApp args
 846                return ty'
 847
 848
 849 --------------------------------------------------------------------------------
 850 -- Semantically different to recoverM in TcRnMonad
 851 -- recoverM retains the errors in the first action,
 852 --  whereas recoverTc here does not
 853 recoverTc :: TcM a -> TcM a -> TcM a
 854 recoverTc recover thing = do
 855   (_,mb_res) <- tryTcErrs thing
 856   case mb_res of
 857     Nothing  -> recover
 858     Just res -> return res
 859
 860 isMonomorphic :: Type -> Bool
 861 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
 862                  = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
 863
 864 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
 865 mapMif pred f xx = sequence $ mapMif_ pred f xx
 866   where
 867    mapMif_ _ _ []     = []
 868    mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
 869
 870 unlessM :: Monad m => m Bool -> m () -> m ()
 871 unlessM condM acc = condM >>= \c -> unless c acc
 872
 873 -- Strict application of f at index i
 874 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
 875 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
 876  = ASSERT (i < length(elems a))
 877    case indexArray# ptrs# i# of
 878        (# e #) -> f e
 879
 880 zonkTerm :: Term -> TcM Term
 881 zonkTerm = foldTerm idTermFoldM {
 882               fTerm = \ty dc v tt -> sequence tt      >>= \tt ->
 883                                      zonkTcType ty    >>= \ty' ->
 884                                      return (Term ty' dc v tt)
 885              ,fSuspension = \ct ty v b -> zonkTcType ty >>= \ty ->
 886                                           return (Suspension ct ty v b)
 887              ,fNewtypeWrap= \ty dc t ->
 888                    return NewtypeWrap `ap` zonkTcType ty `ap` return dc `ap` t}
 889
 890
 891 -- Is this defined elsewhere?
 892 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
 893 sigmaType :: Type -> Type
 894 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
 895
 896