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