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
15 #include "HsVersions.h"
24 import CmdLineOpts ( opt_PprUserLength )
27 import CoreUnfold ( mkUnfolding, PragmaInfo(..) )
28 import TysWiredIn ( tupleCon )
29 import Id ( GenId, mkTemplateLocals, idType,
30 dataConStrictMarks, dataConFieldLabels, dataConArgTys,
31 recordSelectorFieldLabel, dataConSig,
33 isAlgCon, isMethodSelId_maybe, isSuperDictSelId_maybe,
34 isRecordSelector, isPrimitiveId_maybe,
35 addIdUnfolding, addIdArity,
38 import IdInfo ( ArityInfo, exactArity )
39 import Class ( GenClass, GenClassOp, classSig, classOpLocalType )
40 import TyCon ( isNewTyCon, isDataTyCon, isAlgTyCon )
41 import FieldLabel ( FieldLabel )
42 import PrelVals ( pAT_ERROR_ID )
44 import Outputable ( PprStyle(..), Outputable(..) )
46 import Util ( assertPanic, pprTrace,
52 %************************************************************************
54 \subsection{Data constructors}
56 %************************************************************************
58 We're going to build a constructor that looks like:
60 data (Data a, C b) => T a b = T1 !a !Int b
63 \d1::Data a, d2::C b ->
64 \p q r -> case p of { p ->
66 Con T1 [a,b] [p,q,r]}}
70 * d2 is thrown away --- a context in a data decl is used to make sure
71 one *could* construct dictionaries at the site the constructor
72 is used, but the dictionary isn't actually used.
74 * We have to check that we can construct Data dictionaries for
75 the types a and Int. Once we've done that we can throw d1 away too.
77 * We use (case p of ...) to evaluate p, rather than "seq" because
78 all that matters is that the arguments are evaluated. "seq" is
79 very careful to preserve evaluation order, which we don't need
83 addStandardIdInfo :: Id -> Id
85 addStandardIdInfo con_id
88 = con_id `addIdUnfolding` unfolding
89 `addIdArity` exactArity (length locals)
91 unfolding = mkUnfolding IWantToBeINLINEd {- Always inline constructors -} con_rhs
93 (tyvars, theta, con_tyvars, con_theta, arg_tys, tycon) = dataConSig con_id
95 dict_tys = [mkDictTy clas ty | (clas,ty) <- theta]
96 con_dict_tys = [mkDictTy clas ty | (clas,ty) <- con_theta]
97 n_dicts = length dict_tys
98 result_ty = applyTyCon tycon (mkTyVarTys tyvars)
100 locals = mkTemplateLocals (dict_tys ++ con_dict_tys ++ arg_tys)
101 data_args = drop n_dicts locals
102 (data_arg1:_) = data_args -- Used for newtype only
103 strict_marks = dataConStrictMarks con_id
104 strict_args = [arg | (arg,MarkedStrict) <- data_args `zip` strict_marks]
105 -- NB: we can't call mkTemplateLocals twice, because it
106 -- always starts from the same unique.
108 con_app | isNewTyCon tycon
109 = ASSERT( length arg_tys == 1)
110 Coerce (CoerceIn con_id) result_ty (Var data_arg1)
112 = Con con_id (map TyArg (mkTyVarTys tyvars) ++ map VarArg data_args)
114 con_rhs = mkTyLam tyvars $
116 foldr mk_case con_app strict_args
118 mk_case arg body | isUnboxedType (idType arg)
119 = body -- "!" on unboxed arg does nothing
121 = Case (Var arg) (AlgAlts [] (BindDefault arg body))
122 -- This case shadows "arg" but that's fine
126 %************************************************************************
128 \subsection{Record selectors}
130 %************************************************************************
132 We're going to build a record selector that looks like this:
134 data T a b c = T1 { ..., op :: a, ...}
135 | T2 { ..., op :: a, ...}
138 sel = /\ a b c -> \ d -> case d of
144 addStandardIdInfo sel_id
145 | isRecordSelector sel_id
146 = ASSERT( null theta && isDataTyCon tycon )
147 sel_id `addIdUnfolding` unfolding
148 `addIdArity` exactArity 1
149 -- ToDo: consider adding further IdInfo
151 unfolding = mkUnfolding NoPragmaInfo {- Don't inline every selector -} sel_rhs
153 (tyvars, theta, tau) = splitSigmaTy (idType sel_id)
154 field_lbl = recordSelectorFieldLabel sel_id
155 (data_ty,rhs_ty) = expectJust "StdIdInfoRec" (getFunTy_maybe tau)
156 -- tau is of form (T a b c -> field-type)
157 (tycon, _, data_cons) = getAppDataTyCon data_ty
158 tyvar_tys = mkTyVarTys tyvars
160 [data_id] = mkTemplateLocals [data_ty]
161 sel_rhs = mkTyLam tyvars $
163 Case (Var data_id) (AlgAlts (catMaybes (map mk_maybe_alt data_cons))
164 (BindDefault data_id error_expr))
165 mk_maybe_alt data_con
166 = case maybe_the_arg_id of
168 Just the_arg_id -> Just (data_con, arg_ids, Var the_arg_id)
170 arg_ids = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
171 -- The first one will shadow data_id, but who cares
172 field_lbls = dataConFieldLabels data_con
173 maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_lbl
175 error_expr = mkApp (Var pAT_ERROR_ID) [] [rhs_ty] [LitArg msg_lit]
176 full_msg = show (sep [text "No match in record selector", ppr (PprForUser opt_PprUserLength) sel_id])
177 msg_lit = NoRepStr (_PK_ full_msg)
181 %************************************************************************
183 \subsection{Super selectors}
185 %************************************************************************
188 addStandardIdInfo sel_id
189 | maybeToBool maybe_sc_sel_id
190 = sel_id `addIdUnfolding` unfolding
191 -- The always-inline thing means we don't need any other IdInfo
193 maybe_sc_sel_id = isSuperDictSelId_maybe sel_id
194 Just (cls, the_sc) = maybe_sc_sel_id
196 unfolding = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs
197 rhs = mk_dict_selector [tyvar] dict_id arg_ids the_arg_id
199 (tyvar, scs, ops) = classSig cls
200 tyvar_ty = mkTyVarTy tyvar
201 [dict_id] = mkTemplateLocals [mkDictTy cls tyvar_ty]
202 arg_ids = mkTemplateLocals ([mkDictTy sc tyvar_ty | sc <- scs] ++
203 map classOpLocalType ops)
204 the_arg_id = assoc "StdIdInfoSC" (scs `zip` arg_ids) the_sc
206 addStandardIdInfo sel_id
207 | maybeToBool maybe_meth_sel_id
208 = sel_id `addIdUnfolding` unfolding
209 -- The always-inline thing means we don't need any other IdInfo
211 maybe_meth_sel_id = isMethodSelId_maybe sel_id
212 Just (cls, the_op) = maybe_meth_sel_id
214 unfolding = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs
215 rhs = mk_dict_selector [tyvar] dict_id arg_ids the_arg_id
217 (tyvar, scs, ops) = classSig cls
219 tyvar_ty = mkTyVarTy tyvar
220 [dict_id] = mkTemplateLocals [mkDictTy cls tyvar_ty]
221 arg_ids = mkTemplateLocals ([mkDictTy sc tyvar_ty | sc <- scs] ++
222 map classOpLocalType ops)
224 the_arg_id = assoc "StdIdInfoMeth" (ops `zip` (drop n_scs arg_ids)) the_op
228 %************************************************************************
230 \subsection{Primitive operations
232 %************************************************************************
236 addStandardIdInfo prim_id
237 | maybeToBool maybe_prim_id
238 = prim_id `addIdUnfolding` unfolding
240 maybe_prim_id = isPrimitiveId_maybe prim_id
241 Just prim_op = maybe_prim_id
243 unfolding = mkUnfolding IWantToBeINLINEd {- Always inline PrimOps -} rhs
245 (tyvars, tau) = splitForAllTy (idType prim_id)
246 (arg_tys, _) = splitFunTy tau
248 args = mkTemplateLocals arg_tys
249 rhs = mkLam tyvars args $
251 ([TyArg (mkTyVarTy tv) | tv <- tyvars] ++
252 [VarArg v | v <- args])
256 %************************************************************************
258 \subsection{Catch-all}
260 %************************************************************************
264 = pprTrace "addStandardIdInfo missing:" (ppr PprDebug id) id
268 %************************************************************************
270 \subsection{Dictionary selector help function
272 %************************************************************************
274 Selecting a field for a dictionary. If there is just one field, then
275 there's nothing to do.
278 mk_dict_selector tyvars dict_id [arg_id] the_arg_id
279 = mkLam tyvars [dict_id] (Var dict_id)
281 mk_dict_selector tyvars dict_id arg_ids the_arg_id
282 = mkLam tyvars [dict_id] $
283 Case (Var dict_id) (AlgAlts [(tup_con, arg_ids, Var the_arg_id)] NoDefault)
285 tup_con = tupleCon (length arg_ids)