intPrimTy, realWorldStatePrimTy
)
import TysWiredIn ( boolTy, charTy, mkListTy )
-import PrelMods ( pREL_ERR, pREL_GHC )
+import PrelNames ( pREL_ERR, pREL_GHC )
import PrelRules ( primOpRule )
import Rules ( addRule )
-import Type ( Type, ClassContext, mkDictTy, mkTyConApp, mkTyVarTys,
+import Type ( Type, ClassContext, mkDictTy, mkDictTys, mkTyConApp, mkTyVarTys,
mkFunTys, mkFunTy, mkSigmaTy, classesToPreds,
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, tyVarsOfTypes,
- splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp,
+ splitSigmaTy, splitFunTy_maybe,
splitFunTys, splitForAllTys, unUsgTy,
mkUsgTy, UsageAnn(..)
)
import PprType ( pprParendType )
import Module ( Module )
-import CoreUtils ( mkInlineMe )
+import CoreUtils ( exprType, mkInlineMe )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
+import Literal ( Literal(..) )
import Subst ( mkTopTyVarSubst, substClasses )
-import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons, isDataTyCon, isProductTyCon, isUnboxedTupleTyCon )
+import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons, isDataTyCon,
+ tyConTheta, isProductTyCon, isUnboxedTupleTyCon )
import Class ( Class, classBigSig, classTyCon, classTyVars, classSelIds )
import Var ( Id, TyVar )
import VarSet ( isEmptyVarSet )
primOpSig, mkPrimOpIdName,
CCall, pprCCallOp
)
-import Demand ( wwStrict, wwPrim )
+import Demand ( wwStrict, wwPrim, mkStrictnessInfo )
import DataCon ( DataCon, StrictnessMark(..),
dataConFieldLabels, dataConRepArity, dataConTyCon,
- dataConArgTys, dataConRepType, dataConRepStrictness, dataConName,
+ dataConArgTys, dataConRepType, dataConRepStrictness,
+ dataConName, dataConTheta,
dataConSig, dataConStrictMarks, dataConId
)
import Id ( idType, mkId,
arity = dataConRepArity data_con
- strict_info = StrictnessInfo (dataConRepStrictness data_con) False
+ strict_info = mkStrictnessInfo (dataConRepStrictness data_con, False)
cpr_info | isProductTyCon tycon &&
not (isUnboxedTupleTyCon tycon) &&
(tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con
all_tyvars = tyvars ++ ex_tyvars
- dict_tys = [mkDictTy clas tys | (clas,tys) <- theta]
- ex_dict_tys = [mkDictTy clas tys | (clas,tys) <- ex_theta]
+ dict_tys = mkDictTys theta
+ ex_dict_tys = mkDictTys ex_theta
all_arg_tys = dict_tys ++ ex_dict_tys ++ orig_arg_tys
result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
T2 ... x ... -> x
other -> error "..."
+Similarly for newtypes
+
+ newtype N a = MkN { unN :: a->a }
+
+ unN :: N a -> a -> a
+ unN n = coerce (a->a) n
+
+We need to take a little care if the field has a polymorphic type:
+
+ data R = R { f :: forall a. a->a }
+
+Then we want
+
+ f :: forall a. R -> a -> a
+ f = /\ a \ r = case r of
+ R f -> f a
+
+(not f :: R -> forall a. a->a, which gives the type inference mechanism
+problems at call sites)
+
+Similarly for newtypes
+
+ newtype N = MkN { unN :: forall a. a->a }
+
+ unN :: forall a. N -> a -> a
+ unN = /\a -> \n:N -> coerce (a->a) n
+
\begin{code}
-mkRecordSelId tycon field_label
- -- Assumes that all fields with the same field label
- -- have the same type
+mkRecordSelId tycon field_label unpack_id
+ -- Assumes that all fields with the same field label have the same type
+ --
+ -- Annoyingly, we have to pass in the unpackCString# Id, because
+ -- we can't conjure it up out of thin air
= sel_id
where
sel_id = mkId (fieldLabelName field_label) selector_ty info
data_cons = tyConDataCons tycon
tyvars = tyConTyVars tycon -- These scope over the types in
-- the FieldLabels of constructors of this type
+ tycon_theta = tyConTheta tycon -- The context on the data decl
+ -- eg data (Eq a, Ord b) => T a b = ...
+ (field_tyvars,field_tau) = splitForAllTys field_ty
- data_ty = mkTyConApp tycon (mkTyVarTys tyvars)
+ data_ty = mkTyConApp tycon tyvar_tys
tyvar_tys = mkTyVarTys tyvars
+ -- Very tiresomely, the selectors are (unnecessarily!) overloaded over
+ -- just the dictionaries in the types of the constructors that contain
+ -- the relevant field. Urgh.
+ -- NB: this code relies on the fact that DataCons are quantified over
+ -- the identical type variables as their parent TyCon
+ dict_tys = [mkDictTy cls tys | (cls, tys) <- tycon_theta, needed_dict (cls, tys)]
+ needed_dict pred = or [ pred `elem` (dataConTheta dc)
+ | (DataAlt dc, _, _) <- the_alts]
+
selector_ty :: Type
- selector_ty = mkForAllTys tyvars (mkFunTy data_ty field_ty)
+ selector_ty = mkForAllTys tyvars $ mkForAllTys field_tyvars $
+ mkFunTys dict_tys $ mkFunTy data_ty field_tau
info = mkIdInfo (RecordSelId field_label)
`setArityInfo` exactArity 1
unfolding = mkTopUnfolding sel_rhs
- [data_id] = mkTemplateLocals [data_ty]
+ (data_id:dict_ids) = mkTemplateLocals (data_ty:dict_tys)
alts = map mk_maybe_alt data_cons
the_alts = catMaybes alts
default_alt | all isJust alts = [] -- No default needed
sel_rhs | isNewTyCon tycon = new_sel_rhs
| otherwise = data_sel_rhs
- data_sel_rhs = mkLams tyvars $ Lam data_id $
- Case (Var data_id) data_id (the_alts ++ default_alt)
+ data_sel_rhs = mkLams tyvars $ mkLams field_tyvars $
+ mkLams dict_ids $ Lam data_id $
+ Case (Var data_id) data_id (the_alts ++ default_alt)
- new_sel_rhs = mkLams tyvars $ Lam data_id $
- Note (Coerce (unUsgTy field_ty) (unUsgTy data_ty)) (Var data_id)
+ new_sel_rhs = mkLams tyvars $ mkLams field_tyvars $ Lam data_id $
+ Note (Coerce (unUsgTy field_tau) (unUsgTy data_ty)) (Var data_id)
mk_maybe_alt data_con
= case maybe_the_arg_id of
Nothing -> Nothing
- Just the_arg_id -> Just (DataAlt data_con, arg_ids, Var the_arg_id)
+ Just the_arg_id -> Just (DataAlt data_con, arg_ids,
+ mkVarApps (Var the_arg_id) field_tyvars)
where
arg_ids = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
-- The first one will shadow data_id, but who cares
field_lbls = dataConFieldLabels data_con
maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
- error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy field_ty), mkStringLit full_msg]
+ error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy field_tau), err_string]
-- preserves invariant that type args are *not* usage-annotated on top. KSW 1999-04.
+ err_string = App (Var unpack_id) (Lit (MachStr (_PK_ full_msg)))
full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
\end{code}
ToDo: unify with mkRecordSelId.
\begin{code}
-mkDictSelId name clas ty
+mkDictSelId :: Name -> Class -> Id
+mkDictSelId name clas
= sel_id
where
+ ty = exprType rhs
sel_id = mkId name ty info
- field_lbl = mkFieldLabel name ty tag
+ field_lbl = mkFieldLabel name tycon ty tag
tag = assoc "MkId.mkDictSelId" (classSelIds clas `zip` allFieldLabelTags) sel_id
info = mkIdInfo (RecordSelId field_lbl)
\begin{code}
eRROR_ID
= pc_bottoming_Id errorIdKey pREL_ERR SLIT("error") errorTy
-rEC_SEL_ERROR_ID
- = generic_ERROR_ID recSelErrIdKey SLIT("patError")
pAT_ERROR_ID
= generic_ERROR_ID patErrorIdKey SLIT("patError")
+rEC_SEL_ERROR_ID
+ = generic_ERROR_ID recSelErrIdKey SLIT("recSelError")
rEC_CON_ERROR_ID
= generic_ERROR_ID recConErrorIdKey SLIT("recConError")
rEC_UPD_ERROR_ID
projects / ghc-hetmet.git / blobdiff