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