import CoreSyn
import CoreFVs ( exprFreeVars )
import PprCore ( pprCoreExpr )
-import Var ( Var, TyVar, CoVar, isCoVar, tyVarKind, setVarUnique,
- mkCoVar, mkTyVar, mkCoVar )
-import OccName ( OccName, occNameFS, mkVarOccFS )
+import Var ( Var, TyVar, CoVar, isCoVar, tyVarKind, mkCoVar, mkTyVar )
+import OccName ( mkVarOccFS )
+import SrcLoc ( noSrcLoc )
import VarSet ( unionVarSet )
import VarEnv
import Name ( hashName, mkSysTvName )
import Literal ( hashLiteral, literalType, litIsDupable,
litIsTrivial, isZeroLit, Literal( MachLabel ) )
import DataCon ( DataCon, dataConRepArity, eqSpecPreds,
- isVanillaDataCon, dataConTyCon, dataConRepArgTys,
+ dataConTyCon, dataConRepArgTys,
dataConUnivTyVars, dataConExTyVars, dataConEqSpec,
- dataConOrigArgTys )
+ 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 )
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 )
\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
coArgs = decomposeCo (length tyVars) co
-- These InstPat functions go here to avoid circularity between DataCon and Id
-dataConOrigInstPat = dataConInstPat dataConOrigArgTys (repeat (FSLIT("ipv")))
-dataConRepInstPat = dataConInstPat dataConRepArgTys (repeat (FSLIT("ipv")))
+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
-> DataCon
-> [Type] -- Types to instantiate the universally quantified tyvars
-> ([TyVar], [CoVar], [Id]) -- Return instantiated variables
--- dataConInstPat arg_fun us fss con inst_tys returns a triple
+-- 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
-- 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 have their types instantiated with inst_tys and ex_tys
+-- dicts, and their types have been instantiated with inst_tys and ex_tys
--
-- Example.
-- The following constructor T1
-- ...
--
-- has representation type
--- forall a. forall a1. forall a2. forall b. (a :=: (a1,a2)) =>
+-- forall a. forall a1. forall b. (a :=: (a1,b)) =>
-- Int -> b -> T a
--
--- dataConInstPat us T1 (a1',a2') will return
+-- dataConInstPat fss us T1 (a1',b') will return
--
--- ([a1'', a2'', b''],[c :: (a1',a2'):=:(a1'',a2'')],[x :: Int,y :: b''])
+-- ([a1'', b''], [c :: (a1', b'):=:(a1'', b'')], [x :: Int, y :: b''])
--
--- where the double-primed variables are created from the unique list input
--- getting names from the FS list input
+-- 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
n_ex = length ex_tvs
n_co = length eq_spec
- n_id = length arg_tys
-- split the Uniques and FastStrings
(ex_uniqs, uniqs') = splitAt n_ex uniqs
(ex_fss, fss') = splitAt n_ex fss
(co_fss, id_fss) = splitAt n_co fss'
- -- make existential type variables
+ -- 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
- ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs
-
- -- make the instantiation substitution
- inst_subst = substTyWith (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
+ -- Make the instantiating substitution
+ subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
- -- make new coercion vars, instantiating kind
- mk_co_var uniq fs eq_pred = mkCoVar new_name (inst_subst (mkPredTy eq_pred))
+ -- 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_bndrs = zipWith3 mk_co_var co_uniqs co_fss eq_preds
+ co_kind = substTy subst (mkPredTy eq_pred)
-- make value vars, instantiating types
- mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (inst_subst ty) noSrcLoc
+ 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 )
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
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
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