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, ty=ty}  = do
 373   contents <- y app_prec t
 374   return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
 375   -- The constructor name is wired in here ^^^ for the sake of simplicity.
 376   -- I don't think mutvars are going to change in a near future.
 377   -- In any case this is solely a presentation matter: MutVar# is
 378   -- a datatype with no constructors, implemented by the RTS
 379   -- (hence there is no way to obtain a datacon and print it).
 380 ppr_termM _ _ t = ppr_termM1 t
 381
 382
 383 ppr_termM1 :: Monad m => Term -> m SDoc
 384 ppr_termM1 Prim{value=words, ty=ty} =
 385     return$ text$ repPrim (tyConAppTyCon ty) words
 386 ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
 387 ppr_termM1 Suspension{mb_ty=Just ty, bound_to=Just n}
 388   | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
 389   | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
 390 ppr_termM1 Suspension{}  = panic "ppr_termM1 - Suspension"
 391 ppr_termM1 Term{}        = panic "ppr_termM1 - Term"
 392 ppr_termM1 RefWrap{}     = panic "ppr_termM1 - RefWrap"
 393 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
 394
 395 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
 396   | Just (tc,_) <- splitNewTyConApp_maybe ty
 397   , ASSERT(isNewTyCon tc) True
 398   , Just new_dc <- maybeTyConSingleCon tc = do
 399          real_term <- y max_prec t
 400          return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
 401 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
 402
 403 -------------------------------------------------------
 404 -- Custom Term Pretty Printers
 405 -------------------------------------------------------
 406
 407 -- We can want to customize the representation of a
 408 --  term depending on its type.
 409 -- However, note that custom printers have to work with
 410 --  type representations, instead of directly with types.
 411 -- We cannot use type classes here, unless we employ some
 412 --  typerep trickery (e.g. Weirich's RepLib tricks),
 413 --  which I didn't. Therefore, this code replicates a lot
 414 --  of what type classes provide for free.
 415
 416 type CustomTermPrinter m = TermPrinterM m
 417                          -> [Precedence -> Term -> (m (Maybe SDoc))]
 418
 419 -- | Takes a list of custom printers with a explicit recursion knot and a term,
 420 -- and returns the output of the first succesful printer, or the default printer
 421 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
 422 cPprTerm printers_ = go 0 where
 423   printers = printers_ go
 424   go prec t = do
 425     let default_ = Just `liftM` pprTermM go prec t
 426         mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
 427     Just doc <- firstJustM mb_customDocs
 428     return$ cparen (prec>app_prec+1) doc
 429
 430   firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
 431   firstJustM [] = return Nothing
 432
 433 -- Default set of custom printers. Note that the recursion knot is explicit
 434 cPprTermBase :: Monad m => CustomTermPrinter m
 435 cPprTermBase y =
 436   [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
 437                                       . mapM (y (-1))
 438                                       . subTerms)
 439   , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
 440            (\ p Term{subTerms=[h,t]} -> doList p h t)
 441   , ifTerm (isTyCon intTyCon    . ty) (coerceShow$ \(a::Int)->a)
 442   , ifTerm (isTyCon charTyCon   . ty) (coerceShow$ \(a::Char)->a)
 443   , ifTerm (isTyCon floatTyCon  . ty) (coerceShow$ \(a::Float)->a)
 444   , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
 445   , ifTerm (isIntegerTy         . ty) (coerceShow$ \(a::Integer)->a)
 446   ]
 447      where ifTerm pred f prec t@Term{}
 448                | pred t    = Just `liftM` f prec t
 449            ifTerm _ _ _ _  = return Nothing
 450
 451            isIntegerTy ty  = fromMaybe False $ do
 452              (tc,_) <- splitTyConApp_maybe ty
 453              return (tyConName tc == integerTyConName)
 454
 455            isTupleTy ty    = fromMaybe False $ do
 456              (tc,_) <- splitTyConApp_maybe ty
 457              return (tc `elem` (fst.unzip.elems) boxedTupleArr)
 458
 459            isTyCon a_tc ty = fromMaybe False $ do
 460              (tc,_) <- splitTyConApp_maybe ty
 461              return (a_tc == tc)
 462
 463            coerceShow f _p = return . text . show . f . unsafeCoerce# . val
 464
 465            --Note pprinting of list terms is not lazy
 466            doList p h t = do
 467                let elems      = h : getListTerms t
 468                    isConsLast = termType(last elems) /= termType h
 469                print_elems <- mapM (y cons_prec) elems
 470                return$ if isConsLast
 471                      then cparen (p >= cons_prec)
 472                         . pprDeeperList fsep
 473                         . punctuate (space<>colon)
 474                         $ print_elems
 475                      else brackets (pprDeeperList fcat$
 476                                          punctuate comma print_elems)
 477
 478                 where Just a /= Just b = not (a `coreEqType` b)
 479                       _      /=   _    = True
 480                       getListTerms Term{subTerms=[h,t]} = h : getListTerms t
 481                       getListTerms Term{subTerms=[]}    = []
 482                       getListTerms t@Suspension{}       = [t]
 483                       getListTerms t = pprPanic "getListTerms" (ppr t)
 484
 485
 486 repPrim :: TyCon -> [Word] -> String
 487 repPrim t = rep where
 488    rep x
 489     | t == charPrimTyCon   = show (build x :: Char)
 490     | t == intPrimTyCon    = show (build x :: Int)
 491     | t == wordPrimTyCon   = show (build x :: Word)
 492     | t == floatPrimTyCon  = show (build x :: Float)
 493     | t == doublePrimTyCon = show (build x :: Double)
 494     | t == int32PrimTyCon  = show (build x :: Int32)
 495     | t == word32PrimTyCon = show (build x :: Word32)
 496     | t == int64PrimTyCon  = show (build x :: Int64)
 497     | t == word64PrimTyCon = show (build x :: Word64)
 498     | t == addrPrimTyCon   = show (nullPtr `plusPtr` build x)
 499     | t == stablePtrPrimTyCon  = "<stablePtr>"
 500     | t == stableNamePrimTyCon = "<stableName>"
 501     | t == statePrimTyCon      = "<statethread>"
 502     | t == realWorldTyCon      = "<realworld>"
 503     | t == threadIdPrimTyCon   = "<ThreadId>"
 504     | t == weakPrimTyCon       = "<Weak>"
 505     | t == arrayPrimTyCon      = "<array>"
 506     | t == byteArrayPrimTyCon  = "<bytearray>"
 507     | t == mutableArrayPrimTyCon = "<mutableArray>"
 508     | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
 509     | t == mutVarPrimTyCon= "<mutVar>"
 510     | t == mVarPrimTyCon  = "<mVar>"
 511     | t == tVarPrimTyCon  = "<tVar>"
 512     | otherwise = showSDoc (char '<' <> ppr t <> char '>')
 513     where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
 514 --   This ^^^ relies on the representation of Haskell heap values being
 515 --   the same as in a C array.
 516
 517 -----------------------------------
 518 -- Type Reconstruction
 519 -----------------------------------
 520 {-
 521 Type Reconstruction is type inference done on heap closures.
 522 The algorithm walks the heap generating a set of equations, which
 523 are solved with syntactic unification.
 524 A type reconstruction equation looks like:
 525
 526   <datacon reptype>  =  <actual heap contents>
 527
 528 The full equation set is generated by traversing all the subterms, starting
 529 from a given term.
 530
 531 The only difficult part is that newtypes are only found in the lhs of equations.
 532 Right hand sides are missing them. We can either (a) drop them from the lhs, or
 533 (b) reconstruct them in the rhs when possible.
 534
 535 The function congruenceNewtypes takes a shot at (b)
 536 -}
 537
 538 -- The Type Reconstruction monad
 539 type TR a = TcM a
 540
 541 runTR :: HscEnv -> TR a -> IO a
 542 runTR hsc_env c = do
 543   mb_term <- runTR_maybe hsc_env c
 544   case mb_term of
 545     Nothing -> panic "Can't unify"
 546     Just x  -> return x
 547
 548 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
 549 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
 550
 551 traceTR :: SDoc -> TR ()
 552 traceTR = liftTcM . traceTc
 553
 554 trIO :: IO a -> TR a
 555 trIO = liftTcM . ioToTcRn
 556
 557 liftTcM :: TcM a -> TR a
 558 liftTcM = id
 559
 560 newVar :: Kind -> TR TcType
 561 newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
 562
 563 -- | Returns the instantiated type scheme ty', and the substitution sigma
 564 --   such that sigma(ty') = ty
 565 instScheme :: Type -> TR (TcType, TvSubst)
 566 instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
 567    (tvs',_theta,ty') <- tcInstType (mapM tcInstTyVar) ty
 568    return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
 569
 570 -- Adds a constraint of the form t1 == t2
 571 -- t1 is expected to come from walking the heap
 572 -- t2 is expected to come from a datacon signature
 573 -- Before unification, congruenceNewtypes needs to
 574 -- do its magic.
 575 addConstraint :: TcType -> TcType -> TR ()
 576 addConstraint t1 t2  = congruenceNewtypes t1 t2 >>= uncurry unifyType
 577                        >> return () -- TOMDO: what about the coercion?
 578                                     -- we should consider family instances
 579
 580 -- Type & Term reconstruction
 581 cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
 582 cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
 583    tv <- newVar argTypeKind
 584    case mb_ty of
 585      Nothing ->      go bound tv tv hval
 586                 >>= zonkTerm
 587                 >>= return . expandNewtypes
 588      Just ty | isMonomorphic ty ->     go bound ty ty hval
 589                                    >>= zonkTerm
 590                                    >>= return . expandNewtypes
 591      Just ty -> do
 592               (ty',rev_subst) <- instScheme (sigmaType ty)
 593               addConstraint tv ty'
 594               term <- go bound tv tv hval >>= zonkTerm
 595               --restore original Tyvars
 596               return$ expandNewtypes $ mapTermType (substTy rev_subst) term
 597     where
 598   go bound _ _ _ | seq bound False = undefined
 599   go 0 tv _ty a = do
 600     clos <- trIO $ getClosureData a
 601     return (Suspension (tipe clos) (Just tv) a Nothing)
 602   go bound tv ty a = do
 603     let monomorphic = not(isTyVarTy tv)
 604     -- This ^^^ is a convention. The ancestor tests for
 605     -- monomorphism and passes a type instead of a tv
 606     clos <- trIO $ getClosureData a
 607     case tipe clos of
 608 -- Thunks we may want to force
 609 -- NB. this won't attempt to force a BLACKHOLE.  Even with :force, we never
 610 -- force blackholes, because it would almost certainly result in deadlock,
 611 -- and showing the '_' is more useful.
 612       t | isThunk t && force -> seq a $ go (pred bound) tv ty a
 613 -- We always follow indirections
 614       Indirection _ -> go bound tv ty $! (ptrs clos ! 0)
 615 -- We also follow references
 616       MutVar _ | Just (tycon,[world,ty_contents]) <- splitTyConApp_maybe ty
 617                 -- , tycon == mutVarPrimTyCon
 618              -> do
 619          contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
 620          tv' <- newVar liftedTypeKind
 621          addConstraint tv (mkTyConApp tycon [world,tv'])
 622          x <- go bound tv' ty_contents contents
 623          return (RefWrap ty x)
 624
 625  -- The interesting case
 626       Constr -> do
 627         Right dcname <- dataConInfoPtrToName (infoPtr clos)
 628         (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
 629         case mb_dc of
 630           Nothing -> do -- This can happen for private constructors compiled -O0
 631                         -- where the .hi descriptor does not export them
 632                         -- In such case, we return a best approximation:
 633                         --  ignore the unpointed args, and recover the pointeds
 634                         -- This preserves laziness, and should be safe.
 635                        let tag = showSDoc (ppr dcname)
 636                        vars     <- replicateM (length$ elems$ ptrs clos)
 637                                               (newVar (liftedTypeKind))
 638                        subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
 639                                               | (i, tv) <- zip [0..] vars]
 640                        return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
 641           Just dc -> do
 642             let extra_args = length(dataConRepArgTys dc) -
 643                              length(dataConOrigArgTys dc)
 644                 subTtypes  = matchSubTypes dc ty
 645                 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
 646             subTermTvs <- sequence
 647                  [ if isMonomorphic t then return t
 648                                       else (newVar k)
 649                    | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
 650             -- It is vital for newtype reconstruction that the unification step
 651             --  is done right here, _before_ the subterms are RTTI reconstructed
 652             when (not monomorphic) $ do
 653                   let myType = mkFunTys (reOrderTerms subTermTvs
 654                                                       subTtypesNP
 655                                                       subTtypes)
 656                                         tv
 657                   (signatureType,_) <- instScheme(dataConRepType dc)
 658                   addConstraint myType signatureType
 659             subTermsP <- sequence $ drop extra_args
 660                                  -- ^^^  all extra arguments are pointed
 661                   [ appArr (go (pred bound) tv t) (ptrs clos) i
 662                    | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
 663             let unboxeds   = extractUnboxed subTtypesNP clos
 664                 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
 665                 subTerms   = reOrderTerms subTermsP subTermsNP
 666                                 (drop extra_args subTtypes)
 667             return (Term tv (Right dc) a subTerms)
 668 -- The otherwise case: can be a Thunk,AP,PAP,etc.
 669       tipe_clos ->
 670          return (Suspension tipe_clos (Just tv) a Nothing)
 671
 672   matchSubTypes dc ty
 673     | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
 674 --     assumption:             ^^^ looks through newtypes
 675     , isVanillaDataCon dc  --TODO non-vanilla case
 676     = dataConInstArgTys dc ty_args
 677     | otherwise = dataConRepArgTys dc
 678
 679 -- This is used to put together pointed and nonpointed subterms in the
 680 --  correct order.
 681   reOrderTerms _ _ [] = []
 682   reOrderTerms pointed unpointed (ty:tys)
 683    | isPointed ty = ASSERT2(not(null pointed)
 684                             , ptext SLIT("reOrderTerms") $$
 685                                         (ppr pointed $$ ppr unpointed))
 686                     let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
 687    | otherwise    = ASSERT2(not(null unpointed)
 688                            , ptext SLIT("reOrderTerms") $$
 689                                        (ppr pointed $$ ppr unpointed))
 690                     let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
 691
 692   expandNewtypes t@Term{ ty=ty, subTerms=tt }
 693    | Just (tc, args) <- splitNewTyConApp_maybe ty
 694    , isNewTyCon tc
 695    , wrapped_type    <- newTyConInstRhs tc args
 696    , Just dc         <- maybeTyConSingleCon tc
 697    , t'              <- expandNewtypes t{ ty = wrapped_type
 698                                         , subTerms = map expandNewtypes tt }
 699    = NewtypeWrap ty (Right dc) t'
 700
 701    | otherwise = t{ subTerms = map expandNewtypes tt }
 702
 703   expandNewtypes t = t
 704
 705
 706 -- Fast, breadth-first Type reconstruction
 707 cvReconstructType :: HscEnv -> Int -> Maybe Type -> HValue -> IO (Maybe Type)
 708 cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
 709    tv <- newVar argTypeKind
 710    case mb_ty of
 711      Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
 712                           (uncurry go)
 713                           (Seq.singleton (tv, hval))
 714                           max_depth
 715                    zonkTcType tv  -- TODO untested!
 716      Just ty | isMonomorphic ty -> return ty
 717      Just ty -> do
 718               (ty',rev_subst) <- instScheme (sigmaType ty)
 719               addConstraint tv ty'
 720               search (isMonomorphic `fmap` zonkTcType tv)
 721                      (\(ty,a) -> go ty a)
 722                      (Seq.singleton (tv, hval))
 723                      max_depth
 724               substTy rev_subst `fmap` zonkTcType tv
 725     where
 726 --  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
 727   search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
 728                                 int max_depth <> text " steps")
 729   search stop expand l d =
 730     case viewl l of
 731       EmptyL  -> return ()
 732       x :< xx -> unlessM stop $ do
 733                   new <- expand x
 734                   search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
 735
 736    -- returns unification tasks,since we are going to want a breadth-first search
 737   go :: Type -> HValue -> TR [(Type, HValue)]
 738   go tv a = do
 739     clos <- trIO $ getClosureData a
 740     case tipe clos of
 741       Indirection _ -> go tv $! (ptrs clos ! 0)
 742       MutVar _ -> do
 743          contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
 744          tv'   <- newVar liftedTypeKind
 745          world <- newVar liftedTypeKind
 746          addConstraint tv (mkTyConApp mutVarPrimTyCon [world,tv'])
 747 --         x <- go tv' ty_contents contents
 748          return [(tv', contents)]
 749       Constr -> do
 750         Right dcname <- dataConInfoPtrToName (infoPtr clos)
 751         (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
 752         case mb_dc of
 753           Nothing-> do
 754                      --  TODO: Check this case
 755             forM [0..length (elems $ ptrs clos)] $ \i -> do
 756                         tv <- newVar liftedTypeKind
 757                         return$ appArr (\e->(tv,e)) (ptrs clos) i
 758
 759           Just dc -> do
 760             let extra_args = length(dataConRepArgTys dc) -
 761                              length(dataConOrigArgTys dc)
 762             subTtypes <- mapMif (not . isMonomorphic)
 763                                 (\t -> newVar (typeKind t))
 764                                 (dataConRepArgTys dc)
 765
 766             -- It is vital for newtype reconstruction that the unification step
 767             -- is done right here, _before_ the subterms are RTTI reconstructed
 768             let myType         = mkFunTys subTtypes tv
 769             (signatureType,_) <- instScheme(dataConRepType dc)
 770             addConstraint myType signatureType
 771             return $ [ appArr (\e->(t,e)) (ptrs clos) i
 772                        | (i,t) <- drop extra_args $
 773                                      zip [0..] (filter isPointed subTtypes)]
 774       _ -> return []
 775
 776      -- This helper computes the difference between a base type t and the
 777      -- improved rtti_t computed by RTTI
 778      -- The main difference between RTTI types and their normal counterparts
 779      --  is that the former are _not_ polymorphic, thus polymorphism must
 780      --  be stripped. Syntactically, forall's must be stripped.
 781      -- We also remove predicates.
 782 unifyRTTI :: Type -> Type -> TvSubst
 783 unifyRTTI ty rtti_ty =
 784     case mb_subst of
 785       Just subst -> subst
 786       Nothing    -> pprPanic "Failed to compute a RTTI substitution"
 787                              (ppr (ty, rtti_ty))
 788      -- In addition, we strip newtypes too, since the reconstructed type might
 789      --   not have recovered them all
 790      -- TODO stripping newtypes shouldn't be necessary, test
 791    where mb_subst = tcUnifyTys (const BindMe)
 792                                [rttiView ty]
 793                                [rttiView rtti_ty]
 794
 795 -- Dealing with newtypes
 796 {-
 797    A parallel fold over two Type values,
 798  compensating for missing newtypes on both sides.
 799  This is necessary because newtypes are not present
 800  in runtime, but since sometimes there is evidence
 801  available we do our best to reconstruct them.
 802    Evidence can come from DataCon signatures or
 803  from compile-time type inference.
 804    I am using the words congruence and rewriting
 805  because what we are doing here is an approximation
 806  of unification modulo a set of equations, which would
 807  come from newtype definitions. These should be the
 808  equality coercions seen in System Fc. Rewriting
 809  is performed, taking those equations as rules,
 810  before launching unification.
 811
 812    It doesn't make sense to rewrite everywhere,
 813  or we would end up with all newtypes. So we rewrite
 814  only in presence of evidence.
 815    The lhs comes from the heap structure of ptrs,nptrs.
 816    The rhs comes from a DataCon type signature.
 817  Rewriting in the rhs is restricted to the result type.
 818
 819    Note that it is very tricky to make this 'rewriting'
 820  work with the unification implemented by TcM, where
 821  substitutions are 'inlined'. The order in which
 822  constraints are unified is vital for this.
 823    This is a simple form of residuation, the technique of
 824  delaying unification steps until enough information
 825  is available.
 826 -}
 827 congruenceNewtypes ::  TcType -> TcType -> TR (TcType,TcType)
 828 congruenceNewtypes lhs rhs
 829  -- TyVar lhs inductive case
 830     | Just tv <- getTyVar_maybe lhs
 831     = recoverTc (return (lhs,rhs)) $ do
 832          Indirect ty_v <- readMetaTyVar tv
 833          (_lhs1, rhs1) <- congruenceNewtypes ty_v rhs
 834          return (lhs, rhs1)
 835 -- FunTy inductive case
 836     | Just (l1,l2) <- splitFunTy_maybe lhs
 837     , Just (r1,r2) <- splitFunTy_maybe rhs
 838     = do (l2',r2') <- congruenceNewtypes l2 r2
 839          (l1',r1') <- congruenceNewtypes l1 r1
 840          return (mkFunTy l1' l2', mkFunTy r1' r2')
 841 -- TyconApp Inductive case; this is the interesting bit.
 842     | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
 843     , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
 844     , tycon_l /= tycon_r
 845     = do rhs' <- upgrade tycon_l rhs
 846          return (lhs, rhs')
 847
 848     | otherwise = return (lhs,rhs)
 849
 850     where upgrade :: TyCon -> Type -> TR Type
 851           upgrade new_tycon ty
 852             | not (isNewTyCon new_tycon) = return ty
 853             | otherwise = do
 854                vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
 855                let ty' = mkTyConApp new_tycon vars
 856                liftTcM (unifyType ty (repType ty'))
 857         -- assumes that reptype doesn't ^^^^ touch tyconApp args
 858                return ty'
 859
 860
 861 --------------------------------------------------------------------------------
 862 -- Semantically different to recoverM in TcRnMonad
 863 -- recoverM retains the errors in the first action,
 864 --  whereas recoverTc here does not
 865 recoverTc :: TcM a -> TcM a -> TcM a
 866 recoverTc recover thing = do
 867   (_,mb_res) <- tryTcErrs thing
 868   case mb_res of
 869     Nothing  -> recover
 870     Just res -> return res
 871
 872 isMonomorphic :: Type -> Bool
 873 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
 874                  = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
 875
 876 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
 877 mapMif pred f xx = sequence $ mapMif_ pred f xx
 878   where
 879    mapMif_ _ _ []     = []
 880    mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
 881
 882 unlessM :: Monad m => m Bool -> m () -> m ()
 883 unlessM condM acc = condM >>= \c -> unless c acc
 884
 885 -- Strict application of f at index i
 886 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
 887 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
 888  = ASSERT (i < length(elems a))
 889    case indexArray# ptrs# i# of
 890        (# e #) -> f e
 891
 892 zonkTerm :: Term -> TcM Term
 893 zonkTerm = foldTerm idTermFoldM {
 894               fTerm = \ty dc v tt -> sequence tt      >>= \tt ->
 895                                      zonkTcType ty    >>= \ty' ->
 896                                      return (Term ty' dc v tt)
 897              ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
 898                                           return (Suspension ct ty v b)
 899              ,fNewtypeWrap= \ty dc t ->
 900                    return NewtypeWrap `ap` zonkTcType ty `ap` return dc `ap` t}
 901
 902
 903 -- Is this defined elsewhere?
 904 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
 905 sigmaType :: Type -> Type
 906 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
 907
 908