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 -> Bool -> Maybe Type -> HValue -> IO Term
  12
  13      Term(..),
  14      pprTerm,
  15      cPprTerm,
  16      cPprTermBase,
  17      termType,
  18      foldTerm,
  19      TermFold(..),
  20      idTermFold,
  21      idTermFoldM,
  22      isFullyEvaluated,
  23      isPointed,
  24      isFullyEvaluatedTerm,
  25      mapTermType,
  26      termTyVars,
  27 --     unsafeDeepSeq,
  28      cvReconstructType
  29  ) where
  30
  31 #include "HsVersions.h"
  32
  33 import ByteCodeItbls    ( StgInfoTable )
  34 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
  35 import ByteCodeLink     ( HValue )
  36 import HscTypes         ( HscEnv )
  37
  38 import DataCon
  39 import Type
  40 import TcRnMonad        ( TcM, initTcPrintErrors, ioToTcRn, recoverM)
  41 import TcType
  42 import TcMType
  43 import TcUnify
  44 import TcGadt
  45 import TcEnv
  46 import TyCon
  47 import Var
  48 import Name
  49 import VarEnv
  50 import OccName
  51 import Util
  52 import VarSet
  53 import {-#SOURCE#-} TcRnDriver ( tcRnRecoverDataCon )
  54
  55 import TysPrim
  56 import PrelNames
  57 import TysWiredIn
  58
  59 import Constants
  60 import Outputable
  61 import Maybes
  62 import Panic
  63 import FiniteMap
  64
  65 import GHC.Arr          ( Array(..) )
  66 import GHC.Ptr          ( Ptr(..), castPtr )
  67 import GHC.Exts
  68
  69 import Control.Monad
  70 import Data.Maybe
  71 import Data.Array.Base
  72 import Data.List        ( partition, nub )
  73 import Foreign
  74 import System.IO.Unsafe
  75
  76 ---------------------------------------------
  77 -- * A representation of semi evaluated Terms
  78 ---------------------------------------------
  79 {-
  80   A few examples in this representation:
  81
  82   > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
  83
  84   > (('a',_,_),_,('b',_,_)) =
  85       Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
  86           [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
  87           , Suspension
  88           , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
  89 -}
  90
  91 data Term = Term { ty        :: Type
  92                  , dc        :: DataCon  -- The heap datacon. If ty is a newtype,
  93                                          -- this is NOT the newtype datacon
  94                  , val       :: HValue
  95                  , subTerms  :: [Term] }
  96
  97           | Prim { ty        :: Type
  98                  , value     :: [Word] }
  99
 100           | Suspension { ctype    :: ClosureType
 101                        , mb_ty    :: Maybe Type
 102                        , val      :: HValue
 103                        , bound_to :: Maybe Name   -- Useful for printing
 104                        }
 105
 106 isTerm, isSuspension, isPrim :: Term -> Bool
 107 isTerm Term{} = True
 108 isTerm   _    = False
 109 isSuspension Suspension{} = True
 110 isSuspension      _       = False
 111 isPrim Prim{} = True
 112 isPrim   _    = False
 113
 114 termType :: Term -> Maybe Type
 115 termType t@(Suspension {}) = mb_ty t
 116 termType t = Just$ ty t
 117
 118 isFullyEvaluatedTerm :: Term -> Bool
 119 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
 120 isFullyEvaluatedTerm Suspension {}      = False
 121 isFullyEvaluatedTerm Prim {}            = True
 122
 123 instance Outputable (Term) where
 124  ppr = head . cPprTerm cPprTermBase
 125
 126 -------------------------------------------------------------------------
 127 -- Runtime Closure Datatype and functions for retrieving closure related stuff
 128 -------------------------------------------------------------------------
 129 data ClosureType = Constr
 130                  | Fun
 131                  | Thunk Int
 132                  | ThunkSelector
 133                  | Blackhole
 134                  | AP
 135                  | PAP
 136                  | Indirection Int
 137                  | Other Int
 138  deriving (Show, Eq)
 139
 140 data Closure = Closure { tipe         :: ClosureType
 141                        , infoPtr      :: Ptr ()
 142                        , infoTable    :: StgInfoTable
 143                        , ptrs         :: Array Int HValue
 144                        , nonPtrs      :: [Word]
 145                        }
 146
 147 instance Outputable ClosureType where
 148   ppr = text . show
 149
 150 #include "../includes/ClosureTypes.h"
 151
 152 aP_CODE = AP
 153 pAP_CODE = PAP
 154 #undef AP
 155 #undef PAP
 156
 157 getClosureData :: a -> IO Closure
 158 getClosureData a =
 159    case unpackClosure# a of
 160      (# iptr, ptrs, nptrs #) -> do
 161            itbl <- peek (Ptr iptr)
 162            let tipe = readCType (BCI.tipe itbl)
 163                elems = BCI.ptrs itbl
 164                ptrsList = Array 0 (fromIntegral$ elems) ptrs
 165                nptrs_data = [W# (indexWordArray# nptrs i)
 166                               | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
 167            ptrsList `seq`
 168             return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
 169
 170 readCType :: Integral a => a -> ClosureType
 171 readCType i
 172  | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
 173  | i >= FUN    && i <= FUN_STATIC          = Fun
 174  | i >= THUNK  && i < THUNK_SELECTOR       = Thunk (fromIntegral i)
 175  | i == THUNK_SELECTOR                     = ThunkSelector
 176  | i == BLACKHOLE                          = Blackhole
 177  | i >= IND    && i <= IND_STATIC          = Indirection (fromIntegral i)
 178  | fromIntegral i == aP_CODE               = AP
 179  | i == AP_STACK                           = AP
 180  | fromIntegral i == pAP_CODE              = PAP
 181  | otherwise                               = Other (fromIntegral i)
 182
 183 isConstr, isIndirection, isThunk :: ClosureType -> Bool
 184 isConstr Constr = True
 185 isConstr    _   = False
 186
 187 isIndirection (Indirection _) = True
 188 --isIndirection ThunkSelector = True
 189 isIndirection _ = False
 190
 191 isThunk (Thunk _)     = True
 192 isThunk ThunkSelector = True
 193 isThunk AP            = True
 194 isThunk _             = False
 195
 196 isFullyEvaluated :: a -> IO Bool
 197 isFullyEvaluated a = do
 198   closure <- getClosureData a
 199   case tipe closure of
 200     Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
 201                  return$ and are_subs_evaluated
 202     otherwise -> return False
 203   where amapM f = sequence . amap' f
 204
 205 amap' f (Array i0 i arr#) = map (\(I# i#) -> case indexArray# arr# i# of
 206                                    (# e #) -> f e)
 207                                 [0 .. i - i0]
 208
 209 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
 210 {-
 211 unsafeDeepSeq :: a -> b -> b
 212 unsafeDeepSeq = unsafeDeepSeq1 2
 213  where unsafeDeepSeq1 0 a b = seq a $! b
 214        unsafeDeepSeq1 i a b   -- 1st case avoids infinite loops for non reducible thunks
 215         | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
 216      -- | unsafePerformIO (isFullyEvaluated a) = b
 217         | otherwise = case unsafePerformIO (getClosureData a) of
 218                         closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
 219         where tipe = unsafePerformIO (getClosureType a)
 220 -}
 221 isPointed :: Type -> Bool
 222 isPointed t | Just (t, _) <- splitTyConApp_maybe t
 223             = not$ isUnliftedTypeKind (tyConKind t)
 224 isPointed _ = True
 225
 226 extractUnboxed  :: [Type] -> Closure -> [[Word]]
 227 extractUnboxed tt clos = go tt (nonPtrs clos)
 228    where sizeofType t
 229            | Just (tycon,_) <- splitTyConApp_maybe t
 230            = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
 231            | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
 232          go [] _ = []
 233          go (t:tt) xx
 234            | (x, rest) <- splitAt (sizeofType t `div` wORD_SIZE) xx
 235            = x : go tt rest
 236
 237 sizeofTyCon = sizeofPrimRep . tyConPrimRep
 238
 239 -----------------------------------
 240 -- * Traversals for Terms
 241 -----------------------------------
 242
 243 data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a
 244                            , fPrim :: Type -> [Word] -> a
 245                            , fSuspension :: ClosureType -> Maybe Type -> HValue
 246                                            -> Maybe Name -> a
 247                            }
 248
 249 foldTerm :: TermFold a -> Term -> a
 250 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
 251 foldTerm tf (Prim ty    v   ) = fPrim tf ty v
 252 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
 253
 254 idTermFold :: TermFold Term
 255 idTermFold = TermFold {
 256               fTerm = Term,
 257               fPrim = Prim,
 258               fSuspension = Suspension
 259                       }
 260 idTermFoldM :: Monad m => TermFold (m Term)
 261 idTermFoldM = TermFold {
 262               fTerm       = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
 263               fPrim       = (return.). Prim,
 264               fSuspension = (((return.).).). Suspension
 265                        }
 266
 267 mapTermType :: (Type -> Type) -> Term -> Term
 268 mapTermType f = foldTerm idTermFold {
 269           fTerm       = \ty dc hval tt -> Term (f ty) dc hval tt,
 270           fSuspension = \ct mb_ty hval n ->
 271                           Suspension ct (fmap f mb_ty) hval n }
 272
 273 termTyVars :: Term -> TyVarSet
 274 termTyVars = foldTerm TermFold {
 275             fTerm       = \ty _ _ tt   ->
 276                           tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
 277             fSuspension = \_ mb_ty _ _ ->
 278                           maybe emptyVarEnv tyVarsOfType mb_ty,
 279             fPrim       = \ _ _ -> emptyVarEnv }
 280     where concatVarEnv = foldr plusVarEnv emptyVarEnv
 281 ----------------------------------
 282 -- Pretty printing of terms
 283 ----------------------------------
 284
 285 app_prec,cons_prec ::Int
 286 app_prec = 10
 287 cons_prec = 5 -- TODO Extract this info from GHC itself
 288
 289 pprTerm y p t | Just doc <- pprTermM y p t = doc
 290
 291 pprTermM :: Monad m => (Int -> Term -> m SDoc) -> Int -> Term -> m SDoc
 292 pprTermM y p t@Term{dc=dc, subTerms=tt, ty=ty}
 293 {-  | dataConIsInfix dc, (t1:t2:tt') <- tt  --TODO fixity
 294   = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2)
 295     <+> hsep (map (pprTerm1 True) tt)
 296 -}
 297   | null tt   = return$ ppr dc
 298   | Just (tc,_) <- splitNewTyConApp_maybe ty
 299   , isNewTyCon tc
 300   , Just new_dc <- maybeTyConSingleCon tc = do
 301          real_value <- y 10 t{ty=repType ty}
 302          return$ cparen (p >= app_prec) (ppr new_dc <+> real_value)
 303   | otherwise = do
 304          tt_docs <- mapM (y app_prec) tt
 305          return$ cparen (p >= app_prec) (ppr dc <+> sep tt_docs)
 306
 307 pprTermM y _ t = pprTermM1 y t
 308
 309 pprTermM1 _ Prim{value=words, ty=ty} = return$ text$ repPrim (tyConAppTyCon ty)
 310                                                              words
 311 pprTermM1 y t@Term{} = panic "pprTermM1 - unreachable"
 312 pprTermM1 _ Suspension{bound_to=Nothing} = return$ char '_'
 313 pprTermM1 _ Suspension{mb_ty=Just ty, bound_to=Just n}
 314   | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
 315   | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
 316
 317 -- Takes a list of custom printers with a explicit recursion knot and a term,
 318 -- and returns the output of the first succesful printer, or the default printer
 319 cPprTerm :: forall m. Monad m =>
 320            ((Int->Term->m SDoc)->[Int->Term->m (Maybe SDoc)]) -> Term -> m SDoc
 321 cPprTerm custom = go 0 where
 322   go prec t@Term{} = do
 323     let default_ prec t = Just `liftM` pprTermM go prec t
 324         mb_customDocs = [pp prec t | pp <- custom go ++ [default_]]
 325     Just doc <- firstJustM mb_customDocs
 326     return$ cparen (prec>app_prec+1) doc
 327   go _ t = pprTermM1 go t
 328   firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
 329   firstJustM [] = return Nothing
 330
 331 -- Default set of custom printers. Note that the recursion knot is explicit
 332 cPprTermBase :: Monad m => (Int->Term-> m SDoc)->[Int->Term->m (Maybe SDoc)]
 333 cPprTermBase y =
 334   [
 335     ifTerm isTupleTy             (\_ -> liftM (parens . hcat . punctuate comma)
 336                                  . mapM (y (-1)) . subTerms)
 337   , ifTerm (\t -> isTyCon listTyCon t && subTerms t `lengthIs` 2)
 338                                  (\ p Term{subTerms=[h,t]} -> doList p h t)
 339   , ifTerm (isTyCon intTyCon)    (coerceShow$ \(a::Int)->a)
 340   , ifTerm (isTyCon charTyCon)   (coerceShow$ \(a::Char)->a)
 341 --  , ifTerm (isTyCon wordTyCon) (coerceShow$ \(a::Word)->a)
 342   , ifTerm (isTyCon floatTyCon)  (coerceShow$ \(a::Float)->a)
 343   , ifTerm (isTyCon doubleTyCon) (coerceShow$ \(a::Double)->a)
 344   , ifTerm isIntegerTy           (coerceShow$ \(a::Integer)->a)
 345   ]
 346      where ifTerm pred f p t@Term{} | pred t    = liftM Just (f p t)
 347                                     | otherwise = return Nothing
 348            isIntegerTy Term{ty=ty}  | Just (tc,_) <- splitTyConApp_maybe ty
 349                                     = tyConName tc == integerTyConName
 350            isTupleTy Term{ty=ty}    | Just (tc,_) <- splitTyConApp_maybe ty
 351                                     = tc `elem` (fst.unzip.elems) boxedTupleArr
 352            isTyCon a_tc Term{ty=ty} | Just (tc,_) <- splitTyConApp_maybe ty
 353                                     = a_tc == tc
 354            coerceShow f _ = return . text . show . f . unsafeCoerce# . val
 355            --TODO pprinting of list terms is not lazy
 356            doList p h t = do
 357                let elems = h : getListTerms t
 358                    isConsLast = termType(last elems) /= termType h
 359                print_elems <- mapM (y cons_prec) elems
 360                return$ if isConsLast
 361                      then cparen (p >= cons_prec) . hsep . punctuate (space<>colon)
 362                            $ print_elems
 363                      else brackets (hcat$ punctuate comma print_elems)
 364
 365                 where Just a /= Just b = not (a `coreEqType` b)
 366                       _      /=   _    = True
 367                       getListTerms Term{subTerms=[h,t]} = h : getListTerms t
 368                       getListTerms t@Term{subTerms=[]}  = []
 369                       getListTerms t@Suspension{}       = [t]
 370                       getListTerms t = pprPanic "getListTerms" (ppr t)
 371
 372
 373 repPrim :: TyCon -> [Word] -> String
 374 repPrim t = rep where
 375    rep x
 376     | t == charPrimTyCon   = show (build x :: Char)
 377     | t == intPrimTyCon    = show (build x :: Int)
 378     | t == wordPrimTyCon   = show (build x :: Word)
 379     | t == floatPrimTyCon  = show (build x :: Float)
 380     | t == doublePrimTyCon = show (build x :: Double)
 381     | t == int32PrimTyCon  = show (build x :: Int32)
 382     | t == word32PrimTyCon = show (build x :: Word32)
 383     | t == int64PrimTyCon  = show (build x :: Int64)
 384     | t == word64PrimTyCon = show (build x :: Word64)
 385     | t == addrPrimTyCon   = show (nullPtr `plusPtr` build x)
 386     | t == stablePtrPrimTyCon  = "<stablePtr>"
 387     | t == stableNamePrimTyCon = "<stableName>"
 388     | t == statePrimTyCon      = "<statethread>"
 389     | t == realWorldTyCon      = "<realworld>"
 390     | t == threadIdPrimTyCon   = "<ThreadId>"
 391     | t == weakPrimTyCon       = "<Weak>"
 392     | t == arrayPrimTyCon      = "<array>"
 393     | t == byteArrayPrimTyCon  = "<bytearray>"
 394     | t == mutableArrayPrimTyCon = "<mutableArray>"
 395     | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
 396     | t == mutVarPrimTyCon= "<mutVar>"
 397     | t == mVarPrimTyCon  = "<mVar>"
 398     | t == tVarPrimTyCon  = "<tVar>"
 399     | otherwise = showSDoc (char '<' <> ppr t <> char '>')
 400     where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
 401 --   This ^^^ relies on the representation of Haskell heap values being
 402 --   the same as in a C array.
 403
 404 -----------------------------------
 405 -- Type Reconstruction
 406 -----------------------------------
 407 {-
 408 Type Reconstruction is type inference done on heap closures.
 409 The algorithm walks the heap generating a set of equations, which
 410 are solved with syntactic unification.
 411 A type reconstruction equation looks like:
 412
 413   <datacon reptype>  =  <actual heap contents>
 414
 415 The full equation set is generated by traversing all the subterms, starting
 416 from a given term.
 417
 418 The only difficult part is that newtypes are only found in the lhs of equations.
 419 Right hand sides are missing them. We can either (a) drop them from the lhs, or
 420 (b) reconstruct them in the rhs when possible.
 421
 422 The function congruenceNewtypes takes a shot at (b)
 423 -}
 424
 425 -- The Type Reconstruction monad
 426 type TR a = TcM a
 427
 428 runTR :: HscEnv -> TR a -> IO a
 429 runTR hsc_env c = do
 430   mb_term <- initTcPrintErrors hsc_env iNTERACTIVE c
 431   case mb_term of
 432     Nothing -> panic "Can't unify"
 433     Just x -> return x
 434
 435 trIO :: IO a -> TR a
 436 trIO = liftTcM . ioToTcRn
 437
 438 liftTcM :: TcM a -> TR a
 439 liftTcM = id
 440
 441 newVar :: Kind -> TR TcTyVar
 442 newVar = liftTcM . newFlexiTyVar
 443
 444 -- | Returns the instantiated type scheme ty', and the substitution sigma
 445 --   such that sigma(ty') = ty
 446 instScheme :: Type -> TR (TcType, TvSubst)
 447 instScheme ty | (tvs, rho) <- tcSplitForAllTys ty = liftTcM$ do
 448    (tvs',theta,ty') <- tcInstType (mapM tcInstTyVar) ty
 449    return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
 450
 451 -- Adds a constraint of the form t1 == t2
 452 -- t1 is expected to come from walking the heap
 453 -- t2 is expected to come from a datacon signature
 454 -- Before unification, congruenceNewtypes needs to
 455 -- do its magic.
 456 addConstraint :: TcType -> TcType -> TR ()
 457 addConstraint t1 t2  = congruenceNewtypes t1 t2 >>= uncurry unifyType
 458
 459
 460
 461 -- Type & Term reconstruction
 462 cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
 463 cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
 464    tv <- liftM mkTyVarTy (newVar argTypeKind)
 465    case mb_ty of
 466      Nothing -> go tv tv hval >>= zonkTerm
 467      Just ty | isMonomorphic ty -> go ty ty hval >>= zonkTerm
 468      Just ty -> do
 469               (ty',rev_subst) <- instScheme (sigmaType ty)
 470               addConstraint tv ty'
 471               term <- go tv tv hval >>= zonkTerm
 472               --restore original Tyvars
 473               return$ mapTermType (substTy rev_subst) term
 474     where
 475   go tv ty a = do
 476     let monomorphic = not(isTyVarTy tv)
 477     -- This ^^^ is a convention. The ancestor tests for
 478     -- monomorphism and passes a type instead of a tv
 479     clos <- trIO $ getClosureData a
 480     case tipe clos of
 481 -- Thunks we may want to force
 482 -- NB. this won't attempt to force a BLACKHOLE.  Even with :force, we never
 483 -- force blackholes, because it would almost certainly result in deadlock,
 484 -- and showing the '_' is more useful.
 485       t | isThunk t && force -> seq a $ go tv ty a
 486 -- We always follow indirections
 487       Indirection _ -> go tv ty $! (ptrs clos ! 0)
 488  -- The interesting case
 489       Constr -> do
 490         m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
 491         case m_dc of
 492           Nothing -> panic "Can't find the DataCon for a term"
 493           Just dc -> do
 494             let extra_args = length(dataConRepArgTys dc) -
 495                              length(dataConOrigArgTys dc)
 496                 subTtypes  = matchSubTypes dc ty
 497                 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
 498             subTermTvs <- sequence
 499                  [ if isMonomorphic t then return t
 500                                       else (mkTyVarTy `fmap` newVar k)
 501                    | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
 502             -- It is vital for newtype reconstruction that the unification step
 503             --  is done right here, _before_ the subterms are RTTI reconstructed
 504             when (not monomorphic) $ do
 505                   let myType = mkFunTys (reOrderTerms subTermTvs
 506                                                       subTtypesNP
 507                                                       subTtypes)
 508                                         tv
 509                   (signatureType,_) <- instScheme(dataConRepType dc)
 510                   addConstraint myType signatureType
 511             subTermsP <- sequence $ drop extra_args
 512                                  -- ^^^  all extra arguments are pointed
 513                   [ appArr (go tv t) (ptrs clos) i
 514                    | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
 515             let unboxeds   = extractUnboxed subTtypesNP clos
 516                 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
 517                 subTerms   = reOrderTerms subTermsP subTermsNP
 518                                 (drop extra_args subTtypes)
 519             return (Term tv dc a subTerms)
 520 -- The otherwise case: can be a Thunk,AP,PAP,etc.
 521       otherwise ->
 522          return (Suspension (tipe clos) (Just tv) a Nothing)
 523
 524   matchSubTypes dc ty
 525     | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
 526     , isVanillaDataCon dc  --TODO non-vanilla case
 527     = dataConInstArgTys dc ty_args
 528 --     assumes that newtypes are looked ^^^ through
 529     | otherwise = dataConRepArgTys dc
 530
 531 -- This is used to put together pointed and nonpointed subterms in the
 532 --  correct order.
 533   reOrderTerms _ _ [] = []
 534   reOrderTerms pointed unpointed (ty:tys)
 535    | isPointed ty = ASSERT2(not(null pointed)
 536                             , ptext SLIT("reOrderTerms") $$
 537                                         (ppr pointed $$ ppr unpointed))
 538                     head pointed : reOrderTerms (tail pointed) unpointed tys
 539    | otherwise    = ASSERT2(not(null unpointed)
 540                            , ptext SLIT("reOrderTerms") $$
 541                                        (ppr pointed $$ ppr unpointed))
 542                     head unpointed : reOrderTerms pointed (tail unpointed) tys
 543
 544
 545
 546 -- Fast, breadth-first Type reconstruction
 547 max_depth = 10 :: Int
 548 cvReconstructType :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Type
 549 cvReconstructType hsc_env force mb_ty hval = runTR hsc_env $ do
 550    tv <- liftM mkTyVarTy (newVar argTypeKind)
 551    case mb_ty of
 552      Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
 553                           (uncurry go)
 554                           [(tv, hval)]
 555                           max_depth
 556                    zonkTcType tv  -- TODO untested!
 557      Just ty | isMonomorphic ty -> return ty
 558      Just ty -> do
 559               (ty',rev_subst) <- instScheme (sigmaType ty)
 560               addConstraint tv ty'
 561               search (isMonomorphic `fmap` zonkTcType tv)
 562                      (uncurry go)
 563                      [(tv, hval)]
 564                      max_depth
 565               substTy rev_subst `fmap` zonkTcType tv
 566     where
 567 --  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
 568   search stop expand [] depth  = return ()
 569   search stop expand x 0 = fail$ "Failed to reconstruct a type after " ++
 570                                 show max_depth ++ " steps"
 571   search stop expand (x:xx) d  = do
 572     new <- expand x
 573     unlessM stop $ search stop expand (xx ++ new) $! (pred d)
 574
 575    -- returns unification tasks,since we are going to want a breadth-first search
 576   go :: Type -> HValue -> TR [(Type, HValue)]
 577   go tv a = do
 578     clos <- trIO $ getClosureData a
 579     case tipe clos of
 580       Indirection _ -> go tv $! (ptrs clos ! 0)
 581       Constr -> do
 582         m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
 583         case m_dc of
 584           Nothing -> panic "Can't find the DataCon for a term"
 585           Just dc -> do
 586             let extra_args = length(dataConRepArgTys dc) -
 587                              length(dataConOrigArgTys dc)
 588             subTtypes <- mapMif (not . isMonomorphic)
 589                                 (\t -> mkTyVarTy `fmap` newVar (typeKind t))
 590                                 (dataConRepArgTys dc)
 591             -- It is vital for newtype reconstruction that the unification step
 592             -- is done right here, _before_ the subterms are RTTI reconstructed
 593             let myType         = mkFunTys subTtypes tv
 594             (signatureType,_) <- instScheme(dataConRepType dc)
 595             addConstraint myType signatureType
 596             return $ [ appArr (\e->(t,e)) (ptrs clos) i
 597                        | (i,t) <- drop extra_args $ zip [0..] subTtypes]
 598       otherwise -> return []
 599
 600
 601 -- Dealing with newtypes
 602 {-
 603    A parallel fold over two Type values,
 604  compensating for missing newtypes on both sides.
 605  This is necessary because newtypes are not present
 606  in runtime, but since sometimes there is evidence
 607  available we do our best to reconstruct them.
 608    Evidence can come from DataCon signatures or
 609  from compile-time type inference.
 610    I am using the words congruence and rewriting
 611  because what we are doing here is an approximation
 612  of unification modulo a set of equations, which would
 613  come from newtype definitions. These should be the
 614  equality coercions seen in System Fc. Rewriting
 615  is performed, taking those equations as rules,
 616  before launching unification.
 617
 618    It doesn't make sense to rewrite everywhere,
 619  or we would end up with all newtypes. So we rewrite
 620  only in presence of evidence.
 621    The lhs comes from the heap structure of ptrs,nptrs.
 622    The rhs comes from a DataCon type signature.
 623  Rewriting in the rhs is restricted to the result type.
 624
 625    Note that it is very tricky to make this 'rewriting'
 626  work with the unification implemented by TcM, where
 627  substitutions are 'inlined'. The order in which
 628  constraints are unified is vital for this (or I am
 629  using TcM wrongly).
 630 -}
 631 congruenceNewtypes ::  TcType -> TcType -> TcM (TcType,TcType)
 632 congruenceNewtypes lhs rhs
 633  -- TyVar lhs inductive case
 634     | Just tv <- getTyVar_maybe lhs
 635     = recoverM (return (lhs,rhs)) $ do
 636          Indirect ty_v <- readMetaTyVar tv
 637          (lhs1, rhs1) <- congruenceNewtypes ty_v rhs
 638          return (lhs, rhs1)
 639 -- FunTy inductive case
 640     | Just (l1,l2) <- splitFunTy_maybe lhs
 641     , Just (r1,r2) <- splitFunTy_maybe rhs
 642     = do (l2',r2') <- congruenceNewtypes l2 r2
 643          (l1',r1') <- congruenceNewtypes l1 r1
 644          return (mkFunTy l1' l2', mkFunTy r1' r2')
 645 -- TyconApp Inductive case; this is the interesting bit.
 646     | Just (tycon_l, args_l) <- splitNewTyConApp_maybe lhs
 647     , Just (tycon_r, args_r) <- splitNewTyConApp_maybe rhs
 648     , tycon_l /= tycon_r
 649     = return (lhs, upgrade tycon_l rhs)
 650
 651     | otherwise = return (lhs,rhs)
 652
 653     where upgrade :: TyCon -> Type -> Type
 654           upgrade new_tycon ty
 655             | not (isNewTyCon new_tycon) = ty
 656             | ty' <- mkTyConApp new_tycon (map mkTyVarTy $ tyConTyVars new_tycon)
 657             , Just subst <- tcUnifyTys (const BindMe) [ty] [repType ty']
 658             = substTy subst ty'
 659         -- assumes that reptype doesn't touch tyconApp args ^^^
 660
 661
 662 --------------------------------------------------------------------------------
 663
 664 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
 665                  = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
 666
 667 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
 668 mapMif pred f xx = sequence $ mapMif_ pred f xx
 669 mapMif_ pred f []     = []
 670 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
 671
 672 unlessM condM acc = condM >>= \c -> unless c acc
 673
 674 -- Strict application of f at index i
 675 appArr f (Array _ _ ptrs#) (I# i#) = case indexArray# ptrs# i# of
 676                                        (# e #) -> f e
 677
 678 zonkTerm :: Term -> TcM Term
 679 zonkTerm = foldTerm idTermFoldM {
 680               fTerm = \ty dc v tt -> sequence tt      >>= \tt ->
 681                                      zonkTcType ty    >>= \ty' ->
 682                                      return (Term ty' dc v tt)
 683              ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
 684                                           return (Suspension ct ty v b)}
 685
 686
 687 -- Is this defined elsewhere?
 688 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
 689 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
 690
 691