2 % (c) The AQUA Project, Glasgow University, 1994-1996
4 \section[StdIdInfo]{Standard unfoldings}
6 This module contains definitions for the IdInfo for things that
7 have a standard form, namely:
11 * method and superclass selectors
12 * primitive operations
19 #include "HsVersions.h"
22 import TyVar ( alphaTyVar )
25 import CoreUnfold ( mkUnfolding, PragmaInfo(..) )
26 import TysWiredIn ( tupleCon )
27 import Id ( GenId, mkTemplateLocals, idType,
28 dataConStrictMarks, dataConFieldLabels, dataConArgTys,
29 recordSelectorFieldLabel, dataConSig,
31 isAlgCon, isMethodSelId_maybe, isSuperDictSelId_maybe,
32 isRecordSelector, isPrimitiveId_maybe,
33 addIdUnfolding, addIdArity,
36 import IdInfo ( ArityInfo, exactArity )
37 import Class ( classBigSig, classTyCon )
38 import TyCon ( isNewTyCon, tyConDataCons )
39 import FieldLabel ( FieldLabel )
40 import PrelVals ( pAT_ERROR_ID )
47 %************************************************************************
49 \subsection{Data constructors}
51 %************************************************************************
53 We're going to build a constructor that looks like:
55 data (Data a, C b) => T a b = T1 !a !Int b
58 \d1::Data a, d2::C b ->
59 \p q r -> case p of { p ->
61 Con T1 [a,b] [p,q,r]}}
65 * d2 is thrown away --- a context in a data decl is used to make sure
66 one *could* construct dictionaries at the site the constructor
67 is used, but the dictionary isn't actually used.
69 * We have to check that we can construct Data dictionaries for
70 the types a and Int. Once we've done that we can throw d1 away too.
72 * We use (case p of ...) to evaluate p, rather than "seq" because
73 all that matters is that the arguments are evaluated. "seq" is
74 very careful to preserve evaluation order, which we don't need
78 addStandardIdInfo :: Id -> Id
80 addStandardIdInfo con_id
83 = con_id `addIdUnfolding` unfolding
84 `addIdArity` exactArity (length locals)
86 unfolding = mkUnfolding IWantToBeINLINEd {- Always inline constructors -} con_rhs
88 (tyvars, theta, con_tyvars, con_theta, arg_tys, tycon) = dataConSig con_id
90 dict_tys = [mkDictTy clas tys | (clas,tys) <- theta]
91 con_dict_tys = [mkDictTy clas tys | (clas,tys) <- con_theta]
92 n_dicts = length dict_tys
93 result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
95 locals = mkTemplateLocals (dict_tys ++ con_dict_tys ++ arg_tys)
96 data_args = drop n_dicts locals
97 (data_arg1:_) = data_args -- Used for newtype only
98 strict_marks = dataConStrictMarks con_id
99 strict_args = [arg | (arg,MarkedStrict) <- data_args `zip` strict_marks]
100 -- NB: we can't call mkTemplateLocals twice, because it
101 -- always starts from the same unique.
103 con_app | isNewTyCon tycon
104 = ASSERT( length arg_tys == 1)
105 Coerce (CoerceIn con_id) result_ty (Var data_arg1)
107 = Con con_id (map TyArg (mkTyVarTys tyvars) ++ map VarArg data_args)
109 con_rhs = mkTyLam tyvars $
111 foldr mk_case con_app strict_args
113 mk_case arg body | isUnpointedType (idType arg)
114 = body -- "!" on unboxed arg does nothing
116 = Case (Var arg) (AlgAlts [] (BindDefault arg body))
117 -- This case shadows "arg" but that's fine
121 %************************************************************************
123 \subsection{Record selectors}
125 %************************************************************************
127 We're going to build a record selector that looks like this:
129 data T a b c = T1 { ..., op :: a, ...}
130 | T2 { ..., op :: a, ...}
133 sel = /\ a b c -> \ d -> case d of
139 addStandardIdInfo sel_id
140 | isRecordSelector sel_id
141 = ASSERT( null theta && isDataTyCon tycon )
142 sel_id `addIdUnfolding` unfolding
143 `addIdArity` exactArity 1
144 -- ToDo: consider adding further IdInfo
146 unfolding = mkUnfolding NoPragmaInfo {- Don't inline every selector -} sel_rhs
148 (tyvars, theta, tau) = splitSigmaTy (idType sel_id)
149 field_lbl = recordSelectorFieldLabel sel_id
150 (data_ty,rhs_ty) = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
151 -- tau is of form (T a b c -> field-type)
152 (tycon, _, data_cons) = splitAlgTyConApp data_ty
153 tyvar_tys = mkTyVarTys tyvars
155 [data_id] = mkTemplateLocals [data_ty]
156 sel_rhs = mkTyLam tyvars $
158 Case (Var data_id) (AlgAlts (catMaybes (map mk_maybe_alt data_cons))
159 (BindDefault data_id error_expr))
160 mk_maybe_alt data_con
161 = case maybe_the_arg_id of
163 Just the_arg_id -> Just (data_con, arg_ids, Var the_arg_id)
165 arg_ids = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
166 -- The first one will shadow data_id, but who cares
167 field_lbls = dataConFieldLabels data_con
168 maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_lbl
170 error_expr = mkApp (Var pAT_ERROR_ID) [rhs_ty] [LitArg msg_lit]
171 full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
172 msg_lit = NoRepStr (_PK_ full_msg)
176 %************************************************************************
178 \subsection{Dictionary selectors}
180 %************************************************************************
183 addStandardIdInfo sel_id
184 | maybeToBool maybe_sc_sel_id
185 = sel_id `addIdUnfolding` (mk_selector_unfolding cls sel_id)
187 maybe_sc_sel_id = isSuperDictSelId_maybe sel_id
188 Just (cls, _) = maybe_sc_sel_id
190 addStandardIdInfo sel_id
191 | maybeToBool maybe_meth_sel_id
192 = sel_id `addIdUnfolding` (mk_selector_unfolding cls sel_id)
194 maybe_meth_sel_id = isMethodSelId_maybe sel_id
195 Just cls = maybe_meth_sel_id
199 %************************************************************************
201 \subsection{Primitive operations
203 %************************************************************************
207 addStandardIdInfo prim_id
208 | maybeToBool maybe_prim_id
209 = prim_id `addIdUnfolding` unfolding
211 maybe_prim_id = isPrimitiveId_maybe prim_id
212 Just prim_op = maybe_prim_id
214 unfolding = mkUnfolding IWantToBeINLINEd {- Always inline PrimOps -} rhs
216 (tyvars, tau) = splitForAllTys (idType prim_id)
217 (arg_tys, _) = splitFunTys tau
219 args = mkTemplateLocals arg_tys
220 rhs = mkLam tyvars args $
222 ([TyArg (mkTyVarTy tv) | tv <- tyvars] ++
223 [VarArg v | v <- args])
227 %************************************************************************
229 \subsection{Catch-all}
231 %************************************************************************
235 = pprTrace "addStandardIdInfo missing:" (ppr id) id
239 %************************************************************************
241 \subsection{Dictionary selector help function
243 %************************************************************************
245 Selecting a field for a dictionary. If there is just one field, then
246 there's nothing to do.
249 mk_selector_unfolding clas sel_id
250 = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs
251 -- The always-inline thing means we don't need any other IdInfo
253 (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
255 tycon = classTyCon clas
256 [data_con] = tyConDataCons tycon
257 tyvar_tys = mkTyVarTys tyvars
258 arg_tys = dataConArgTys data_con tyvar_tys
259 the_arg_id = assoc "StdIdInfo:mk_sel" ((sc_sel_ids ++ op_sel_ids) `zip` arg_ids) sel_id
261 (dict_id:arg_ids) = mkTemplateLocals (mkDictTy clas tyvar_tys : arg_tys)
263 rhs | isNewTyCon tycon = mkLam tyvars [dict_id] $
264 Coerce (CoerceOut data_con) (head arg_tys) (Var dict_id)
265 | otherwise = mkLam tyvars [dict_id] $
267 AlgAlts [(data_con, arg_ids, Var the_arg_id)] NoDefault