X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=0cc60031892cd69c8cfeddc92e5ad8731d7c9fd6;hb=7676e57a3a0868448cad6e52aa1e69ef2d76158c;hp=af44ef483a9fe563a4a9a92b9ce7bd228018b726;hpb=ef47b5c2f44fce638b623c9cf5bb2f7f62ba619d;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index af44ef4..0cc6003 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -33,7 +33,7 @@ module CoreUtils ( -- Equality cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg, - dataConInstPat + dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat ) where #include "HsVersions.h" @@ -44,8 +44,9 @@ import GLAEXTS -- For `xori` import CoreSyn import CoreFVs ( exprFreeVars ) import PprCore ( pprCoreExpr ) -import Var ( Var, TyVar, CoVar, isCoVar, tyVarKind, setVarUnique, - mkCoVar, mkTyVar, mkCoVar ) +import Var ( Var, TyVar, CoVar, isCoVar, tyVarKind, mkCoVar, mkTyVar ) +import OccName ( mkVarOccFS ) +import SrcLoc ( noSrcLoc ) import VarSet ( unionVarSet ) import VarEnv import Name ( hashName, mkSysTvName ) @@ -54,13 +55,15 @@ import Packages ( isDllName ) #endif import Literal ( hashLiteral, literalType, litIsDupable, litIsTrivial, isZeroLit, Literal( MachLabel ) ) -import DataCon ( DataCon, dataConRepArity, - isVanillaDataCon, dataConTyCon, dataConRepArgTys, - dataConUnivTyVars, dataConExTyVars, dataConEqSpec ) +import DataCon ( DataCon, dataConRepArity, eqSpecPreds, + dataConTyCon, dataConRepArgTys, + dataConUnivTyVars, dataConExTyVars, dataConEqSpec, + dataConOrigArgTys, dataConTheta ) import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap ) import Id ( Id, idType, globalIdDetails, idNewStrictness, mkWildId, idArity, idName, idUnfolding, idInfo, - isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal, + isOneShotBndr, isStateHackType, + isDataConWorkId_maybe, mkSysLocal, mkUserLocal, isDataConWorkId, isBottomingId, isDictId ) import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo ) @@ -68,14 +71,14 @@ import NewDemand ( appIsBottom ) import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy, tcEqTypeX, applyTys, isUnLiftedType, seqType, mkTyVarTy, - splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe, + splitForAllTy_maybe, isForAllTy, splitTyConApp_maybe, coreEqType, funResultTy, applyTy, - substTyWith, mkPredTy + substTyWith, mkPredTy, zipOpenTvSubst, substTy ) import Coercion ( Coercion, mkTransCoercion, coercionKind, - splitNewTypeRepCo_maybe, mkSymCoercion, mkLeftCoercion, - mkRightCoercion, decomposeCo, coercionKindPredTy, - splitCoercionKind, mkEqPred ) + splitNewTypeRepCo_maybe, mkSymCoercion, + decomposeCo, coercionKindPredTy, + splitCoercionKind ) import TyCon ( tyConArity ) import TysWiredIn ( boolTy, trueDataCon, falseDataCon ) import CostCentre ( CostCentre ) @@ -86,6 +89,7 @@ import Outputable import DynFlags ( DynFlags, DynFlag(Opt_DictsCheap), dopt ) import TysPrim ( alphaTy ) -- Debugging only import Util ( equalLength, lengthAtLeast, foldl2 ) +import FastString ( FastString ) \end{code} @@ -208,8 +212,8 @@ mkInlineMe e = Note InlineMe e \begin{code} mkCoerce :: Coercion -> CoreExpr -> CoreExpr mkCoerce co (Cast expr co2) - = ASSERT(let { (from_ty, to_ty) = coercionKind co; - (from_ty2, to_ty2) = coercionKind co2} in + = ASSERT(let { (from_ty, _to_ty) = coercionKind co; + (_from_ty2, to_ty2) = coercionKind co2} in from_ty `coreEqType` to_ty2 ) mkCoerce (mkTransCoercion co2 co) expr @@ -677,52 +681,91 @@ deepCast ty tyVars co -- coArgs = [right (left (left co)), right (left co), right co] coArgs = decomposeCo (length tyVars) co --- This goes here to avoid circularity between DataCon and Id -dataConInstPat :: [Unique] -- An infinite list of uniques - -> DataCon - -> [Type] -- Types to instantiate the universally quantified tyvars - -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables -dataConInstPat uniqs con inst_tys +-- These InstPat functions go here to avoid circularity between DataCon and Id +dataConRepInstPat = dataConInstPat dataConRepArgTys (repeat (FSLIT("ipv"))) +dataConRepFSInstPat = dataConInstPat dataConRepArgTys +dataConOrigInstPat = dataConInstPat dc_arg_tys (repeat (FSLIT("ipv"))) + where + dc_arg_tys dc = map mkPredTy (dataConTheta dc) ++ dataConOrigArgTys dc + -- Remember to include the existential dictionaries + +dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys + -> [FastString] -- A long enough list of FSs to use for names + -> [Unique] -- An equally long list of uniques, at least one for each binder + -> DataCon + -> [Type] -- Types to instantiate the universally quantified tyvars + -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables +-- dataConInstPat arg_fun fss us con inst_tys returns a triple +-- (ex_tvs, co_tvs, arg_ids), +-- +-- ex_tvs are intended to be used as binders for existential type args +-- +-- co_tvs are intended to be used as binders for coercion args and the kinds +-- of these vars have been instantiated by the inst_tys and the ex_tys +-- +-- arg_ids are indended to be used as binders for value arguments, including +-- dicts, and their types have been instantiated with inst_tys and ex_tys +-- +-- Example. +-- The following constructor T1 +-- +-- data T a where +-- T1 :: forall b. Int -> b -> T(a,b) +-- ... +-- +-- has representation type +-- forall a. forall a1. forall b. (a :=: (a1,b)) => +-- Int -> b -> T a +-- +-- dataConInstPat fss us T1 (a1',b') will return +-- +-- ([a1'', b''], [c :: (a1', b'):=:(a1'', b'')], [x :: Int, y :: b'']) +-- +-- where the double-primed variables are created with the FastStrings and +-- Uniques given as fss and us +dataConInstPat arg_fun fss uniqs con inst_tys = (ex_bndrs, co_bndrs, id_bndrs) where univ_tvs = dataConUnivTyVars con ex_tvs = dataConExTyVars con - arg_tys = dataConRepArgTys con + arg_tys = arg_fun con eq_spec = dataConEqSpec con - eq_preds = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- eq_spec ] + eq_preds = eqSpecPreds eq_spec n_ex = length ex_tvs n_co = length eq_spec - n_id = length arg_tys - -- split the uniques - (ex_uniqs, uniqs') = splitAt n_ex uniqs + -- split the Uniques and FastStrings + (ex_uniqs, uniqs') = splitAt n_ex uniqs (co_uniqs, id_uniqs) = splitAt n_co uniqs' - -- make existential type variables - mk_ex_var uniq var = setVarUnique var uniq - ex_bndrs = zipWith mk_ex_var ex_uniqs ex_tvs + (ex_fss, fss') = splitAt n_ex fss + (co_fss, id_fss) = splitAt n_co fss' - -- make the instantiation substitution - inst_subst = substTyWith (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs) + -- Make existential type variables + ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs + mk_ex_var uniq fs var = mkTyVar new_name kind + where + new_name = mkSysTvName uniq fs + kind = tyVarKind var - -- make a new coercion vars, instantiating kind - mk_co_var uniq eq_pred = mkCoVar new_name (inst_subst (mkPredTy eq_pred)) - where - new_name = mkSysTvName uniq FSLIT("co") + -- Make the instantiating substitution + subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs) - co_bndrs = zipWith mk_co_var co_uniqs eq_preds + -- Make new coercion vars, instantiating kind + co_bndrs = zipWith3 mk_co_var co_uniqs co_fss eq_preds + mk_co_var uniq fs eq_pred = mkCoVar new_name co_kind + where + new_name = mkSysTvName uniq fs + co_kind = substTy subst (mkPredTy eq_pred) -- make value vars, instantiating types - mk_id_var uniq ty = mkSysLocal FSLIT("ca") uniq (inst_subst ty) - - id_bndrs = zipWith mk_id_var id_uniqs arg_tys - + mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcLoc + id_bndrs = zipWith3 mk_id_var id_uniqs id_fss arg_tys exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr]) -- Returns (Just (dc, [x1..xn])) if the argument expression is -- a constructor application of the form (dc x1 .. xn) - exprIsConApp_maybe (Cast expr co) = -- Maybe this is over the top, but here we try to turn -- coerce (S,T) ( x, y ) @@ -757,7 +800,7 @@ exprIsConApp_maybe (Cast expr co) arity = tyConArity tc n_ex_tvs = length dc_ex_tyvars - (univ_args, rest) = splitAt arity args + (_univ_args, rest) = splitAt arity args (ex_args, val_args) = splitAt n_ex_tvs rest arg_tys = dataConRepArgTys dc @@ -767,7 +810,6 @@ exprIsConApp_maybe (Cast expr co) deep arg_ty = deepCast arg_ty dc_tyvars co -- first we appropriately cast the value arguments - arg_cos = map deep arg_tys new_val_args = zipWith mkCoerce (map deep arg_tys) val_args -- then we cast the existential coercion arguments @@ -1106,8 +1148,12 @@ eta_expand n us (Lam v body) ty eta_expand n us expr ty = ASSERT2 (exprType expr `coreEqType` ty, ppr (exprType expr) $$ ppr ty) case splitForAllTy_maybe ty of { - Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty') + Just (tv,ty') -> + Lam lam_tv (eta_expand n us2 (App expr (Type (mkTyVarTy lam_tv))) (substTyWith [tv] [mkTyVarTy lam_tv] ty')) + where + lam_tv = mkTyVar (mkSysTvName uniq FSLIT("etaT")) (tyVarKind tv) + (uniq:us2) = us ; Nothing -> case splitFunTy_maybe ty of { @@ -1127,7 +1173,7 @@ eta_expand n us expr ty case splitNewTypeRepCo_maybe ty of { Just(ty1,co) -> - mkCoerce co (eta_expand n us (mkCoerce (mkSymCoercion co) expr) ty1) ; + mkCoerce (mkSymCoercion co) (eta_expand n us (mkCoerce co expr) ty1) ; Nothing -> -- We have an expression of arity > 0, but its type isn't a function