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 ( mkTemplateLocals, idType,
28 dataConStrictMarks, dataConFieldLabels, dataConArgTys,
29 recordSelectorFieldLabel, dataConSig,
31 isAlgCon, isDictSelId_maybe,
32 isRecordSelector, isPrimitiveId_maybe,
33 addIdUnfolding, addIdArity,
36 import IdInfo ( ArityInfo, exactArity )
37 import Class ( classBigSig, classTyCon )
38 import TyCon ( isNewTyCon, tyConDataCons, isDataTyCon )
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 %************************************************************************
182 Selecting a field for a dictionary. If there is just one field, then
183 there's nothing to do.
186 addStandardIdInfo sel_id
187 | maybeToBool maybe_dict_sel_id
188 = sel_id `addIdUnfolding` unfolding
190 maybe_dict_sel_id = isDictSelId_maybe sel_id
191 Just clas = maybe_dict_sel_id
193 unfolding = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs
194 -- The always-inline thing means we don't need any other IdInfo
196 (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
198 tycon = classTyCon clas
199 [data_con] = tyConDataCons tycon
200 tyvar_tys = mkTyVarTys tyvars
201 arg_tys = dataConArgTys data_con tyvar_tys
202 the_arg_id = assoc "StdIdInfo:mk_sel" ((sc_sel_ids ++ op_sel_ids) `zip` arg_ids) sel_id
204 (dict_id:arg_ids) = mkTemplateLocals (mkDictTy clas tyvar_tys : arg_tys)
206 rhs | isNewTyCon tycon = mkLam tyvars [dict_id] $
207 Coerce (CoerceOut data_con) (head arg_tys) (Var dict_id)
208 | otherwise = mkLam tyvars [dict_id] $
210 AlgAlts [(data_con, arg_ids, Var the_arg_id)] NoDefault
214 %************************************************************************
216 \subsection{Primitive operations
218 %************************************************************************
222 addStandardIdInfo prim_id
223 | maybeToBool maybe_prim_id
224 = prim_id `addIdUnfolding` unfolding
226 maybe_prim_id = isPrimitiveId_maybe prim_id
227 Just prim_op = maybe_prim_id
229 unfolding = mkUnfolding IWantToBeINLINEd {- Always inline PrimOps -} rhs
231 (tyvars, tau) = splitForAllTys (idType prim_id)
232 (arg_tys, _) = splitFunTys tau
234 args = mkTemplateLocals arg_tys
235 rhs = mkLam tyvars args $
237 ([TyArg (mkTyVarTy tv) | tv <- tyvars] ++
238 [VarArg v | v <- args])
242 %************************************************************************
244 \subsection{Catch-all}
246 %************************************************************************
250 = pprTrace "addStandardIdInfo missing:" (ppr id) id