-- And some particular Ids; see below for why they are wired in
wiredInIds, ghcPrimIds,
unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId,
- lazyId, lazyIdUnfolding, lazyIdKey,
+ lazyId, lazyIdUnfolding, lazyIdKey,
mkRuntimeErrorApp,
rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
)
import TysWiredIn ( charTy, mkListTy )
import PrelRules ( primOpRules )
-import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes, newTyConInstRhs )
+import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes, newTyConInstRhs, coreEqType,
+ PredType(..),
+ mkTopTvSubst, substTyVar )
+import TcGadt ( gadtRefine, refineType, emptyRefinement )
+import HsBinds ( ExprCoFn(..), isIdCoercion )
import Coercion ( mkSymCoercion, mkUnsafeCoercion,
- splitRecNewTypeCo_maybe )
+ splitNewTypeRepCo_maybe, isEqPred )
import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
mkTyConApp, mkTyVarTys, mkClassPred,
mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy,
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 )
+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 )
import DataCon ( DataCon, DataConIds(..), dataConTyCon, dataConUnivTyVars,
dataConFieldLabels, dataConRepArity, dataConResTys,
- dataConRepArgTys, dataConRepType,
+ dataConRepArgTys, dataConRepType, dataConFullSig,
dataConSig, dataConStrictMarks, dataConExStricts,
splitProductType, isVanillaDataCon, dataConFieldType,
dataConInstOrigArgTys, deepSplitProductType
import Util ( dropList, isSingleton )
import Outputable
import FastString
-import ListSetOps ( assoc )
+import ListSetOps ( assoc, minusList )
\end{code}
%************************************************************************
= NewDC nt_wrap_id
| any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper
+ || not (null eq_spec)
= AlgDC (Just alg_wrap_id) wrk_id
| otherwise -- Algebraic, no wrapper
= AlgDC Nothing wrk_id
where
- (tvs, theta, orig_arg_tys) = dataConSig data_con
- tycon = dataConTyCon data_con
+ (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys) = dataConFullSig data_con
+ tycon = dataConTyCon data_con
- dict_tys = mkPredTys theta
- all_arg_tys = dict_tys ++ orig_arg_tys
- tycon_args = dataConUnivTyVars data_con
- result_ty_args = (mkTyVarTys tycon_args)
- result_ty = mkTyConApp tycon result_ty_args
-
- wrap_ty = mkForAllTys tvs (mkFunTys all_arg_tys result_ty)
+ ----------- Wrapper --------------
-- We used to include the stupid theta in the wrapper's args
-- but now we don't. Instead the type checker just injects these
-- extra constraints where necessary.
+ wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
+ subst = mkTopTvSubst eq_spec
+ dict_tys = mkPredTys theta
+ result_ty_args = map (substTyVar subst) univ_tvs
+ result_ty = mkTyConApp tycon result_ty_args
+ wrap_ty = mkForAllTys wrap_tvs $ mkFunTys dict_tys $
+ mkFunTys orig_arg_tys $ result_ty
+ -- NB: watch out here if you allow user-written equality
+ -- constraints in data constructor signatures
----------- Worker (algebraic data types only) --------------
-- The *worker* for the data constructor is the function that
-- No existentials on a newtype, but it can have a context
-- e.g. newtype Eq a => T a = MkT (...)
mkCompulsoryUnfolding $
- mkLams tvs $ Lam id_arg1 $
+ mkLams wrap_tvs $ Lam id_arg1 $
wrapNewTypeBody tycon result_ty_args
(Var id_arg1)
-- we want to see that w is strict in its two arguments
alg_unf = mkTopUnfolding $ Note InlineMe $
- mkLams tvs $
+ mkLams wrap_tvs $
mkLams dict_args $ mkLams id_args $
foldr mk_case con_app
(zip (dict_args ++ id_args) all_strict_marks)
i3 []
- con_app i rep_ids = mkApps (Var wrk_id)
- (map varToCoreExpr (tvs ++ reverse rep_ids))
+ con_app i rep_ids = Var wrk_id `mkTyApps` result_ty_args
+ `mkVarApps` ex_tvs
+ `mkTyApps` map snd eq_spec
+ `mkVarApps` reverse rep_ids
(dict_args,i2) = mkLocals 1 dict_tys
(id_args,i3) = mkLocals i2 orig_arg_tys
stupid_dict_tys = mkPredTys (dataConsStupidTheta data_cons_w_field)
n_stupid_dicts = length stupid_dict_tys
- (field_tyvars,field_theta,field_tau) = tcSplitSigmaTy field_ty
+ (field_tyvars,pre_field_theta,field_tau) = tcSplitSigmaTy field_ty
+
+ field_theta = filter (not . isEqPred) pre_field_theta
field_dict_tys = mkPredTys field_theta
n_field_dict_tys = length field_dict_tys
-- If the field has a universally quantified type we have to
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)
+ = (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
- (dc_tvs, dc_theta, dc_arg_tys) = dataConSig data_con
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, _) = refineType refinement (idType the_arg_id)
+
+ rhs = 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
-- The Ints passed around are just for creating fresh locals
unboxProduct :: Int -> CoreExpr -> Type -> (Int -> [Id] -> CoreExpr) -> Type -> CoreExpr
unboxProduct i arg arg_ty body res_ty
- = mkUnpackCase the_id arg con_args boxing_con rhs
+ = result
where
- (_, _, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty
+ result = mkUnpackCase the_id arg arg_ty con_args boxing_con rhs
+ (tycon, tycon_args, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty
([the_id], i') = mkLocals i [arg_ty]
(con_args, i'') = mkLocals i' tys
rhs = body i'' con_args
-mkUnpackCase :: Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr
-mkUnpackCase bndr arg unpk_args boxing_con body
- = Case cast_arg bndr (exprType body) [(DataAlt boxing_con, unpk_args, body)]
+mkUnpackCase :: Id -> CoreExpr -> Type -> [Id] -> DataCon -> CoreExpr -> CoreExpr
+-- (mkUnpackCase x e args Con body)
+-- returns
+-- case (e `cast` ...) of bndr { Con args -> body }
+--
+-- the type of the bndr passed in is irrelevent
+mkUnpackCase bndr arg arg_ty unpk_args boxing_con body
+ = Case cast_arg (setIdType bndr bndr_ty) (exprType body) [(DataAlt boxing_con, unpk_args, body)]
where
- cast_arg = go (idType bndr) arg
+ (cast_arg, bndr_ty) = go (idType bndr) arg
go ty arg
| res@(tycon, tycon_args, _, _) <- splitProductType "mkUnpackCase" ty
, isNewTyCon tycon && not (isRecursiveTyCon tycon)
= go (newTyConInstRhs tycon tycon_args)
(unwrapNewTypeBody tycon tycon_args arg)
- | otherwise = arg
+ | otherwise = (arg, ty)
-- ...and the dual
reboxProduct :: [Unique] -- uniques to create new local binders
(tycon, tycon_args, pack_con, con_arg_tys) = splitProductType "mkProductBox" ty
result_expr
- | isNewTyCon tycon
+ | isNewTyCon tycon && not (isRecursiveTyCon tycon)
= wrap (mkProductBox arg_ids (newTyConInstRhs tycon tycon_args))
| otherwise = mkConApp pack_con (map Type tycon_args ++ map Var arg_ids)