substTyWith, substTyVar, mkTopTvSubst,
mkForAllTys, mkFunTys, mkTyConApp, mkTyVarTy, mkTyVarTys,
splitTyConApp_maybe, newTyConInstRhs,
- mkPredTys, isStrictPred, pprType
+ mkPredTys, isStrictPred, pprType, mkPredTy
)
import Coercion ( isEqPred, mkEqPred )
import TyCon ( TyCon, FieldLabel, tyConDataCons,
isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon,
isNewTyCon, isRecursiveTyCon )
import Class ( Class, classTyCon )
-import Name ( Name, NamedThing(..), nameUnique )
-import Var ( TyVar, Id )
+import Name ( Name, NamedThing(..), nameUnique, mkSysTvName, mkSystemName )
++ import Var ( TyVar, CoVar, Id, mkTyVar, tyVarKind, setVarUnique,
++ mkCoVar )
import BasicTypes ( Arity, StrictnessMark(..) )
import Outputable
import Unique ( Unique, Uniquable(..) )
import Util ( zipEqual, zipWithEqual )
import List ( partition )
import Maybes ( expectJust )
+import FastString
\end{code}
where
tyvars = univ_tvs ++ ex_tvs
+
-- And the same deal for the original arg tys
dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,
mkLocalId name ty = mkLocalIdWithInfo name ty vanillaIdInfo
-- SysLocal: for an Id being created by the compiler out of thin air...
+mkSysLocal :: FastString -> Unique -> Type -> Id
+mkSysLocal fs uniq ty = mkLocalId (mkSystemVarName uniq fs) ty
+
+
-- UserLocal: an Id with a name the user might recognize...
mkUserLocal :: OccName -> Unique -> Type -> SrcLoc -> Id
-mkSysLocal :: FastString -> Unique -> Type -> Id
mkVanillaGlobal :: Name -> Type -> IdInfo -> Id
-mkSysLocal fs uniq ty = mkLocalId (mkSystemVarName uniq fs) ty
-
mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty
mkVanillaGlobal = mkGlobalId VanillaGlobal
\end{code}
import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes, newTyConInstRhs, coreEqType,
PredType(..),
mkTopTvSubst, substTyVar )
+import TcGadt ( gadtRefine, refineType, emptyRefinement )
+import HsBinds ( ExprCoFn(..), isIdCoercion )
import Coercion ( mkSymCoercion, mkUnsafeCoercion,
splitNewTypeRepCo_maybe, isEqPred )
import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta
)
-import CoreUtils ( exprType )
+import CoreUtils ( exprType, dataConInstPat )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding )
import Literal ( nullAddrLit, mkStringLit )
import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon,
newTyConCo, tyConArity )
import Class ( Class, classTyCon, classSelIds )
-import Var ( Id, TyVar, Var, setIdType, mkWildCoVar )
+import Var ( Id, TyVar, Var, setIdType, mkCoVar, mkWildCoVar )
import VarSet ( isEmptyVarSet, subVarSet, varSetElems )
-import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) )
+import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..),
+ mkSysTvName )
import OccName ( mkOccNameFS, varName )
import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag )
import ForeignCall ( ForeignCall )
stupid_dict_tys = mkPredTys (dataConsStupidTheta data_cons_w_field)
n_stupid_dicts = length stupid_dict_tys
- (pre_field_tyvars,pre_field_theta,field_tau) = tcSplitSigmaTy field_ty
- -- tcSplitSigmaTy puts tyvars with EqPred kinds in with the theta, but
- -- this is not what we want here, so we need to split out the EqPreds
- -- as new wild tyvars
- field_tyvars = pre_field_tyvars ++ eq_vars
- eq_vars = map (mkWildCoVar . mkPredTy)
+ (field_tyvars,pre_field_theta,field_tau) = tcSplitSigmaTy field_ty
+
+ mk_co_var k = mkWildCoVar k
+ eq_vars = map (mk_co_var . mkPredTy)
(filter isEqPred pre_field_theta)
+
field_theta = filter (not . isEqPred) pre_field_theta
field_dict_tys = mkPredTys field_theta
n_field_dict_tys = length field_dict_tys
mk_alt data_con
= -- In the non-vanilla case, the pattern must bind type variables and
-- the context stuff; hence the arg_prefix binding below
- mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids) (Var the_arg_id)
+ mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids) rhs
where
(arg_prefix, arg_ids)
| isVanillaDataCon data_con -- Instantiate from commmon base
= ([], mkTemplateLocalsNum arg_base (dataConInstOrigArgTys data_con res_tys))
| otherwise -- The case pattern binds type variables, which are used
-- in the types of the arguments of the pattern
- = (dc_tvs ++ mkTemplateLocalsNum arg_base (mkPredTys dc_theta),
- mkTemplateLocalsNum arg_base' dc_arg_tys)
-
- (pre_dc_tvs, pre_dc_theta, dc_arg_tys) = dataConSig data_con
- -- again we need to pull the EqPreds out of dc_theta, into dc_tvs
- dc_eqvars = map (mkWildCoVar . mkPredTy . fixEqPred) (filter isEqPred pre_dc_theta)
- -- The type of the record selector Id does not contain the univ tvs
- -- but rather their substitution according to the eq_spec. Therefore
- -- the coercion arguments bound in the case alternative will just
- -- have reflexive coercion kinds
- fixEqPred (EqPred ty1 ty2) = EqPred ty2 ty2
- dc_tvs = drop (length (dataConUnivTyVars data_con)) pre_dc_tvs ++ dc_eqvars
+ = (ex_tvs ++ co_tvs ++ dict_vs, field_vs)
+
+ (ex_tvs, co_tvs, arg_vs) = dataConInstPat uniqs' data_con res_tys
+ (dict_vs, field_vs) = splitAt (length dc_theta) arg_vs
+
+ (_, pre_dc_theta, dc_arg_tys) = dataConSig data_con
dc_theta = filter (not . isEqPred) pre_dc_theta
+
arg_base' = arg_base + length dc_theta
unpack_base = arg_base' + length dc_arg_tys
- uniqs = map mkBuiltinUnique [unpack_base..]
+
+ uniq_list = map mkBuiltinUnique [unpack_base..]
+
+ Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
+ (co_fn, out_ty) = refineType refinement (idType the_arg_id)
+
+ rhs = ASSERT(out_ty `coreEqType` field_tau) perform_co co_fn (Var the_arg_id)
+
+ perform_co (ExprCoFn co) expr = Cast expr co
+ perform_co id_co expr = ASSERT(isIdCoercion id_co) expr
+
+ -- split the uniq_list into two
+ uniqs = takeHalf uniq_list
+ uniqs' = takeHalf (drop 1 uniq_list)
+
+ takeHalf [] = []
+ takeHalf (h:_:t) = h:(takeHalf t)
+ takeHalf (h:t) = [h]
the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` arg_ids) field_label
field_lbls = dataConFieldLabels data_con
Id, DictId,
idName, idType, idUnique, idInfo, modifyIdInfo, maybeModifyIdInfo,
setIdName, setIdUnique, setIdType, setIdInfo, lazySetIdInfo,
- setIdExported, setIdNotExported,
+ setIdExported, setIdNotExported,
globalIdDetails, globaliseId,
import {-# SOURCE #-} IdInfo( GlobalIdDetails, notGlobalId, IdInfo, seqIdInfo )
import Name ( Name, NamedThing(..),
- setNameUnique, nameUnique, mkSysTvName
+ setNameUnique, nameUnique, mkSysTvName,
+ mkSystemVarName
)
import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey#,
mkBuiltinUnique )
import FastTypes
-import Outputable
+import FastString
+import Outputable
\end{code}
lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
| isNewTyCon (dataConTyCon con) = addErrL (mkNewTyDataConAltMsg scrut_ty alt)
| Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
- = addLoc (CaseAlt alt) $ lintBinders args $ \ args ->
+ = lintBinders args $ \ args ->
do { addLoc (CasePat alt) $ do
{ -- Check the pattern
hashExpr,
-- Equality
- cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg
+ cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg,
+
+ dataConInstPat
) where
#include "HsVersions.h"
import CoreSyn
import CoreFVs ( exprFreeVars )
import PprCore ( pprCoreExpr )
-import Var ( Var, TyVar, isCoVar, tyVarKind )
+import Var ( Var, TyVar, CoVar, isCoVar, tyVarKind, setVarUnique,
+ mkCoVar, mkTyVar, mkCoVar )
import VarSet ( unionVarSet )
import VarEnv
-import Name ( hashName )
+import Name ( hashName, mkSysTvName )
#if mingw32_TARGET_OS
import Packages ( isDllName )
#endif
litIsTrivial, isZeroLit, Literal( MachLabel ) )
import DataCon ( DataCon, dataConRepArity,
isVanillaDataCon, dataConTyCon, dataConRepArgTys,
- dataConUnivTyVars, dataConExTyVars )
+ dataConUnivTyVars, dataConExTyVars, dataConEqSpec )
import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
import Id ( Id, idType, globalIdDetails, idNewStrictness,
mkWildId, idArity, idName, idUnfolding, idInfo,
applyTys, isUnLiftedType, seqType, mkTyVarTy,
splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe,
splitTyConApp_maybe, coreEqType, funResultTy, applyTy,
- substTyWith
+ substTyWith, mkPredTy
)
import Coercion ( Coercion, mkTransCoercion, coercionKind,
splitNewTypeRepCo_maybe, mkSymCoercion, mkLeftCoercion,
mkRightCoercion, decomposeCo, coercionKindPredTy,
- splitCoercionKind )
+ splitCoercionKind, mkEqPred )
import TyCon ( tyConArity )
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
import CostCentre ( CostCentre )
-- 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
+ = (ex_bndrs, co_bndrs, id_bndrs)
+ where
+ univ_tvs = dataConUnivTyVars con
+ ex_tvs = dataConExTyVars con
+ arg_tys = dataConRepArgTys con
+ eq_spec = dataConEqSpec con
+ eq_preds = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- 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
+ (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
+
+ -- make the instantiation substitution
+ inst_subst = substTyWith (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
+
+ -- 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")
+
+ co_bndrs = zipWith mk_co_var co_uniqs eq_preds
+
+ -- 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
+
+
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)
emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds )
import InstEnv ( Instance(..), mkImportedInstance )
import CoreSyn
-import CoreUtils ( exprType )
+import CoreUtils ( exprType, dataConInstPat )
import CoreUnfold
import CoreLint ( lintUnfolding )
import WorkWrap ( mkWrapper )
import FastString ( FastString )
import Module ( Module, moduleName )
import UniqFM ( lookupUFM )
-import UniqSupply ( initUs_ )
+import UniqSupply ( initUs_, uniqsFromSupply )
import Outputable
import ErrUtils ( Message )
import Maybes ( MaybeErr(..) )
; tcIfaceDataAlt data_con inst_tys arg_occs rhs }
tcIfaceDataAlt con inst_tys arg_strs rhs
- = do { arg_names <- newIfaceNames (map mkVarOccFS arg_strs)
- ; let (tyvar_strs, id_strs) = splitAtList (dataConTyVars con) arg_strs
- ; tyvar_names <- mapM (newIfaceName . mkTyVarOcc) tyvar_strs
- ; id_names <- mapM (newIfaceName . mkVarOccFS) id_strs
- ; let ex_tvs = [ mkTyVar name (tyVarKind tv)
- | (name,tv) <- tyvar_names `zip` dataConExTyVars con ]
- arg_tys = dataConInstArgTys con (inst_tys ++ mkTyVarTys ex_tvs)
- arg_ids = ASSERT2( equalLength id_names arg_tys,
- ppr (con, tyvar_names++id_names, rhs) $$ ppr ex_tvs $$ ppr arg_tys )
- zipWith mkLocalId id_names arg_tys
-
- ; rhs' <- extendIfaceTyVarEnv ex_tvs $
+ = do { us <- newUniqueSupply
+ ; let uniqs = uniqsFromSupply us
+ ; let (ex_tvs, co_tvs, arg_ids) = dataConInstPat uniqs con inst_tys
+ all_tvs = ex_tvs ++ co_tvs
+
+ ; rhs' <- extendIfaceTyVarEnv all_tvs $
extendIfaceIdEnv arg_ids $
tcIfaceExpr rhs
; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
= do { b1 <- tvBindFlag tv1
; b2 <- tvBindFlag tv2
; case (b1,b2) of
- (BindMe, _) -> bind tv1 ty2
+ (BindMe, _) -> bind False tv1 ty2
- (AvoidMe, BindMe) -> bind tv2 ty1
- (AvoidMe, _) -> bind tv1 ty2
+ (AvoidMe, BindMe) -> bind True tv2 ty1
+ (AvoidMe, _) -> bind False tv1 ty2
(WildCard, WildCard) -> return subst
(WildCard, Skolem) -> return subst
- (WildCard, _) -> bind tv2 ty1
+ (WildCard, _) -> bind True tv2 ty1
(Skolem, WildCard) -> return subst
(Skolem, Skolem) -> failWith (misMatch ty1 ty2)
- (Skolem, _) -> bind tv2 ty1
+ (Skolem, _) -> bind True tv2 ty1
}
- | k1 `isSubKind` k2 = bindTv subst co tv2 ty1 -- Must update tv2
+ | k1 `isSubKind` k2 = bindTv subst (mkSymCoercion co) tv2 ty1 -- Must update tv2
| k2 `isSubKind` k1 = bindTv subst co tv1 ty2 -- Must update tv1
| otherwise = failWith (kindMisMatch tv1 ty2)
ty1 = TyVarTy tv1
k1 = tyVarKind tv1
k2 = tyVarKind tv2
- bind tv ty = return (extendVarEnv subst tv (co,ty))
+ bind swap tv ty = return (extendVarEnv subst tv (co',ty))
+ where
+ co' = if swap then mkSymCoercion co else co
uUnrefined subst co tv1 ty2 ty2' -- ty2 is not a type variable
| tv1 `elemVarSet` substTvSet subst (tyVarsOfType ty2')
projects / ghc-hetmet.git / commitdiff