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