X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FGenerics.lhs;h=cc611618f350b32c408ed25fd01c4f14179d4b70;hb=2205f0ceeb65d8acb7db953bf4fd2ad673dc55ee;hp=89e36c4fa1af209f7df621cb3a4079410e6b141e;hpb=01e0566e61e4222600c7ba0a2d35d6102fd1afb5;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index 89e36c4..cc61161 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -5,39 +5,41 @@ module Generics ( mkTyConGenInfo, mkGenericRhs, 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, 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, mkSysLocal ) +import MkId ( mkReboxingAlt, mkNewTypeBody ) 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 ( Unique, builtinUniques, mkBuiltinUnique ) +import Util ( takeList, dropList ) import Outputable +import FastString #include "HsVersions.h" \end{code} @@ -80,7 +82,8 @@ patterns (not Unit, this is done differently) is done in mk_inst_info HsOpTy is tied to Generic definitions which is not a very good design feature, indeed a bug. However, the check is easy to move from tcHsType back to mk_inst_info and everything will be fine. Also see -bug #5. +bug #5. [I don't think that this is the case anymore after SPJ's latest +changes in that regard. Delete this comment? -=chak/7Jun2] Generics.lhs @@ -187,7 +190,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 @@ -197,17 +200,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} @@ -218,7 +228,7 @@ valid ty %************************************************************************ \begin{code} -mkTyConGenInfo :: 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 @@ -229,35 +239,52 @@ mkTyConGenInfo :: TyCon -> Name -> Name -> Maybe (EP Id) -- The two names are the names constructed by the renamer -- for the fromT and toT conversion functions. -mkTyConGenInfo tycon from_name to_name - | null datacons -- Abstractly imported types don't have - = Nothing -- to/from operations, (and should not need them) +mkTyConGenInfo tycon [] + = Nothing -- This happens when we deal with the interface-file type + -- decl for a module compiled without -fgenerics - -- If any of the constructor has an unboxed type as argument +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, -- 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 + | null datacons -- There are no constructors; + = Nothing -- there are no values of this type + | otherwise - = Just (EP { fromEP = mkId from_name from_ty from_id_info, - toEP = mkId to_name to_ty to_id_info }) + = ASSERT( not (null datacons) ) -- mk_sum_stuff loops if no datacons + 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 $ mkNewTypeBody tycon newrep_ty (Var x), Var (dataConWrapId the_datacon), newrep_ty ) @@ -267,25 +294,27 @@ mkTyConGenInfo tycon from_name to_name idType rep_var ) -- x :: T a b c - x = mkTemplateLocal 1 tycon_ty + x = mkGenericLocal u1 tycon_ty + (u1 : uniqs) = builtinUniques ---------------------- -- Newtypes only [the_datacon] = datacons - newrep_ty = applyTys (expectJust "mkGenTyConInfo" (newTyConRep tycon)) tyvar_tys + (_, newrep_ty) = newTyConRep tycon ---------------------- -- Non-newtypes only -- Recurse over the sum first -- The "2" is the first free unique - (from_alts, to_inner, rep_var) = mk_sum_stuff 2 tyvars datacons + (from_alts, to_inner, rep_var) = mk_sum_stuff uniqs tyvars datacons +mkTyConGenInfo tycon names = pprPanic "mkTyConGenInfo" (ppr tycon <+> ppr names) ---------------------------------------------------- -- Dealing with sums ---------------------------------------------------- -mk_sum_stuff :: Int -- Base for generating unique names +mk_sum_stuff :: [Unique] -- Base for generating unique names -> [TyVar] -- Type variables over which the tycon is abstracted -> [DataCon] -- The data constructors -> ([Alt Id], CoreExpr, Id) @@ -300,29 +329,36 @@ mk_sum_stuff :: Int -- Base for generating unique names -- D a b c }} }, -- cd) -mk_sum_stuff i tyvars [datacon] +mk_sum_stuff us tyvars [datacon] = ([from_alt], to_body_fn app_exp, rep_var) where - types = dataConOrigArgTys datacon - datacon_vars = mkTemplateLocalsNum i types - new_i = i + length types - app_exp = mkVarApps (Var (dataConId datacon)) (tyvars ++ datacon_vars) - from_alt = (DataAlt datacon, datacon_vars, from_alt_rhs) + types = dataConOrigArgTys datacon -- Existentials already excluded + datacon_vars = zipWith mkGenericLocal us types + us' = dropList types us + + app_exp = mkVarApps (Var (dataConWrapId datacon)) (tyvars ++ datacon_vars) + from_alt = mkReboxingAlt us' datacon datacon_vars from_alt_rhs + -- We are talking about *user* datacons here; hence + -- dataConWrapId + -- mkReboxingAlt + + (_,args',_) = from_alt + us'' = dropList args' us' -- Conservative, but safe - (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff new_i datacon_vars + (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff us'' datacon_vars -mk_sum_stuff i tyvars datacons +mk_sum_stuff (u:us) tyvars datacons = (wrap inlDataCon l_from_alts ++ wrap inrDataCon r_from_alts, Case (Var rep_var) rep_var [(DataAlt inlDataCon, [l_rep_var], l_to_body), (DataAlt inrDataCon, [r_rep_var], r_to_body)], rep_var) where (l_datacons, r_datacons) = splitInHalf datacons - (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff (i+2) tyvars l_datacons - (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff (i+2) tyvars r_datacons + (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff us tyvars l_datacons + (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff us tyvars r_datacons rep_tys = [idType l_rep_var, idType r_rep_var] rep_ty = mkTyConApp plusTyCon rep_tys - rep_var = mkTemplateLocal i rep_ty + rep_var = mkGenericLocal u rep_ty wrap :: DataCon -> [Alt Id] -> [Alt Id] -- Wrap an application of the Inl or Inr constructor round each alternative @@ -331,21 +367,14 @@ 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 ---------------------------------------------------- -mk_prod_stuff :: Int -- Base for unique names +mk_prod_stuff :: [Unique] -- Base for unique names -> [Id] -- arg-ids; args of the original user-defined constructor -- They are bound enclosing from_rhs -- Please bind these in the to_body_fn - -> (Int, -- Depleted unique-name supply + -> ([Unique], -- Depleted unique-name supply CoreExpr, -- from-rhs: puts together the representation from the arg_ids CoreExpr -> CoreExpr, -- to_body_fn: takes apart the representation Id) -- The rep-id; please bind this to the representation @@ -361,26 +390,26 @@ mk_prod_stuff :: Int -- Base for unique names -- because the returned to_body_fns are nested. -- Hence the returned unqique-name supply -mk_prod_stuff i [] -- Unit case - = (i, +mk_prod_stuff (u:us) [] -- Unit case + = (us, Var (dataConWrapId genUnitDataCon), \x -> x, - mkTemplateLocal i (mkTyConApp genUnitTyCon [])) + mkGenericLocal u (mkTyConApp genUnitTyCon [])) -mk_prod_stuff i [arg_var] -- Singleton case - = (i, Var arg_var, \x -> x, arg_var) +mk_prod_stuff us [arg_var] -- Singleton case + = (us, Var arg_var, \x -> x, arg_var) -mk_prod_stuff i arg_vars -- Two or more - = (r_i, +mk_prod_stuff (u:us) arg_vars -- Two or more + = (us'', mkConApp crossDataCon (map Type rep_tys ++ [l_alt_rhs, r_alt_rhs]), \x -> Case (Var rep_var) rep_var [(DataAlt crossDataCon, [l_rep_var, r_rep_var], l_to_body_fn (r_to_body_fn x))], rep_var) where (l_arg_vars, r_arg_vars) = splitInHalf arg_vars - (l_i, l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff (i+1) l_arg_vars - (r_i, r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff l_i r_arg_vars - rep_var = mkTemplateLocal i (mkTyConApp crossTyCon rep_tys) + (us', l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff us l_arg_vars + (us'', r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff us' r_arg_vars + rep_var = mkGenericLocal u (mkTyConApp crossTyCon rep_tys) rep_tys = [idType l_rep_var, idType r_rep_var] \end{code} @@ -393,6 +422,9 @@ splitInHalf list = (left, right) half = length list `div` 2 left = take half list right = drop half list + +mkGenericLocal :: Unique -> Type -> Id +mkGenericLocal uniq ty = mkSysLocal FSLIT("g") uniq ty \end{code} %************************************************************************ @@ -403,7 +435,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 @@ -415,37 +491,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 } @@ -458,7 +548,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 @@ -466,9 +556,13 @@ bimapTuple eps ------------------- genericNames :: [Name] -genericNames = [mkSysLocalName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]] +genericNames = [mkSystemName (mkBuiltinUnique i) (mkFastString ('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}