X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FRtClosureInspect.hs;h=509eb996fc69743de88f6fee17a760916120e269;hp=9e2ef17e8da02ae06ce6bebac5c724a29bf0c30f;hb=8c2fd74094dc533bf3256158325e3f091e57e5d2;hpb=937eb1f1386f12c729c6d819417fe81bc4786b9f diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 9e2ef17..509eb99 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, @@ -54,7 +54,6 @@ import TcRnMonad import TcType import TcMType import TcUnify -import TcGadt import TcEnv import DriverPhases import TyCon @@ -68,8 +67,11 @@ import PrelNames import TysWiredIn import Outputable +import FastString import Panic +import Constants ( wORD_SIZE ) + import GHC.Arr ( Array(..) ) import GHC.Exts import GHC.IOBase ( IO(IO) ) @@ -85,6 +87,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 --------------------------------------------- @@ -175,15 +178,17 @@ getClosureData :: a -> IO Closure getClosureData a = case unpackClosure# a of (# iptr, ptrs, nptrs #) -> do -#ifndef GHCI_TABLES_NEXT_TO_CODE - -- the info pointer we get back from unpackClosure# is to the - -- beginning of the standard info table, but the Storable instance - -- for info tables takes into account the extra entry pointer - -- when !tablesNextToCode, so we must adjust here: - itbl <- peek (Ptr iptr `plusPtr` negate wORD_SIZE) -#else - itbl <- peek (Ptr iptr) -#endif + let iptr' + | ghciTablesNextToCode = + Ptr iptr + | otherwise = + -- the info pointer we get back from unpackClosure# + -- is to the beginning of the standard info table, + -- but the Storable instance for info tables takes + -- into account the extra entry pointer when + -- !ghciTablesNextToCode, so we must adjust here: + Ptr iptr `plusPtr` negate wORD_SIZE + itbl <- peek iptr' let tipe = readCType (BCI.tipe itbl) elems = fromIntegral (BCI.ptrs itbl) ptrsList = Array 0 (elems - 1) elems ptrs @@ -372,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" @@ -381,7 +386,7 @@ ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap" pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t} | Just (tc,_) <- splitNewTyConApp_maybe ty , ASSERT(isNewTyCon tc) True - , Just new_dc <- maybeTyConSingleCon tc = do + , Just new_dc <- tyConSingleDataCon_maybe tc = do real_term <- y max_prec t return$ cparen (p >= app_prec) (ppr new_dc <+> real_term) pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap" @@ -530,7 +535,7 @@ 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 @@ -542,7 +547,7 @@ 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 @@ -557,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 @@ -641,7 +646,7 @@ cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do (signatureType,_) <- instScheme(dataConRepType dc) addConstraint myType signatureType subTermsP <- sequence $ drop extra_args - -- ^^^ all extra arguments are pointed + -- \^^^ all extra arguments are pointed [ appArr (go (pred bound) tv t) (ptrs clos) i | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP] let unboxeds = extractUnboxed subTtypesNP clos @@ -665,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 @@ -677,7 +682,7 @@ cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do | Just (tc, args) <- splitNewTyConApp_maybe ty , isNewTyCon tc , wrapped_type <- newTyConInstRhs tc args - , Just dc <- maybeTyConSingleCon tc + , Just dc <- tyConSingleDataCon_maybe tc , t' <- expandNewtypes t{ ty = wrapped_type , subTerms = map expandNewtypes tt } = NewtypeWrap ty (Right dc) t' @@ -757,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 {-