X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FRtClosureInspect.hs;h=b4068a7aa76ecb92908c8f1c9a15e5eb2a3db80a;hp=ef25ad5644873f0abfb0afbdb4332e3d9ab52642;hb=35a1ec430a5e44a9bc79d385b997422c20cb427b;hpb=76349636abcb764e8ed3b9ae548730ad2d85abb2 diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index ef25ad5..b4068a7 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -20,9 +20,7 @@ module RtClosureInspect( -- unsafeDeepSeq, - Closure(..), getClosureData, ClosureType(..), isConstr, isIndirection, - - sigmaType + Closure(..), getClosureData, ClosureType(..), isConstr, isIndirection ) where #include "HsVersions.h" @@ -34,6 +32,7 @@ import Linker import DataCon import Type +import qualified Unify as U import TypeRep -- I know I know, this is cheating import Var import TcRnMonad @@ -60,12 +59,7 @@ import Constants ( wORD_SIZE ) import GHC.Arr ( Array(..) ) import GHC.Exts - -#if __GLASGOW_HASKELL__ >= 611 import GHC.IO ( IO(..) ) -#else -import GHC.IOBase ( IO(..) ) -#endif import Control.Monad import Data.Maybe @@ -572,13 +566,33 @@ liftTcM = id newVar :: Kind -> TR TcType newVar = liftTcM . newFlexiTyVarTy --- | Returns the instantiated type scheme ty', and the substitution sigma --- such that sigma(ty') = ty -instScheme :: Type -> TR (TcType, TvSubst) -instScheme ty = liftTcM$ do - (tvs, _, _) <- tcInstType return ty - (tvs',_,ty') <- tcInstType (mapM tcInstTyVar) ty - return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs)) +type RttiInstantiation = [(TcTyVar, TyVar)] + -- Associates the typechecker-world meta type variables + -- (which are mutable and may be refined), to their + -- debugger-world RuntimeUnk counterparts. + -- If the TcTyVar has not been refined by the runtime type + -- elaboration, then we want to turn it back into the + -- original RuntimeUnk + +-- | Returns the instantiated type scheme ty', and the +-- mapping from new (instantiated) -to- old (skolem) type variables +instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation) +instScheme (tvs, ty) + = liftTcM $ do { (tvs', _, subst) <- tcInstTyVars tvs + ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs] + ; return (substTy subst ty, rtti_inst) } + +applyRevSubst :: RttiInstantiation -> TR () +-- Apply the *reverse* substitution in-place to any un-filled-in +-- meta tyvars. This recovers the original debugger-world variable +-- unless it has been refined by new information from the heap +applyRevSubst pairs = liftTcM (mapM_ do_pair pairs) + where + do_pair (tc_tv, rtti_tv) + = do { tc_ty <- zonkTcTyVar tc_tv + ; case tcGetTyVar_maybe tc_ty of + Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv) + _ -> return () } -- Adds a constraint of the form t1 == t2 -- t1 is expected to come from walking the heap @@ -589,9 +603,10 @@ addConstraint :: TcType -> TcType -> TR () addConstraint actual expected = do traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected]) recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual, - text "with", ppr expected]) - (congruenceNewtypes actual expected >>= - (getConstraints . uncurry unifyType) >> return ()) + text "with", ppr expected]) $ + do { (ty1, ty2) <- congruenceNewtypes actual expected + ; _ <- captureConstraints $ unifyType ty1 ty2 + ; return () } -- TOMDO: what about the coercion? -- we should consider family instances @@ -603,30 +618,32 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do -- we quantify existential tyvars as universal, -- as this is needed to be able to manipulate -- them properly - let sigma_old_ty = sigmaType old_ty + let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty + sigma_old_ty = mkForAllTys old_tvs old_tau traceTR (text "Term reconstruction started with initial type " <> ppr old_ty) term <- - if isMonomorphic sigma_old_ty + if null old_tvs then do - new_ty <- go max_depth sigma_old_ty sigma_old_ty hval >>= zonkTerm - return $ fixFunDictionaries $ expandNewtypes new_ty + term <- go max_depth sigma_old_ty sigma_old_ty hval + term' <- zonkTerm term + return $ fixFunDictionaries $ expandNewtypes term' else do - (old_ty', rev_subst) <- instScheme sigma_old_ty + (old_ty', rev_subst) <- instScheme quant_old_ty my_ty <- newVar argTypeKind - when (check1 sigma_old_ty) (traceTR (text "check1 passed") >> + when (check1 quant_old_ty) (traceTR (text "check1 passed") >> addConstraint my_ty old_ty') term <- go max_depth my_ty sigma_old_ty hval - zterm <- zonkTerm term - let new_ty = termType zterm - if isMonomorphic new_ty || check2 (sigmaType new_ty) sigma_old_ty + new_ty <- zonkTcType (termType term) + if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty then do traceTR (text "check2 passed") - addConstraint (termType term) old_ty' + addConstraint new_ty old_ty' + applyRevSubst rev_subst zterm' <- zonkTerm term - return ((fixFunDictionaries . expandNewtypes . mapTermType (substTy rev_subst)) zterm') + return ((fixFunDictionaries . expandNewtypes) zterm') else do traceTR (text "check2 failed" <+> parens - (ppr zterm <+> text "::" <+> ppr new_ty)) + (ppr term <+> text "::" <+> ppr new_ty)) -- we have unsound types. Replace constructor types in -- subterms with tyvars zterm' <- mapTermTypeM @@ -634,7 +651,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do Just (tc, _:_) | tc /= funTyCon -> newVar argTypeKind _ -> return ty) - zterm + term zonkTerm zterm' traceTR (text "Term reconstruction completed." $$ text "Term obtained: " <> ppr term $$ @@ -676,7 +693,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do contents_tv <- newVar liftedTypeKind contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w ASSERT(isUnliftedTypeKind $ typeKind my_ty) return () - (mutvar_ty,_) <- instScheme $ sigmaType $ mkFunTy + (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy contents_ty (mkTyConApp tycon [world,contents_ty]) addConstraint (mkFunTy contents_tv my_ty) mutvar_ty x <- go (pred max_depth) contents_tv contents_ty contents @@ -780,9 +797,9 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type) cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do traceTR (text "RTTI started with initial type " <> ppr old_ty) - let sigma_old_ty = sigmaType old_ty + let sigma_old_ty@(old_tvs, _) = quantifyType old_ty new_ty <- - if isMonomorphic sigma_old_ty + if null old_tvs then return old_ty else do (old_ty', rev_subst) <- instScheme sigma_old_ty @@ -794,12 +811,12 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do (Seq.singleton (my_ty, hval)) max_depth new_ty <- zonkTcType my_ty - if isMonomorphic new_ty || check2 (sigmaType new_ty) sigma_old_ty + if isMonomorphic new_ty || check2 (quantifyType new_ty) sigma_old_ty then do - traceTR (text "check2 passed") + traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty) addConstraint my_ty old_ty' - new_ty' <- zonkTcType my_ty - return (substTy rev_subst new_ty') + applyRevSubst rev_subst + zonkRttiType new_ty else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >> return old_ty traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty) @@ -846,7 +863,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do -- It is vital for newtype reconstruction that the unification step -- is done right here, _before_ the subterms are RTTI reconstructed let myType = mkFunTys subTtypes my_ty - (signatureType,_) <- instScheme(mydataConType dc) + (signatureType,_) <- instScheme (mydataConType dc) addConstraint myType signatureType return $ [ appArr (\e->(t,e)) (ptrs clos) i | (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)] @@ -856,36 +873,23 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do -- 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 -> RttiType -> RttiType -> IO (Maybe TvSubst) -improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do - traceTR (text "improveRttiType" <+> fsep [ppr _ty, ppr rtti_ty]) - (ty_tvs, _, _) <- tcInstType return ty - (ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty - (_, _, rtti_ty') <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty) - _ <- getConstraints(unifyType rtti_ty' ty') - tvs1_contents <- zonkTcTyVars ty_tvs' - let subst = (uncurry zipTopTvSubst . unzip) - [(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents - , getTyVar_maybe ty /= Just tv - --, not(isTyVarTy ty) - ] - return subst - where ty = sigmaType _ty +improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TvSubst +improveRTTIType _ base_ty new_ty + = U.tcUnifyTys (const U.BindMe) [base_ty] [new_ty] myDataConInstArgTys :: DataCon -> [Type] -> [Type] myDataConInstArgTys dc args | null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args | otherwise = dataConRepArgTys dc -mydataConType :: DataCon -> Type +mydataConType :: DataCon -> QuantifiedType -- ^ Custom version of DataCon.dataConUserType where we -- - remove the equality constraints -- - use the representation types for arguments, including dictionaries -- - keep the original result type mydataConType dc - = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $ - mkFunTys arg_tys $ - res_ty + = ( (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs + , mkFunTys arg_tys res_ty ) where univ_tvs = dataConUnivTyVars dc ex_tvs = dataConExTyVars dc eq_spec = dataConEqSpec dc @@ -1017,24 +1021,21 @@ If that is not the case, then we consider two conditions. -} -check1 :: Type -> Bool -check1 ty | (tvs, _, _) <- tcSplitSigmaTy ty = not $ any isHigherKind (map tyVarKind tvs) +check1 :: QuantifiedType -> Bool +check1 (tvs, _) = not $ any isHigherKind (map tyVarKind tvs) where isHigherKind = not . null . fst . splitKindFunTys -check2 :: Type -> Type -> Bool -check2 sigma_rtti_ty sigma_old_ty +check2 :: QuantifiedType -> QuantifiedType -> Bool +check2 (_, rtti_ty) (_, old_ty) | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty = case () of _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty - -> and$ zipWith check2 rttis olds + -> and$ zipWith check2 (map quantifyType rttis) (map quantifyType olds) _ | Just _ <- splitAppTy_maybe old_ty -> isMonomorphicOnNonPhantomArgs rtti_ty _ -> True | otherwise = True - where (_, _ , rtti_ty) = tcSplitSigmaTy sigma_rtti_ty - (_, _ , old_ty) = tcSplitSigmaTy sigma_old_ty - -- Dealing with newtypes -------------------------- @@ -1072,6 +1073,8 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') go l r -- TyVar lhs inductive case | Just tv <- getTyVar_maybe l + , isTcTyVar tv + , isMetaTyVar tv = recoverTR (return r) $ do Indirect ty_v <- readMetaTyVar tv traceTR $ fsep [text "(congruence) Following indirect tyvar:", @@ -1108,17 +1111,30 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') zonkTerm :: Term -> TcM Term -zonkTerm = foldTermM TermFoldM{ - fTermM = \ty dc v tt -> zonkTcType ty >>= \ty' -> - return (Term ty' dc v tt) - ,fSuspensionM = \ct ty v b -> zonkTcType ty >>= \ty -> - return (Suspension ct ty v b) - ,fNewtypeWrapM= \ty dc t -> zonkTcType ty >>= \ty' -> - return$ NewtypeWrap ty' dc t - ,fRefWrapM = \ty t -> - return RefWrap `ap` zonkTcType ty `ap` return t - ,fPrimM = (return.) . Prim - } +zonkTerm = foldTermM (TermFoldM + { fTermM = \ty dc v tt -> zonkRttiType ty >>= \ty' -> + return (Term ty' dc v tt) + , fSuspensionM = \ct ty v b -> zonkRttiType ty >>= \ty -> + return (Suspension ct ty v b) + , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' -> + return$ NewtypeWrap ty' dc t + , fRefWrapM = \ty t -> return RefWrap `ap` + zonkRttiType ty `ap` return t + , fPrimM = (return.) . Prim }) + +zonkRttiType :: TcType -> TcM Type +-- Zonk the type, replacing any unbound Meta tyvars +-- by skolems, safely out of Meta-tyvar-land +zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta) + where + zonk_unbound_meta tv + = ASSERT( isTcTyVar tv ) + do { tv' <- skolemiseUnboundMetaTyVar tv RuntimeUnk + -- This is where RuntimeUnks are born: + -- otherwise-unconstrained unification variables are + -- turned into RuntimeUnks as they leave the + -- typechecker's monad + ; return (mkTyVarTy tv') } -------------------------------------------------------------------------------- -- Restore Class predicates out of a representation type @@ -1137,7 +1153,7 @@ dictsView ty = ty -- Use only for RTTI types isMonomorphic :: RttiType -> Bool isMonomorphic ty = noExistentials && noUniversals - where (tvs, _, ty') = tcSplitSigmaTy ty + where (tvs, _, ty') = tcSplitSigmaTy ty noExistentials = isEmptyVarSet (tyVarsOfType ty') noUniversals = null tvs @@ -1161,11 +1177,11 @@ tyConPhantomTyVars tc = tyConTyVars tc \\ dc_vars tyConPhantomTyVars _ = [] --- Is this defined elsewhere? --- Generalize the type: find all free tyvars and wrap in the appropiate ForAll. -sigmaType :: Type -> Type -sigmaType ty = mkSigmaTy (varSetElems$ tyVarsOfType ty) [] ty +type QuantifiedType = ([TyVar], Type) -- Make the free type variables explicit +quantifyType :: Type -> QuantifiedType +-- Generalize the type: find all free tyvars and wrap in the appropiate ForAll. +quantifyType ty = (varSetElems (tyVarsOfType ty), ty) mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a] mapMif pred f xx = sequence $ mapMif_ pred f xx