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