X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcType.lhs;h=3f6831bb9a55a9b2f35e4128787e850896245067;hb=c7e7bc25c21e28651194d9d37a53a8820932fba7;hp=d03f6f51460e309a124ff7e3287550b820a8d8ee;hpb=f43ebad1020dccdf6fde2fddc91994b27d0f565e;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index d03f6f5..3f6831b 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -22,17 +22,18 @@ module TcType ( tcSplitRhoTy, - tcInstTyVars, - tcInstSigVar, - tcInstTcType, + tcInstTyVar, tcInstTyVars, + tcInstSigVars, + tcInstType, -------------------------------- TcKind, newKindVar, newKindVars, newBoxityVar, -------------------------------- - zonkTcTyVar, zonkTcTyVars, zonkTcSigTyVars, + zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkTcSigTyVars, zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType, + zonkTcPredType, zonkTcTypeToType, zonkTcTyVarToTyVar, zonkKindEnv @@ -47,9 +48,9 @@ import Type ( PredType(..), getTyVar, mkAppTy, mkUTy, splitPredTy_maybe, splitForAllTys, isTyVarTy, mkTyVarTy, mkTyVarTys, - openTypeKind, boxedTypeKind, - superKind, superBoxity, - defaultKind, boxedBoxity + openTypeKind, liftedTypeKind, + superKind, superBoxity, tyVarsOfTypes, + defaultKind, liftedBoxity ) import Subst ( Subst, mkTopTyVarSubst, substTy ) import TyCon ( mkPrimTyCon ) @@ -170,26 +171,31 @@ tcInstTyVar tyvar in tcNewMutTyVar name (tyVarKind tyvar) -tcInstSigVar tyvar -- Very similar to tcInstTyVar - = tcGetUnique `thenNF_Tc` \ uniq -> - let - name = setNameUnique (tyVarName tyvar) uniq - kind = tyVarKind tyvar - in - ASSERT( not (kind == openTypeKind) ) -- Shouldn't happen - tcNewSigTyVar name kind +tcInstSigVars tyvars -- Very similar to tcInstTyVar + = tcGetUniques `thenNF_Tc` \ uniqs -> + listTc [ ASSERT( not (kind == openTypeKind) ) -- Shouldn't happen + tcNewSigTyVar name kind + | (tyvar, uniq) <- tyvars `zip` uniqs, + let name = setNameUnique (tyVarName tyvar) uniq, + let kind = tyVarKind tyvar + ] \end{code} -@tcInstTcType@ instantiates the outer-level for-alls of a TcType with -fresh type variables, returning them and the instantiated body of the for-all. +@tcInstType@ instantiates the outer-level for-alls of a TcType with +fresh type variables, splits off the dictionary part, and returns the results. \begin{code} -tcInstTcType :: TcType -> NF_TcM ([TcTyVar], TcType) -tcInstTcType ty +tcInstType :: TcType -> NF_TcM ([TcTyVar], TcThetaType, TcType) +tcInstType ty = case splitForAllTys ty of - ([], _) -> returnNF_Tc ([], ty) -- Nothing to do - (tyvars, rho) -> tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) -> - returnNF_Tc (tyvars', substTy tenv rho) + ([], rho) -> -- There may be overloading but no type variables; + -- (?x :: Int) => Int -> Int + tcSplitRhoTy rho `thenNF_Tc` \ (theta, tau) -> + returnNF_Tc ([], theta, tau) + + (tyvars, rho) -> tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) -> + tcSplitRhoTy (substTy tenv rho) `thenNF_Tc` \ (theta, tau) -> + returnNF_Tc (tyvars', theta, tau) \end{code} @@ -208,9 +214,16 @@ tcGetTyVar :: TcTyVar -> NF_TcM (Maybe TcType) Putting is easy: \begin{code} -tcPutTyVar tyvar ty = UASSERT2( not (isUTy ty), ppr tyvar <+> ppr ty ) - tcWriteMutTyVar tyvar (Just ty) `thenNF_Tc_` - returnNF_Tc ty +tcPutTyVar tyvar ty + | not (isMutTyVar tyvar) + = pprTrace "tcPutTyVar" (ppr tyvar) $ + returnNF_Tc ty + + | otherwise + = ASSERT( isMutTyVar tyvar ) + UASSERT2( not (isUTy ty), ppr tyvar <+> ppr ty ) + tcWriteMutTyVar tyvar (Just ty) `thenNF_Tc_` + returnNF_Tc ty \end{code} Getting is more interesting. The easy thing to do is just to read, thus: @@ -227,6 +240,11 @@ We return Nothing iff the original box was unbound. \begin{code} tcGetTyVar tyvar + | not (isMutTyVar tyvar) + = pprTrace "tcGetTyVar" (ppr tyvar) $ + returnNF_Tc (Just (mkTyVarTy tyvar)) + + | otherwise = ASSERT2( isMutTyVar tyvar, ppr tyvar ) tcReadMutTyVar tyvar `thenNF_Tc` \ maybe_ty -> case maybe_ty of @@ -266,6 +284,10 @@ short_out other_ty = returnNF_Tc other_ty zonkTcTyVars :: [TcTyVar] -> NF_TcM [TcType] zonkTcTyVars tyvars = mapNF_Tc zonkTcTyVar tyvars +zonkTcTyVarsAndFV :: [TcTyVar] -> NF_TcM TcTyVarSet +zonkTcTyVarsAndFV tyvars = mapNF_Tc zonkTcTyVar tyvars `thenNF_Tc` \ tys -> + returnNF_Tc (tyVarsOfTypes tys) + zonkTcTyVar :: TcTyVar -> NF_TcM TcType zonkTcTyVar tyvar = zonkTyVar (\ tv -> returnNF_Tc (TyVarTy tv)) tyvar @@ -296,9 +318,9 @@ zonkTcThetaType :: TcThetaType -> NF_TcM TcThetaType zonkTcThetaType theta = mapNF_Tc zonkTcPredType theta zonkTcPredType :: TcPredType -> NF_TcM TcPredType -zonkTcPredType (Class c ts) = +zonkTcPredType (ClassP c ts) = zonkTcTypes ts `thenNF_Tc` \ new_ts -> - returnNF_Tc (Class c new_ts) + returnNF_Tc (ClassP c new_ts) zonkTcPredType (IParam n t) = zonkTcType t `thenNF_Tc` \ new_t -> returnNF_Tc (IParam n new_t) @@ -318,18 +340,18 @@ zonkKindEnv pairs -- When zonking a kind, we want to -- zonk a *kind* variable to (Type *) -- zonk a *boxity* variable to * - zonk_unbound_kind_var kv | tyVarKind kv == superKind = tcPutTyVar kv boxedTypeKind - | tyVarKind kv == superBoxity = tcPutTyVar kv boxedBoxity + zonk_unbound_kind_var kv | tyVarKind kv == superKind = tcPutTyVar kv liftedTypeKind + | tyVarKind kv == superBoxity = tcPutTyVar kv liftedBoxity | otherwise = pprPanic "zonkKindEnv" (ppr kv) zonkTcTypeToType :: TcType -> NF_TcM Type zonkTcTypeToType ty = zonkType zonk_unbound_tyvar ty where -- Zonk a mutable but unbound type variable to - -- Void if it has kind Boxed + -- Void if it has kind Lifted -- :Void otherwise zonk_unbound_tyvar tv - | kind == boxedTypeKind + | kind == liftedTypeKind || kind == openTypeKind = tcPutTyVar tv voidTy -- Just to avoid creating a new tycon in -- this vastly common case | otherwise @@ -359,7 +381,7 @@ zonkTcTyVarToTyVar :: TcTyVar -> NF_TcM TyVar zonkTcTyVarToTyVar tv = let -- Make an immutable version, defaulting - -- the kind to boxed if necessary + -- the kind to lifted if necessary immut_tv = mkTyVar (tyVarName tv) (defaultKind (tyVarKind tv)) immut_tv_ty = mkTyVarTy immut_tv @@ -429,8 +451,8 @@ zonkType unbound_var_fn ty go ty `thenNF_Tc` \ ty' -> returnNF_Tc (ForAllTy tyvar' ty') - go_pred (Class c tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' -> - returnNF_Tc (Class c tys') + go_pred (ClassP c tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' -> + returnNF_Tc (ClassP c tys') go_pred (IParam n ty) = go ty `thenNF_Tc` \ ty' -> returnNF_Tc (IParam n ty')