X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcType.lhs;h=f50b9b085cfb00145c1f7d0358e27314d9b9bdc5;hp=b1862b70a385a589cb7f59af67df6492a773b481;hb=2da37f4f15790377900fa6c38ff8fdcd394dfaa2;hpb=6084fb5517da34f65034370a3695e2af3b85ce2b diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index b1862b7..f50b9b0 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -41,7 +41,7 @@ module TcType ( -- Splitters -- These are important because they do not look through newtypes tcView, - tcSplitForAllTys, tcSplitPhiTy, + tcSplitForAllTys, tcSplitPhiTy, tcSplitPredFunTy_maybe, tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN, tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs, tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe, @@ -71,9 +71,10 @@ module TcType ( getClassPredTys_maybe, getClassPredTys, isClassPred, isTyVarClassPred, isEqPred, mkDictTy, tcSplitPredTy_maybe, - isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique, + isPredTy, isDictTy, isDictLikeTy, + tcSplitDFunTy, tcSplitDFunHead, predTyUnique, mkClassPred, isInheritablePred, isIPPred, - dataConsStupidTheta, isRefineableTy, isRefineablePred, + isRefineableTy, isRefineablePred, --------------------------------- -- Foreign import and export @@ -83,6 +84,8 @@ module TcType ( isFFIExternalTy, -- :: Type -> Bool isFFIDynArgumentTy, -- :: Type -> Bool isFFIDynResultTy, -- :: Type -> Bool + isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool + isFFIPrimResultTy, -- :: DynFlags -> Type -> Bool isFFILabelTy, -- :: Type -> Bool isFFIDotnetTy, -- :: DynFlags -> Type -> Bool isFFIDotnetObjTy, -- :: Type -> Bool @@ -97,7 +100,7 @@ module TcType ( unliftedTypeKind, liftedTypeKind, argTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind, - isSubArgTypeKind, isSubKind, defaultKind, + isSubArgTypeKind, isSubKind, splitKindFunTys, defaultKind, kindVarRef, mkKindVar, Type, PredType(..), ThetaType, @@ -123,7 +126,8 @@ module TcType ( typeKind, tidyKind, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, - tcTyVarsOfType, tcTyVarsOfTypes, exactTyVarsOfType, exactTyVarsOfTypes, + tcTyVarsOfType, tcTyVarsOfTypes, tcTyVarsOfPred, exactTyVarsOfType, + exactTyVarsOfTypes, pprKind, pprParendKind, pprType, pprParendType, pprTypeApp, pprTyThingCategory, @@ -139,7 +143,6 @@ import DataCon import Class import Var import ForeignCall -import Unify import VarSet import Type import Coercion @@ -352,6 +355,7 @@ data UserTypeCtxt | ForSigCtxt Name -- Foreign inport or export signature | DefaultDeclCtxt -- Types in a default declaration | SpecInstCtxt -- SPECIALISE instance pragma + | ThBrackCtxt -- Template Haskell type brackets [t| ... |] -- Notes re TySynCtxt -- We allow type synonyms that aren't types; e.g. type List = [] @@ -409,6 +413,7 @@ pprUserTypeCtxt ExprSigCtxt = ptext (sLit "an expression type signature") pprUserTypeCtxt (ConArgCtxt c) = ptext (sLit "the type of the constructor") <+> quotes (ppr c) pprUserTypeCtxt (TySynCtxt c) = ptext (sLit "the RHS of the type synonym") <+> quotes (ppr c) pprUserTypeCtxt GenPatCtxt = ptext (sLit "the type pattern of a generic definition") +pprUserTypeCtxt ThBrackCtxt = ptext (sLit "a Template Haskell quotation [t|...|]") pprUserTypeCtxt LamPatSigCtxt = ptext (sLit "a pattern type signature") pprUserTypeCtxt BindPatSigCtxt = ptext (sLit "a pattern type signature") pprUserTypeCtxt ResSigCtxt = ptext (sLit "a result type signature") @@ -421,7 +426,7 @@ pprUserTypeCtxt SpecInstCtxt = ptext (sLit "a SPECIALISE instance pragma") tidySkolemTyVar :: TidyEnv -> TcTyVar -> (TidyEnv, TcTyVar) -- Tidy the type inside a GenSkol, preparatory to printing it tidySkolemTyVar env tv - = ASSERT( isSkolemTyVar tv || isSigTyVar tv ) + = ASSERT( isTcTyVar tv && (isSkolemTyVar tv || isSigTyVar tv ) ) (env1, mkTcTyVar (tyVarName tv) (tyVarKind tv) info1) where (env1, info1) = case tcTyVarDetails tv of @@ -508,7 +513,7 @@ isTyConableTyVar tv SkolemTv {} -> False isSkolemTyVar tv - = ASSERT( isTcTyVar tv ) + = ASSERT2( isTcTyVar tv, ppr tv ) case tcTyVarDetails tv of SkolemTv _ -> True MetaTv _ _ -> False @@ -660,16 +665,24 @@ tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty' tcIsForAllTy (ForAllTy tv _) = not (isCoVar tv) tcIsForAllTy _ = False -tcSplitPhiTy :: Type -> (ThetaType, Type) -tcSplitPhiTy ty = split ty ty [] - where - split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs +tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type) +-- Split off the first predicate argument from a type +tcSplitPredFunTy_maybe ty | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty' +tcSplitPredFunTy_maybe (ForAllTy tv ty) + | isCoVar tv = Just (coVarPred tv, ty) +tcSplitPredFunTy_maybe (FunTy arg res) + | Just p <- tcSplitPredTy_maybe arg = Just (p, res) +tcSplitPredFunTy_maybe _ + = Nothing - split _ (ForAllTy tv ty) ts - | isCoVar tv = split ty ty (coVarPred tv : ts) - split _ (FunTy arg res) ts - | Just p <- tcSplitPredTy_maybe arg = split res res (p:ts) - split orig_ty _ ts = (reverse ts, orig_ty) +tcSplitPhiTy :: Type -> (ThetaType, Type) +tcSplitPhiTy ty + = split ty [] + where + split ty ts + = case tcSplitPredFunTy_maybe ty of + Just (pred, ty) -> split ty (pred:ts) + Nothing -> (reverse ts, ty) tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type) tcSplitSigmaTy ty = case tcSplitForAllTys ty of @@ -886,8 +899,45 @@ isDictTy :: Type -> Bool isDictTy ty | Just ty' <- tcView ty = isDictTy ty' isDictTy (PredTy p) = isClassPred p isDictTy _ = False + +isDictLikeTy :: Type -> Bool +-- Note [Dictionary-like types] +isDictLikeTy ty | Just ty' <- tcView ty = isDictTy ty' +isDictLikeTy (PredTy p) = isClassPred p +isDictLikeTy (TyConApp tc tys) + | isTupleTyCon tc = all isDictLikeTy tys +isDictLikeTy _ = False \end{code} +Note [Dictionary-like types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Being "dictionary-like" means either a dictionary type or a tuple thereof. +In GHC 6.10 we build implication constraints which construct such tuples, +and if we land up with a binding + t :: (C [a], Eq [a]) + t = blah +then we want to treat t as cheap under "-fdicts-cheap" for example. +(Implication constraints are normally inlined, but sadly not if the +occurrence is itself inside an INLINE function! Until we revise the +handling of implication constraints, that is.) This turned out to +be important in getting good arities in DPH code. Example: + + class C a + class D a where { foo :: a -> a } + instance C a => D (Maybe a) where { foo x = x } + + bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b) + {-# INLINE bar #-} + bar x y = (foo (Just x), foo (Just y)) + +Then 'bar' should jolly well have arity 4 (two dicts, two args), but +we ended up with something like + bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ... + in \x,y. ) + +This is all a bit ad-hoc; eg it relies on knowing that implication +constraints build tuples. + --------------------- Implicit parameters --------------------------------- \begin{code} @@ -916,28 +966,6 @@ substEqSpec subst eq_spec = [ (substTyVar subst tv, substTy subst ty) | (tv,ty) <- eq_spec] \end{code} ---------------------- The stupid theta (sigh) --------------------------------- - -\begin{code} -dataConsStupidTheta :: [DataCon] -> ThetaType --- Union the stupid thetas from all the specified constructors (non-empty) --- All the constructors should have the same result type, modulo alpha conversion --- The resulting ThetaType uses type variables from the *first* constructor in the list --- --- It's here because it's used in MkId.mkRecordSelId, and in TcExpr -dataConsStupidTheta (con1:cons) - = nubBy tcEqPred all_preds - where - all_preds = dataConStupidTheta con1 ++ other_stupids - res_ty1 = dataConOrigResTy con1 - other_stupids = [ substPred subst pred - | con <- cons - , let (tvs, _, _, res_ty) = dataConSig con - Just subst = tcMatchTy (mkVarSet tvs) res_ty res_ty1 - , pred <- dataConStupidTheta con ] -dataConsStupidTheta [] = panic "dataConsStupidTheta" -\end{code} - %************************************************************************ %* * @@ -957,10 +985,13 @@ isSigmaTy (FunTy a _) = isPredTy a isSigmaTy _ = False isOverloadedTy :: Type -> Bool +-- Yes for a type of a function that might require evidence-passing +-- Used only by bindInstsOfLocalFuns/Pats +-- NB: be sure to check for type with an equality predicate; hence isCoVar isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty' -isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty -isOverloadedTy (FunTy a _) = isPredTy a -isOverloadedTy _ = False +isOverloadedTy (ForAllTy tv ty) = isCoVar tv || isOverloadedTy ty +isOverloadedTy (FunTy a _) = isPredTy a +isOverloadedTy _ = False isPredTy :: Type -> Bool -- Belongs in TcType because it does -- not look through newtypes, or predtypes (of course) @@ -999,8 +1030,9 @@ is_tc uniq ty = case tcSplitTyConApp_maybe ty of -- hence no 'coreView'. This could, however, be changed without breaking -- any code. isOpenSynTyConApp :: TcTauType -> Bool -isOpenSynTyConApp (TyConApp tc _) = isOpenSynTyCon tc -isOpenSynTyConApp _other = False +isOpenSynTyConApp (TyConApp tc tys) = isOpenSynTyCon tc && + length tys == tyConArity tc +isOpenSynTyConApp _other = False \end{code} @@ -1198,6 +1230,18 @@ isFFILabelTy :: Type -> Bool -- or a newtype of either. isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey] +isFFIPrimArgumentTy :: DynFlags -> Type -> Bool +-- Checks for valid argument type for a 'foreign import prim' +-- Currently they must all be simple unlifted types. +isFFIPrimArgumentTy dflags ty + = checkRepTyCon (legalFIPrimArgTyCon dflags) ty + +isFFIPrimResultTy :: DynFlags -> Type -> Bool +-- Checks for valid result type for a 'foreign import prim' +-- Currently it must be an unlifted type, including unboxed tuples. +isFFIPrimResultTy dflags ty + = checkRepTyCon (legalFIPrimResultTyCon dflags) ty + isFFIDotnetTy :: DynFlags -> Type -> Bool isFFIDotnetTy dflags ty = checkRepTyCon (\ tc -> (legalFIResultTyCon dflags tc || @@ -1250,14 +1294,19 @@ toDNType ty ] checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool - -- Look through newtypes - -- Non-recursive ones are transparent to splitTyConApp, - -- but recursive ones aren't. Manuel had: - -- newtype T = MkT (Ptr T) - -- and wanted it to work... -checkRepTyCon check_tc ty - | Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc - | otherwise = False +-- Look through newtypes, but *not* foralls +-- Should work even for recursive newtypes +-- eg Manuel had: newtype T = MkT (Ptr T) +checkRepTyCon check_tc ty + = go [] ty + where + go rec_nts ty + | Just (tc,tys) <- splitTyConApp_maybe ty + = case carefullySplitNewType_maybe rec_nts tc tys of + Just (rec_nts', ty') -> go rec_nts' ty' + Nothing -> check_tc tc + | otherwise + = False checkRepTyConKey :: [Unique] -> Type -> Bool -- Like checkRepTyCon, but just looks at the TyCon key @@ -1318,6 +1367,26 @@ boxedMarshalableTyCon tc , stablePtrTyConKey , boolTyConKey ] + +legalFIPrimArgTyCon :: DynFlags -> TyCon -> Bool +-- Check args of 'foreign import prim', only allow simple unlifted types. +-- Strictly speaking it is unnecessary to ban unboxed tuples here since +-- currently they're of the wrong kind to use in function args anyway. +legalFIPrimArgTyCon dflags tc + = dopt Opt_UnliftedFFITypes dflags + && isUnLiftedTyCon tc + && not (isUnboxedTupleTyCon tc) + +legalFIPrimResultTyCon :: DynFlags -> TyCon -> Bool +-- Check result type of 'foreign import prim'. Allow simple unlifted +-- types and also unboxed tuple result types '... -> (# , , #)' +legalFIPrimResultTyCon dflags tc + = dopt Opt_UnliftedFFITypes dflags + && isUnLiftedTyCon tc + && (isUnboxedTupleTyCon tc + || case tyConPrimRep tc of -- Note [Marshalling VoidRep] + VoidRep -> False + _ -> True) \end{code} Note [Marshalling VoidRep]