2 % (c) The AQUA Project, Glasgow University, 1998
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
16 mkSpecPragmaId, mkWorkerId,
18 mkDictFunId, mkDefaultMethodId,
19 mkMethodSelId, mkSuperDictSelId,
27 #include "HsVersions.h"
29 import {-# SOURCE #-} CoreUnfold ( mkUnfolding )
31 import TysWiredIn ( boolTy )
32 import Type ( Type, ThetaType,
33 mkDictTy, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy,
34 isUnLiftedType, substTopTheta,
35 splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp,
36 splitFunTys, splitForAllTys
38 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon )
39 import Class ( Class, classBigSig, classTyCon )
40 import Var ( Id, TyVar, VarDetails(..), mkId )
41 import VarEnv ( zipVarEnv )
42 import Const ( Con(..) )
43 import Name ( mkDerivedName, mkWiredInIdName,
44 mkWorkerOcc, mkSuperDictSelOcc,
47 import PrimOp ( PrimOp, primOpType, primOpOcc, primOpUniq )
48 import DataCon ( DataCon, dataConStrictMarks, dataConFieldLabels,
49 dataConArgTys, dataConSig
52 mkUserLocal, mkVanillaId, mkTemplateLocals,
55 import IdInfo ( noIdInfo,
56 exactArity, setUnfoldingInfo,
57 setArityInfo, setInlinePragInfo,
58 InlinePragInfo(..), IdInfo
60 import FieldLabel ( FieldLabel, FieldLabelTag, mkFieldLabel, fieldLabelName,
61 firstFieldLabelTag, allFieldLabelTags
64 import PrelVals ( rEC_SEL_ERROR_ID )
65 import PrelMods ( pREL_GHC )
67 import BasicTypes ( Arity, StrictnessMark(..) )
68 import Unique ( Unique )
69 import Maybe ( isJust )
76 %************************************************************************
78 \subsection{Easy ones}
80 %************************************************************************
83 mkSpecPragmaId occ uniq ty loc
84 = mkUserLocal occ uniq ty loc `setInlinePragma` IAmASpecPragmaId
85 -- Maybe a SysLocal? But then we'd lose the location
87 mkDefaultMethodId dm_name rec_c ty
88 = mkVanillaId dm_name ty
90 mkWorkerId uniq unwrkr ty
91 = mkVanillaId (mkDerivedName mkWorkerOcc (getName unwrkr) uniq) ty
94 %************************************************************************
96 \subsection{Data constructors}
98 %************************************************************************
101 mkDataConId :: DataCon -> Id
103 = mkId (getName data_con)
105 (ConstantId (DataCon data_con))
106 (dataConInfo data_con)
108 (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon) = dataConSig data_con
109 id_ty = mkSigmaTy (tyvars ++ ex_tyvars)
111 (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)))
114 We're going to build a constructor that looks like:
116 data (Data a, C b) => T a b = T1 !a !Int b
119 \d1::Data a, d2::C b ->
120 \p q r -> case p of { p ->
122 Con T1 [a,b] [p,q,r]}}
126 * d2 is thrown away --- a context in a data decl is used to make sure
127 one *could* construct dictionaries at the site the constructor
128 is used, but the dictionary isn't actually used.
130 * We have to check that we can construct Data dictionaries for
131 the types a and Int. Once we've done that we can throw d1 away too.
133 * We use (case p of ...) to evaluate p, rather than "seq" because
134 all that matters is that the arguments are evaluated. "seq" is
135 very careful to preserve evaluation order, which we don't need
139 dataConInfo :: DataCon -> IdInfo
142 = setInlinePragInfo IMustBeINLINEd $
143 -- Always inline constructors; we won't create a binding for them
144 setArityInfo (exactArity (length locals)) $
145 setUnfoldingInfo unfolding $
148 unfolding = mkUnfolding con_rhs
150 (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon) = dataConSig data_con
151 all_tyvars = tyvars ++ ex_tyvars
153 dict_tys = [mkDictTy clas tys | (clas,tys) <- theta]
154 ex_dict_tys = [mkDictTy clas tys | (clas,tys) <- ex_theta]
155 n_dicts = length dict_tys
156 result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
158 locals = mkTemplateLocals (dict_tys ++ ex_dict_tys ++ arg_tys)
159 data_args = drop n_dicts locals
160 (data_arg1:_) = data_args -- Used for newtype only
161 strict_marks = dataConStrictMarks data_con
162 strict_args = [arg | (arg,MarkedStrict) <- data_args `zip` strict_marks]
163 -- NB: we can't call mkTemplateLocals twice, because it
164 -- always starts from the same unique.
166 con_app | isNewTyCon tycon
167 = ASSERT( length arg_tys == 1)
168 Note (Coerce result_ty (head arg_tys)) (Var data_arg1)
170 = mkConApp data_con (map Type (mkTyVarTys all_tyvars) ++ map Var data_args)
172 con_rhs = mkLams all_tyvars $ mkLams locals $
173 foldr mk_case con_app strict_args
175 mk_case arg body | isUnLiftedType (idType arg)
176 = body -- "!" on unboxed arg does nothing
178 = Case (Var arg) arg [(DEFAULT,[],body)]
179 -- This case shadows "arg" but that's fine
183 %************************************************************************
185 \subsection{Record selectors}
187 %************************************************************************
189 We're going to build a record selector unfolding that looks like this:
191 data T a b c = T1 { ..., op :: a, ...}
192 | T2 { ..., op :: a, ...}
195 sel = /\ a b c -> \ d -> case d of
201 mkRecordSelId field_label selector_ty
202 = ASSERT( null theta && isDataTyCon tycon )
205 sel_id = mkId (fieldLabelName field_label) selector_ty
206 (RecordSelId field_label) info
208 info = exactArity 1 `setArityInfo` (
209 unfolding `setUnfoldingInfo`
211 -- ToDo: consider adding further IdInfo
213 unfolding = mkUnfolding sel_rhs
215 (tyvars, theta, tau) = splitSigmaTy selector_ty
216 (data_ty,rhs_ty) = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
217 -- tau is of form (T a b c -> field-type)
218 (tycon, _, data_cons) = splitAlgTyConApp data_ty
219 tyvar_tys = mkTyVarTys tyvars
221 [data_id] = mkTemplateLocals [data_ty]
222 alts = map mk_maybe_alt data_cons
223 the_alts = catMaybes alts
224 default_alt | all isJust alts = [] -- No default needed
225 | otherwise = [(DEFAULT, [], error_expr)]
227 sel_rhs = mkLams tyvars $ Lam data_id $
228 Case (Var data_id) data_id (the_alts ++ default_alt)
230 mk_maybe_alt data_con
231 = case maybe_the_arg_id of
233 Just the_arg_id -> Just (DataCon data_con, arg_ids, Var the_arg_id)
235 arg_ids = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
236 -- The first one will shadow data_id, but who cares
237 field_lbls = dataConFieldLabels data_con
238 maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
240 error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type rhs_ty, mkStringLit full_msg]
241 full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
245 %************************************************************************
247 \subsection{Newtype field selectors}
249 %************************************************************************
251 Possibly overkill to do it this way:
254 mkNewTySelId field_label selector_ty = sel_id
256 sel_id = mkId (fieldLabelName field_label) selector_ty
257 (RecordSelId field_label) info
259 info = exactArity 1 `setArityInfo` (
260 unfolding `setUnfoldingInfo`
262 -- ToDo: consider adding further IdInfo
264 unfolding = mkUnfolding sel_rhs
266 (tyvars, theta, tau) = splitSigmaTy selector_ty
267 (data_ty,rhs_ty) = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
268 -- tau is of form (T a b c -> field-type)
269 (tycon, _, data_cons) = splitAlgTyConApp data_ty
270 tyvar_tys = mkTyVarTys tyvars
272 [data_id] = mkTemplateLocals [data_ty]
273 sel_rhs = mkLams tyvars $ Lam data_id $
274 Note (Coerce rhs_ty data_ty) (Var data_id)
279 %************************************************************************
281 \subsection{Dictionary selectors}
283 %************************************************************************
286 mkSuperDictSelId :: Unique -> Class -> FieldLabelTag -> Type -> Id
287 -- The FieldLabelTag says which superclass is selected
289 -- class (C a, C b) => Foo a b where ...
290 -- we get superclass selectors
293 mkSuperDictSelId uniq clas index ty
294 = mkDictSelId name clas ty
296 name = mkDerivedName (mkSuperDictSelOcc index) (getName clas) uniq
298 -- For method selectors the clean thing to do is
299 -- to give the method selector the same name as the class op itself.
300 mkMethodSelId name clas ty
301 = mkDictSelId name clas ty
304 Selecting a field for a dictionary. If there is just one field, then
305 there's nothing to do.
308 mkDictSelId name clas ty
311 sel_id = mkId name ty (RecordSelId field_lbl) info
312 field_lbl = mkFieldLabel name ty tag
313 tag = assoc "MkId.mkDictSelId" ((sc_sel_ids ++ op_sel_ids) `zip` allFieldLabelTags) sel_id
315 info = setInlinePragInfo IMustBeINLINEd $
316 setUnfoldingInfo unfolding noIdInfo
317 -- The always-inline thing means we don't need any other IdInfo
318 -- We need "Must" inline because we don't create any bindigs for
321 unfolding = mkUnfolding rhs
323 (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
325 tycon = classTyCon clas
326 [data_con] = tyConDataCons tycon
327 tyvar_tys = mkTyVarTys tyvars
328 arg_tys = dataConArgTys data_con tyvar_tys
329 the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
331 dict_ty = mkDictTy clas tyvar_tys
332 (dict_id:arg_ids) = mkTemplateLocals (dict_ty : arg_tys)
334 rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
335 Note (Coerce (head arg_tys) dict_ty) (Var dict_id)
336 | otherwise = mkLams tyvars $ Lam dict_id $
337 Case (Var dict_id) dict_id
338 [(DataCon data_con, arg_ids, Var the_arg_id)]
342 %************************************************************************
344 \subsection{Primitive operations
346 %************************************************************************
350 mkPrimitiveId :: PrimOp -> Id
351 mkPrimitiveId prim_op
354 occ_name = primOpOcc prim_op
355 key = primOpUniq prim_op
356 ty = primOpType prim_op
357 name = mkWiredInIdName key pREL_GHC occ_name id
358 id = mkId name ty (ConstantId (PrimOp prim_op)) info
360 info = setUnfoldingInfo unfolding $
361 setInlinePragInfo IMustBeINLINEd $
362 -- The pragma @IMustBeINLINEd@ says that this Id absolutely
363 -- must be inlined. It's only used for primitives,
364 -- because we don't want to make a closure for each of them.
367 unfolding = mkUnfolding rhs
369 (tyvars, tau) = splitForAllTys ty
370 (arg_tys, _) = splitFunTys tau
372 args = mkTemplateLocals arg_tys
373 rhs = mkLams tyvars $ mkLams args $
374 mkPrimApp prim_op (map Type (mkTyVarTys tyvars) ++ map Var args)
380 dyadic_fun_ty ty = mkFunTys [ty, ty] ty
381 monadic_fun_ty ty = ty `mkFunTy` ty
382 compare_fun_ty ty = mkFunTys [ty, ty] boolTy
386 %************************************************************************
388 \subsection{DictFuns}
390 %************************************************************************
393 mkDictFunId :: Name -- Name to use for the dict fun;
400 mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
401 = mkVanillaId dfun_name dfun_ty
403 (class_tyvars, sc_theta, _, _, _) = classBigSig clas
404 sc_theta' = substTopTheta (zipVarEnv class_tyvars inst_tys) sc_theta
406 dfun_theta = case inst_decl_theta of
407 [] -> [] -- If inst_decl_theta is empty, then we don't
408 -- want to have any dict arguments, so that we can
409 -- expose the constant methods.
411 other -> nub (inst_decl_theta ++ sc_theta')
412 -- Otherwise we pass the superclass dictionaries to
413 -- the dictionary function; the Mark Jones optimisation.
415 -- NOTE the "nub". I got caught by this one:
416 -- class Monad m => MonadT t m where ...
417 -- instance Monad m => MonadT (EnvT env) m where ...
418 -- Here, the inst_decl_theta has (Monad m); but so
419 -- does the sc_theta'!
421 dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)