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 TyVar ( alphaTyVar )
25 import CmdLineOpts ( opt_PprUserLength )
28 import CoreUnfold ( mkUnfolding, PragmaInfo(..) )
29 import TysWiredIn ( tupleCon )
30 import Id ( GenId, mkTemplateLocals, idType,
31 dataConStrictMarks, dataConFieldLabels, dataConArgTys,
32 recordSelectorFieldLabel, dataConSig,
34 isAlgCon, isMethodSelId_maybe, isSuperDictSelId_maybe,
35 isRecordSelector, isPrimitiveId_maybe,
36 addIdUnfolding, addIdArity,
39 import IdInfo ( ArityInfo, exactArity )
40 import Class ( GenClass, classBigSig, classDictArgTys )
41 import TyCon ( isNewTyCon, isDataTyCon, isAlgTyCon )
42 import FieldLabel ( FieldLabel )
43 import PrelVals ( pAT_ERROR_ID )
45 import Outputable ( PprStyle(..), Outputable(..) )
47 import Util ( assertPanic, pprTrace,
53 %************************************************************************
55 \subsection{Data constructors}
57 %************************************************************************
59 We're going to build a constructor that looks like:
61 data (Data a, C b) => T a b = T1 !a !Int b
64 \d1::Data a, d2::C b ->
65 \p q r -> case p of { p ->
67 Con T1 [a,b] [p,q,r]}}
71 * d2 is thrown away --- a context in a data decl is used to make sure
72 one *could* construct dictionaries at the site the constructor
73 is used, but the dictionary isn't actually used.
75 * We have to check that we can construct Data dictionaries for
76 the types a and Int. Once we've done that we can throw d1 away too.
78 * We use (case p of ...) to evaluate p, rather than "seq" because
79 all that matters is that the arguments are evaluated. "seq" is
80 very careful to preserve evaluation order, which we don't need
84 addStandardIdInfo :: Id -> Id
86 addStandardIdInfo con_id
89 = con_id `addIdUnfolding` unfolding
90 `addIdArity` exactArity (length locals)
92 unfolding = mkUnfolding IWantToBeINLINEd {- Always inline constructors -} con_rhs
94 (tyvars, theta, con_tyvars, con_theta, arg_tys, tycon) = dataConSig con_id
96 dict_tys = [mkDictTy clas ty | (clas,ty) <- theta]
97 con_dict_tys = [mkDictTy clas ty | (clas,ty) <- con_theta]
98 n_dicts = length dict_tys
99 result_ty = applyTyCon tycon (mkTyVarTys tyvars)
101 locals = mkTemplateLocals (dict_tys ++ con_dict_tys ++ arg_tys)
102 data_args = drop n_dicts locals
103 (data_arg1:_) = data_args -- Used for newtype only
104 strict_marks = dataConStrictMarks con_id
105 strict_args = [arg | (arg,MarkedStrict) <- data_args `zip` strict_marks]
106 -- NB: we can't call mkTemplateLocals twice, because it
107 -- always starts from the same unique.
109 con_app | isNewTyCon tycon
110 = ASSERT( length arg_tys == 1)
111 Coerce (CoerceIn con_id) result_ty (Var data_arg1)
113 = Con con_id (map TyArg (mkTyVarTys tyvars) ++ map VarArg data_args)
115 con_rhs = mkTyLam tyvars $
117 foldr mk_case con_app strict_args
119 mk_case arg body | isUnboxedType (idType arg)
120 = body -- "!" on unboxed arg does nothing
122 = Case (Var arg) (AlgAlts [] (BindDefault arg body))
123 -- This case shadows "arg" but that's fine
127 %************************************************************************
129 \subsection{Record selectors}
131 %************************************************************************
133 We're going to build a record selector that looks like this:
135 data T a b c = T1 { ..., op :: a, ...}
136 | T2 { ..., op :: a, ...}
139 sel = /\ a b c -> \ d -> case d of
145 addStandardIdInfo sel_id
146 | isRecordSelector sel_id
147 = ASSERT( null theta && isDataTyCon tycon )
148 sel_id `addIdUnfolding` unfolding
149 `addIdArity` exactArity 1
150 -- ToDo: consider adding further IdInfo
152 unfolding = mkUnfolding NoPragmaInfo {- Don't inline every selector -} sel_rhs
154 (tyvars, theta, tau) = splitSigmaTy (idType sel_id)
155 field_lbl = recordSelectorFieldLabel sel_id
156 (data_ty,rhs_ty) = expectJust "StdIdInfoRec" (getFunTy_maybe tau)
157 -- tau is of form (T a b c -> field-type)
158 (tycon, _, data_cons) = getAppDataTyCon data_ty
159 tyvar_tys = mkTyVarTys tyvars
161 [data_id] = mkTemplateLocals [data_ty]
162 sel_rhs = mkTyLam tyvars $
164 Case (Var data_id) (AlgAlts (catMaybes (map mk_maybe_alt data_cons))
165 (BindDefault data_id error_expr))
166 mk_maybe_alt data_con
167 = case maybe_the_arg_id of
169 Just the_arg_id -> Just (data_con, arg_ids, Var the_arg_id)
171 arg_ids = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
172 -- The first one will shadow data_id, but who cares
173 field_lbls = dataConFieldLabels data_con
174 maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_lbl
176 error_expr = mkApp (Var pAT_ERROR_ID) [] [rhs_ty] [LitArg msg_lit]
177 full_msg = show (sep [text "No match in record selector", ppr (PprForUser opt_PprUserLength) sel_id])
178 msg_lit = NoRepStr (_PK_ full_msg)
182 %************************************************************************
184 \subsection{Super selectors}
186 %************************************************************************
189 addStandardIdInfo sel_id
190 | maybeToBool maybe_sc_sel_id
191 = sel_id `addIdUnfolding` (mk_selector_unfolding cls sel_id)
193 maybe_sc_sel_id = isSuperDictSelId_maybe sel_id
194 Just (cls, _) = maybe_sc_sel_id
196 addStandardIdInfo sel_id
197 | maybeToBool maybe_meth_sel_id
198 = sel_id `addIdUnfolding` (mk_selector_unfolding cls sel_id)
200 maybe_meth_sel_id = isMethodSelId_maybe sel_id
201 Just cls = maybe_meth_sel_id
205 %************************************************************************
207 \subsection{Primitive operations
209 %************************************************************************
213 addStandardIdInfo prim_id
214 | maybeToBool maybe_prim_id
215 = prim_id `addIdUnfolding` unfolding
217 maybe_prim_id = isPrimitiveId_maybe prim_id
218 Just prim_op = maybe_prim_id
220 unfolding = mkUnfolding IWantToBeINLINEd {- Always inline PrimOps -} rhs
222 (tyvars, tau) = splitForAllTy (idType prim_id)
223 (arg_tys, _) = splitFunTy tau
225 args = mkTemplateLocals arg_tys
226 rhs = mkLam tyvars args $
228 ([TyArg (mkTyVarTy tv) | tv <- tyvars] ++
229 [VarArg v | v <- args])
233 %************************************************************************
235 \subsection{Catch-all}
237 %************************************************************************
241 = pprTrace "addStandardIdInfo missing:" (ppr PprDebug id) id
245 %************************************************************************
247 \subsection{Dictionary selector help function
249 %************************************************************************
251 Selecting a field for a dictionary. If there is just one field, then
252 there's nothing to do.
255 mk_selector_unfolding clas sel_id
256 = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs
257 -- The always-inline thing means we don't need any other IdInfo
259 rhs = mk_dict_selector [alphaTyVar] dict_id arg_ids the_arg_id
260 tyvar_ty = mkTyVarTy alphaTyVar
261 [dict_id] = mkTemplateLocals [mkDictTy clas tyvar_ty]
262 arg_tys = classDictArgTys clas tyvar_ty
263 arg_ids = mkTemplateLocals arg_tys
264 the_arg_id = assoc "StdIdInfo:mk_sel" ((sc_sel_ids ++ op_sel_ids) `zip` arg_ids) sel_id
266 (_, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
268 mk_dict_selector tyvars dict_id [arg_id] the_arg_id
269 = mkLam tyvars [dict_id] (Var dict_id)
271 mk_dict_selector tyvars dict_id arg_ids the_arg_id
272 = mkLam tyvars [dict_id] $
273 Case (Var dict_id) (AlgAlts [(tup_con, arg_ids, Var the_arg_id)] NoDefault)
275 tup_con = tupleCon (length arg_ids)