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