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