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