X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FRtClosureInspect.hs;h=cb16c1d39d8f32cd2b4f290f6129752fb98b1755;hb=4fc2ca8222ca4625132ad5acf3afeb8293e42a46;hp=437ff940fe1827e7e8d0328ccd84639675b39711;hpb=6c27803d6d1095741fc99136c329aaffa6f3006c;p=ghc-hetmet.git diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 437ff94..cb16c1d 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -31,7 +31,7 @@ module RtClosureInspect( termTyVars, -- unsafeDeepSeq, cvReconstructType, - unifyRTTI, + improveRTTIType, sigmaType, Closure(..), getClosureData, @@ -50,12 +50,10 @@ import Linker import DataCon import Type import Var -import TcRnMonad ( TcM, initTc, ioToTcRn, - tryTcErrs, traceTc) +import TcRnMonad import TcType import TcMType import TcUnify -import TcGadt import TcEnv import DriverPhases import TyCon @@ -68,13 +66,17 @@ import TysPrim import PrelNames import TysWiredIn -import Constants import Outputable +import FastString import Panic +#ifndef GHCI_TABLES_NEXT_TO_CODE +import Constants ( wORD_SIZE ) +#endif + import GHC.Arr ( Array(..) ) import GHC.Exts -import GHC.IOBase +import GHC.IOBase ( IO(IO) ) import Control.Monad import Data.Maybe @@ -87,6 +89,7 @@ import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse) import Foreign import System.IO.Unsafe +import System.IO --------------------------------------------- -- * A representation of semi evaluated Terms --------------------------------------------- @@ -261,11 +264,11 @@ extractUnboxed tt clos = go tt (nonPtrs clos) | otherwise = pprPanic "Expected a TcTyCon" (ppr t) go [] _ = [] go (t:tt) xx - | (x, rest) <- splitAt ((sizeofType t + wORD_SIZE - 1) `div` wORD_SIZE) xx + | (x, rest) <- splitAt (sizeofType t) xx = x : go tt rest -sizeofTyCon :: TyCon -> Int -sizeofTyCon = sizeofPrimRep . tyConPrimRep +sizeofTyCon :: TyCon -> Int -- in *words* +sizeofTyCon = primRepSizeW . tyConPrimRep ----------------------------------- -- * Traversals for Terms @@ -374,7 +377,7 @@ ppr_termM1 Prim{value=words, ty=ty} = return$ text$ repPrim (tyConAppTyCon ty) words ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_' ppr_termM1 Suspension{ty=ty, bound_to=Just n} - | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("") + | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit "") | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty ppr_termM1 Term{} = panic "ppr_termM1 - Term" ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap" @@ -532,19 +535,19 @@ runTR hsc_env c = do Just x -> return x runTR_maybe :: HscEnv -> TR a -> IO (Maybe a) -runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE +runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE traceTR :: SDoc -> TR () traceTR = liftTcM . traceTc trIO :: IO a -> TR a -trIO = liftTcM . ioToTcRn +trIO = liftTcM . liftIO liftTcM :: TcM a -> TR a liftTcM = id newVar :: Kind -> TR TcType -newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar +newVar = liftTcM . fmap mkTyVarTy . newBoxyTyVar -- | Returns the instantiated type scheme ty', and the substitution sigma -- such that sigma(ty') = ty @@ -559,7 +562,7 @@ instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do -- Before unification, congruenceNewtypes needs to -- do its magic. addConstraint :: TcType -> TcType -> TR () -addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType +addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry boxyUnify >> return () -- TOMDO: what about the coercion? -- we should consider family instances @@ -667,11 +670,11 @@ cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do reOrderTerms _ _ [] = [] reOrderTerms pointed unpointed (ty:tys) | isPointed ty = ASSERT2(not(null pointed) - , ptext SLIT("reOrderTerms") $$ + , ptext (sLit "reOrderTerms") $$ (ppr pointed $$ ppr unpointed)) let (t:tt) = pointed in t : reOrderTerms tt unpointed tys | otherwise = ASSERT2(not(null unpointed) - , ptext SLIT("reOrderTerms") $$ + , ptext (sLit "reOrderTerms") $$ (ppr pointed $$ ppr unpointed)) let (t:tt) = unpointed in t : reOrderTerms pointed tt tys @@ -759,26 +762,26 @@ cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do zip [0..] (filter isPointed subTtypes)] _ -> return [] -{- - This helper computes the difference between a base type t and the - improved rtti_t computed by RTTI - The main difference between RTTI types and their normal counterparts - is that the former are _not_ polymorphic, thus polymorphism must - be stripped. Syntactically, forall's must be stripped. - We also remove predicates. --} -unifyRTTI :: Type -> Type -> TvSubst -unifyRTTI ty rtti_ty = - case mb_subst of - Just subst -> subst - Nothing -> pprPanic "Failed to compute a RTTI substitution" - (ppr (ty, rtti_ty)) - -- In addition, we strip newtypes too, since the reconstructed type might - -- not have recovered them all - -- TODO stripping newtypes shouldn't be necessary, test - where mb_subst = tcUnifyTys (const BindMe) - [rttiView ty] - [rttiView rtti_ty] +-- Compute the difference between a base type and the type found by RTTI +-- improveType +-- The types can contain skolem type variables, which need to be treated as normal vars. +-- In particular, we want them to unify with things. +improveRTTIType :: HscEnv -> Type -> Type -> IO (Maybe TvSubst) +improveRTTIType hsc_env ty rtti_ty = runTR_maybe hsc_env $ do + let (_,ty0) = splitForAllTys ty + ty_tvs = varSetElems $ tyVarsOfType ty0 + let (_,rtti_ty0)= splitForAllTys rtti_ty + rtti_tvs = varSetElems $ tyVarsOfType rtti_ty0 + (ty_tvs',_,ty')<- tcInstType (mapM tcInstTyVar) (mkSigmaTy ty_tvs [] ty0) + (_,_,rtti_ty') <- tcInstType (mapM tcInstTyVar) (mkSigmaTy rtti_tvs [] rtti_ty0) + boxyUnify rtti_ty' ty' + tvs1_contents <- zonkTcTyVars ty_tvs' + let subst = uncurry zipTopTvSubst + (unzip [(tv,ty) | tv <- ty_tvs, ty <- tvs1_contents + , getTyVar_maybe ty /= Just tv + , not(isTyVarTy ty)]) +-- liftIO $ hPutStrLn stderr $ showSDocDebug $ text "unify " <+> sep [ppr ty, ppr rtti_ty, equals, ppr subst ] + return subst -- Dealing with newtypes {-