X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FGenerics.lhs;h=ca05c3921964deaec90637b102b9513177fdfbab;hb=1553c7788e7f663bfc55813158325d695a21a229;hp=10f9eedc55b38130a14a361806bfaabe656757a0;hpb=4102e5cec12cd96f59260aee2c6da01616b97467;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index 10f9eed..ca05c39 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -4,40 +4,41 @@ module Generics ( mkTyConGenInfo, mkGenericRhs, ) where -import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) import RnHsSyn ( RenamedHsExpr ) -import HsSyn ( HsExpr(..), InPat(..), mkSimpleMatch ) +import HsSyn ( HsExpr(..), InPat(..), mkSimpleMatch, placeHolderType ) -import Type ( Type, isUnLiftedType, applyTys, tyVarsOfType, tyVarsOfTypes, - mkTyVarTys, mkForAllTys, mkTyConApp, splitFunTys, - mkFunTy, isTyVarTy, - splitSigmaTy, getTyVar, splitTyConApp_maybe, funTyCon +import Type ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes, + mkTyVarTys, mkForAllTys, mkTyConApp, + mkFunTy, isTyVarTy, getTyVar_maybe, + funTyCon ) +import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy ) +import DataCon ( DataCon, dataConOrigArgTys, dataConWrapId, dataConId, isExistentialDataCon ) -import DataCon ( DataCon, dataConOrigArgTys, dataConWrapId, dataConId ) - -import TyCon ( TyCon, tyConTyVars, tyConDataConsIfAvailable, +import TyCon ( TyCon, tyConTyVars, tyConDataCons_maybe, tyConGenInfo, isNewTyCon, newTyConRep, isBoxedTupleTyCon ) -import Name ( Name, mkSysLocalName ) -import CoreSyn ( mkLams, Expr(..), CoreExpr, AltCon(..), Note(..), +import Name ( Name, mkSystemName ) +import CoreSyn ( mkLams, Expr(..), CoreExpr, AltCon(..), mkConApp, Alt, mkTyApps, mkVarApps ) +import CoreUtils ( exprArity ) import BasicTypes ( EP(..), Boxity(..) ) import Var ( TyVar ) -import VarSet ( isEmptyVarSet ) -import Id ( Id, mkTemplateLocal, idType, idName, - mkTemplateLocalsNum, mkId +import VarSet ( varSetElems ) +import Id ( Id, mkVanillaGlobal, idType, idName, + mkTemplateLocal, mkTemplateLocalsNum ) import TysWiredIn ( genericTyCons, genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon, inlDataCon, crossTyCon, crossDataCon ) -import IdInfo ( vanillaIdInfo, setUnfoldingInfo ) +import IdInfo ( noCafNoTyGenIdInfo, setUnfoldingInfo, setArityInfo ) import CoreUnfold ( mkTopUnfolding ) -import Unique ( mkBuiltinUnique ) +import Maybe ( isNothing ) import SrcLoc ( builtinSrcLoc ) -import Maybes ( expectJust ) +import Unique ( mkBuiltinUnique ) +import Util ( takeList ) import Outputable #include "HsVersions.h" @@ -188,7 +189,7 @@ validGenericInstanceType :: Type -> Bool -- f {| a + Int |} validGenericInstanceType inst_ty - = case splitTyConApp_maybe inst_ty of + = case tcSplitTyConApp_maybe inst_ty of Just (tycon, tys) -> all isTyVarTy tys && tycon `elem` genericTyCons Nothing -> False @@ -198,17 +199,24 @@ validGenericMethodType :: Type -> Bool -- * function arrow -- * boxed tuples -- * an arbitrary type not involving the class type variables -validGenericMethodType ty = valid ty - -valid ty - | isTyVarTy ty = True - | not (null arg_tys) = all valid arg_tys && valid res_ty - | no_tyvars_in_ty = True - | otherwise = isBoxedTupleTyCon tc && all valid tys + -- e.g. this is ok: forall b. Ord b => [b] -> a + -- where a is the class variable +validGenericMethodType ty + = valid tau where - (arg_tys, res_ty) = splitFunTys ty - no_tyvars_in_ty = isEmptyVarSet (tyVarsOfType ty) - Just (tc,tys) = splitTyConApp_maybe ty + (local_tvs, _, tau) = tcSplitSigmaTy ty + + valid ty + | isTyVarTy ty = True + | no_tyvars_in_ty = True + | otherwise = case tcSplitTyConApp_maybe ty of + Just (tc,tys) -> valid_tycon tc && all valid tys + Nothing -> False + where + no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty)) + + valid_tycon tc = tc == funTyCon || isBoxedTupleTyCon tc + -- Compare bimapApp, below \end{code} @@ -219,7 +227,7 @@ valid ty %************************************************************************ \begin{code} -mkTyConGenInfo :: DynFlags -> TyCon -> Name -> Name -> Maybe (EP Id) +mkTyConGenInfo :: TyCon -> [Name] -> Maybe (EP Id) -- mkTyConGenInfo is called twice -- once from TysWiredIn for Tuples -- once the typechecker TcTyDecls @@ -230,38 +238,44 @@ mkTyConGenInfo :: DynFlags -> TyCon -> Name -> Name -> Maybe (EP Id) -- The two names are the names constructed by the renamer -- for the fromT and toT conversion functions. -mkTyConGenInfo dflags tycon from_name to_name - | dopt Opt_Generics dflags - = Nothing - - | null datacons -- Abstractly imported types don't have - = Nothing -- to/from operations, (and should not need them) +mkTyConGenInfo tycon [from_name, to_name] + | isNothing maybe_datacons -- Abstractly imported types don't have + = Nothing -- to/from operations, (and should not need them) - -- If any of the constructor has an unboxed type as argument + -- If any of the constructor has an unboxed type as argument, -- then we can't build the embedding-projection pair, because -- it relies on instantiating *polymorphic* sum and product types -- at the argument types of the constructors - | any (any isUnLiftedType . dataConOrigArgTys) datacons + -- Nor can we do the job if it's an existential data constructor, + | or [ any isUnLiftedType (dataConOrigArgTys dc) || isExistentialDataCon dc + | dc <- datacons ] = Nothing | otherwise - = Just (EP { fromEP = mkId from_name from_ty from_id_info, - toEP = mkId to_name to_ty to_id_info }) + = Just (EP { fromEP = mkVanillaGlobal from_name from_ty from_id_info, + toEP = mkVanillaGlobal to_name to_ty to_id_info }) where - tyvars = tyConTyVars tycon -- [a, b, c] - datacons = tyConDataConsIfAvailable tycon -- [C, D] - tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c - tyvar_tys = mkTyVarTys tyvars + maybe_datacons = tyConDataCons_maybe tycon + Just datacons = maybe_datacons -- [C, D] - from_id_info = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn - to_id_info = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn + tyvars = tyConTyVars tycon -- [a, b, c] + tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c + tyvar_tys = mkTyVarTys tyvars + + from_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn + `setArityInfo` exprArity from_fn + to_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn + `setArityInfo` exprArity to_fn + -- It's important to set the arity info, so that + -- the calling convention (gotten from arity) + -- matches reality. from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty) to_ty = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty) (from_fn, to_fn, rep_ty) | isNewTyCon tycon - = ( mkLams tyvars $ Lam x $ Note (Coerce newrep_ty tycon_ty) (Var x), + = ( mkLams tyvars $ Lam x $ Var x, Var (dataConWrapId the_datacon), newrep_ty ) @@ -276,7 +290,7 @@ mkTyConGenInfo dflags tycon from_name to_name ---------------------- -- Newtypes only [the_datacon] = datacons - newrep_ty = applyTys (expectJust "mkGenTyConInfo" (newTyConRep tycon)) tyvar_tys + (_, newrep_ty) = newTyConRep tycon ---------------------- -- Non-newtypes only @@ -335,13 +349,6 @@ mk_sum_stuff i tyvars datacons where datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys - --- This constructs the c_of datatype from a DataCon and a Type --- The identity function at the moment. -cOfConstr :: DataCon -> Type -> Type -cOfConstr y z = z - - ---------------------------------------------------- -- Dealing with products ---------------------------------------------------- @@ -407,7 +414,51 @@ splitInHalf list = (left, right) Generating the Generic default method. Uses the bimaps to generate the actual method. All of this is rather incomplete, but it would be nice -to make even this work. +to make even this work. Example + + class Foo a where + op :: Op a + + instance Foo T + +Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs: + + instance Foo T where + op = + +To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where + + toOp :: Op Trep -> Op T + fromOp :: Op T -> Op Trep + +(the bimap) and then fill in the RHS with + + instance Foo T where + op = toOp op + +Remember, we're generating a RenamedHsExpr, so the result of all this +will be fed to the type checker. So the 'op' on the RHS will be +at the representation type for T, Trep. + + +A note about polymorphism. Suppose the class op is polymorphic: + + class Baz a where + op :: forall b. Ord b => a -> b -> b + +Then we can still generate a bimap with + + toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b) + +and fill in the instance decl thus + + instance Foo T where + op = toOp op + +By the time the type checker has done its stuff we'll get + + instance Foo T where + op = \b. \dict::Ord b. toOp b (op Trep b dict) \begin{code} mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr @@ -419,37 +470,51 @@ mkGenericRhs sel_id tyvar tycon Just (EP from to) = tyConGenInfo tycon -- Caller checked this will succeed ep = EP (HsVar (idName from)) (HsVar (idName to)) - -- Takes out the ForAll and the Class rstrictions in front of the - -- type of the method. - (_,_,op_ty) = splitSigmaTy (idType sel_id) + -- Takes out the ForAll and the Class restrictions + -- in front of the type of the method. + (_,_,op_ty) = tcSplitSigmaTy (idType sel_id) + + -- Do it again! This deals with the case where the method type + -- is polymorphic -- see notes above + (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty -- Now we probably have a tycon in front -- of us, quite probably a FunTyCon. - bimap = generate_bimap (tyvar, ep) op_ty + bimap = generate_bimap (tyvar, ep, local_tvs) final_ty --- EP is the environment of to/from bimaps, but as we only have one type --- variable at the moment, there is only one EP. +type EPEnv = (TyVar, -- The class type variable + EP RenamedHsExpr, -- The EP it maps to + [TyVar] -- Other in-scope tyvars; they have an identity EP + ) ------------------- -generate_bimap :: (TyVar, EP RenamedHsExpr) -> Type -> EP RenamedHsExpr +generate_bimap :: EPEnv + -> Type + -> EP RenamedHsExpr -- Top level case - splitting the TyCon. -generate_bimap (tv,ep) ty | isTyVarTy ty = ASSERT( getTyVar "Generics.generate_bimap" ty == tv) ep - | otherwise = bimapApp (tv,ep) (splitTyConApp_maybe ty) +generate_bimap env@(tv,ep,local_tvs) ty + = case getTyVar_maybe ty of + Just tv1 | tv == tv1 -> ep -- The class tyvar + | otherwise -> ASSERT( tv1 `elem` local_tvs) -- One of the polymorphic tyvars of the method + idEP + Nothing -> bimapApp env (tcSplitTyConApp_maybe ty) ------------------- -bimapApp :: (TyVar, EP RenamedHsExpr) -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr -bimapApp ep Nothing = panic "TcClassDecl: Type Application!" -bimapApp ep (Just (tycon, ty_args)) +bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr +bimapApp env Nothing = panic "TcClassDecl: Type Application!" +bimapApp env (Just (tycon, ty_args)) | tycon == funTyCon = bimapArrow arg_eps | isBoxedTupleTyCon tycon = bimapTuple arg_eps | otherwise = -- Otherwise validGenericMethodType will -- have checked that the type is a constant type - ASSERT( isEmptyVarSet (tyVarsOfTypes ty_args) ) - EP idexpr idexpr + ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) ) + idEP where - arg_eps = map (generate_bimap ep) ty_args + arg_eps = map (generate_bimap env) ty_args + (_,_,local_tvs) = env ------------------- +-- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b') bimapArrow [ep1, ep2] = EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body, toEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body } @@ -462,7 +527,7 @@ bimapTuple eps = EP { fromEP = mk_hs_lam [tuple_pat] from_body, toEP = mk_hs_lam [tuple_pat] to_body } where - names = take (length eps) genericNames + names = takeList eps genericNames tuple_pat = TuplePatIn (map VarPatIn names) Boxed eps_w_names = eps `zip` names to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed @@ -470,9 +535,13 @@ bimapTuple eps ------------------- genericNames :: [Name] -genericNames = [mkSysLocalName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]] +genericNames = [mkSystemName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]] (g1:g2:g3:_) = genericNames -mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body Nothing builtinSrcLoc)) -idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3) +mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType builtinSrcLoc)) + +idEP :: EP RenamedHsExpr +idEP = EP idexpr idexpr + where + idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3) \end{code}