hashExpr,
-- Equality
- cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg
+ cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg,
+
+ dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat
) 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 OccName ( OccName, occNameFS, mkVarOccFS )
import VarSet ( unionVarSet )
import VarEnv
-import Name ( hashName )
+import Name ( hashName, mkSysTvName )
#if mingw32_TARGET_OS
import Packages ( isDllName )
#endif
import Literal ( hashLiteral, literalType, litIsDupable,
litIsTrivial, isZeroLit, Literal( MachLabel ) )
-import DataCon ( DataCon, dataConRepArity,
+import DataCon ( DataCon, dataConRepArity, eqSpecPreds,
isVanillaDataCon, dataConTyCon, dataConRepArgTys,
- dataConUnivTyVars, dataConExTyVars )
+ dataConUnivTyVars, dataConExTyVars, dataConEqSpec,
+ dataConOrigArgTys )
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, coercionKindTyConApp,
- splitCoercionKind )
+ mkRightCoercion, decomposeCo, coercionKindPredTy,
+ splitCoercionKind, mkEqPred )
import TyCon ( tyConArity )
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
import CostCentre ( CostCentre )
import DynFlags ( DynFlags, DynFlag(Opt_DictsCheap), dopt )
import TysPrim ( alphaTy ) -- Debugging only
import Util ( equalLength, lengthAtLeast, foldl2 )
+import FastString ( FastString )
\end{code}
-- if to_ty `coreEqType` from_ty
-- then expr
-- else
- ASSERT2(from_ty `coreEqType` (exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionKindTyConApp co))
+ ASSERT2(from_ty `coreEqType` (exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionKindPredTy co))
(Cast expr co)
\end{code}
-- coArgs = [right (left (left co)), right (left co), right co]
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")))
+dataConRepFSInstPat = dataConInstPat dataConRepArgTys
+
+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 = arg_fun con
+ eq_spec = dataConEqSpec con
+ eq_preds = eqSpecPreds eq_spec
+
+ 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
+ (co_uniqs, id_uniqs) = splitAt n_co uniqs'
+
+ (ex_fss, fss') = splitAt n_ex fss
+ (co_fss, id_fss) = splitAt n_co fss'
+
+ -- make existential type variables
+ 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 new coercion vars, instantiating kind
+ mk_co_var uniq fs eq_pred = mkCoVar new_name co_kind
+ where
+ new_name = mkSysTvName uniq fs
+ co_kind = inst_subst (mkPredTy eq_pred)
+
+ co_bndrs = zipWith3 mk_co_var co_uniqs co_fss eq_preds
+
+ -- make value vars, instantiating types
+ mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (inst_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 )
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 {
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
projects / ghc-hetmet.git / blobdiff