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, dataConRawArgTys
52 mkUserLocal, mkVanillaId, mkTemplateLocals,
53 mkTemplateLocal, setInlinePragma
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 $ -- Always inline constructors
143 setArityInfo (exactArity (n_dicts + n_ex_dicts + n_id_args)) $
144 setUnfoldingInfo unfolding $
147 unfolding = mkUnfolding con_rhs
149 (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon)
150 = dataConSig data_con
151 rep_arg_tys = dataConRawArgTys data_con
152 all_tyvars = tyvars ++ ex_tyvars
154 dict_tys = [mkDictTy clas tys | (clas,tys) <- theta]
155 ex_dict_tys = [mkDictTy clas tys | (clas,tys) <- ex_theta]
157 n_dicts = length dict_tys
158 n_ex_dicts = length ex_dict_tys
159 n_id_args = length orig_arg_tys
160 n_rep_args = length rep_arg_tys
162 result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
164 mkLocals i n tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
165 (dict_args, i1) = mkLocals 1 n_dicts dict_tys
166 (ex_dict_args,i2) = mkLocals i1 n_ex_dicts ex_dict_tys
167 (id_args,i3) = mkLocals i2 n_id_args orig_arg_tys
169 (id_arg1:_) = id_args -- Used for newtype only
170 strict_marks = dataConStrictMarks data_con
174 = ASSERT( length orig_arg_tys == 1 )
175 Note (Coerce result_ty (head orig_arg_tys)) (Var id_arg1)
178 (map Type (mkTyVarTys all_tyvars) ++
179 map Var (reverse rep_ids))
181 con_rhs = mkLams all_tyvars $ mkLams dict_args $
182 mkLams ex_dict_args $ mkLams id_args $
183 foldr mk_case con_app (zip id_args strict_marks) i3 []
186 :: (Id, StrictnessMark) -- arg, strictness
187 -> (Int -> [Id] -> CoreExpr) -- body
188 -> Int -- next rep arg id
189 -> [Id] -- rep args so far
191 mk_case (arg,strict) body i rep_args
193 NotMarkedStrict -> body i (arg:rep_args)
195 | isUnLiftedType (idType arg) -> body i (arg:rep_args)
197 Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))]
199 MarkedUnboxed con tys ->
200 Case (Var arg) arg [(DataCon con, con_args,
201 body i' (reverse con_args++rep_args))]
202 where n_tys = length tys
203 (con_args,i') = mkLocals i (length tys) tys
207 %************************************************************************
209 \subsection{Record selectors}
211 %************************************************************************
213 We're going to build a record selector unfolding that looks like this:
215 data T a b c = T1 { ..., op :: a, ...}
216 | T2 { ..., op :: a, ...}
219 sel = /\ a b c -> \ d -> case d of
225 mkRecordSelId field_label selector_ty
226 = ASSERT( null theta && isDataTyCon tycon )
229 sel_id = mkId (fieldLabelName field_label) selector_ty
230 (RecordSelId field_label) info
232 info = exactArity 1 `setArityInfo` (
233 unfolding `setUnfoldingInfo`
235 -- ToDo: consider adding further IdInfo
237 unfolding = mkUnfolding sel_rhs
239 (tyvars, theta, tau) = splitSigmaTy selector_ty
240 (data_ty,rhs_ty) = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
241 -- tau is of form (T a b c -> field-type)
242 (tycon, _, data_cons) = splitAlgTyConApp data_ty
243 tyvar_tys = mkTyVarTys tyvars
245 [data_id] = mkTemplateLocals [data_ty]
246 alts = map mk_maybe_alt data_cons
247 the_alts = catMaybes alts
248 default_alt | all isJust alts = [] -- No default needed
249 | otherwise = [(DEFAULT, [], error_expr)]
251 sel_rhs = mkLams tyvars $ Lam data_id $
252 Case (Var data_id) data_id (the_alts ++ default_alt)
254 mk_maybe_alt data_con
255 = case maybe_the_arg_id of
257 Just the_arg_id -> Just (DataCon data_con, arg_ids, Var the_arg_id)
259 arg_ids = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
260 -- The first one will shadow data_id, but who cares
261 field_lbls = dataConFieldLabels data_con
262 maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
264 error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type rhs_ty, mkStringLit full_msg]
265 full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
269 %************************************************************************
271 \subsection{Newtype field selectors}
273 %************************************************************************
275 Possibly overkill to do it this way:
278 mkNewTySelId field_label selector_ty = sel_id
280 sel_id = mkId (fieldLabelName field_label) selector_ty
281 (RecordSelId field_label) info
283 info = exactArity 1 `setArityInfo` (
284 unfolding `setUnfoldingInfo`
286 -- ToDo: consider adding further IdInfo
288 unfolding = mkUnfolding sel_rhs
290 (tyvars, theta, tau) = splitSigmaTy selector_ty
291 (data_ty,rhs_ty) = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
292 -- tau is of form (T a b c -> field-type)
293 (tycon, _, data_cons) = splitAlgTyConApp data_ty
294 tyvar_tys = mkTyVarTys tyvars
296 [data_id] = mkTemplateLocals [data_ty]
297 sel_rhs = mkLams tyvars $ Lam data_id $
298 Note (Coerce rhs_ty data_ty) (Var data_id)
303 %************************************************************************
305 \subsection{Dictionary selectors}
307 %************************************************************************
310 mkSuperDictSelId :: Unique -> Class -> FieldLabelTag -> Type -> Id
311 -- The FieldLabelTag says which superclass is selected
313 -- class (C a, C b) => Foo a b where ...
314 -- we get superclass selectors
317 mkSuperDictSelId uniq clas index ty
318 = mkDictSelId name clas ty
320 name = mkDerivedName (mkSuperDictSelOcc index) (getName clas) uniq
322 -- For method selectors the clean thing to do is
323 -- to give the method selector the same name as the class op itself.
324 mkMethodSelId name clas ty
325 = mkDictSelId name clas ty
328 Selecting a field for a dictionary. If there is just one field, then
329 there's nothing to do.
332 mkDictSelId name clas ty
335 sel_id = mkId name ty (RecordSelId field_lbl) info
336 field_lbl = mkFieldLabel name ty tag
337 tag = assoc "MkId.mkDictSelId" ((sc_sel_ids ++ op_sel_ids) `zip` allFieldLabelTags) sel_id
339 info = setInlinePragInfo IMustBeINLINEd $
340 setUnfoldingInfo unfolding noIdInfo
341 -- The always-inline thing means we don't need any other IdInfo
342 -- We need "Must" inline because we don't create any bindigs for
345 unfolding = mkUnfolding rhs
347 (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
349 tycon = classTyCon clas
350 [data_con] = tyConDataCons tycon
351 tyvar_tys = mkTyVarTys tyvars
352 arg_tys = dataConArgTys data_con tyvar_tys
353 the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
355 dict_ty = mkDictTy clas tyvar_tys
356 (dict_id:arg_ids) = mkTemplateLocals (dict_ty : arg_tys)
358 rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
359 Note (Coerce (head arg_tys) dict_ty) (Var dict_id)
360 | otherwise = mkLams tyvars $ Lam dict_id $
361 Case (Var dict_id) dict_id
362 [(DataCon data_con, arg_ids, Var the_arg_id)]
366 %************************************************************************
368 \subsection{Primitive operations
370 %************************************************************************
374 mkPrimitiveId :: PrimOp -> Id
375 mkPrimitiveId prim_op
378 occ_name = primOpOcc prim_op
379 key = primOpUniq prim_op
380 ty = primOpType prim_op
381 name = mkWiredInIdName key pREL_GHC occ_name id
382 id = mkId name ty (ConstantId (PrimOp prim_op)) info
384 info = setUnfoldingInfo unfolding $
385 setInlinePragInfo IMustBeINLINEd $
386 -- The pragma @IMustBeINLINEd@ says that this Id absolutely
387 -- must be inlined. It's only used for primitives,
388 -- because we don't want to make a closure for each of them.
391 unfolding = mkUnfolding rhs
393 (tyvars, tau) = splitForAllTys ty
394 (arg_tys, _) = splitFunTys tau
396 args = mkTemplateLocals arg_tys
397 rhs = mkLams tyvars $ mkLams args $
398 mkPrimApp prim_op (map Type (mkTyVarTys tyvars) ++ map Var args)
404 dyadic_fun_ty ty = mkFunTys [ty, ty] ty
405 monadic_fun_ty ty = ty `mkFunTy` ty
406 compare_fun_ty ty = mkFunTys [ty, ty] boolTy
410 %************************************************************************
412 \subsection{DictFuns}
414 %************************************************************************
417 mkDictFunId :: Name -- Name to use for the dict fun;
424 mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
425 = mkVanillaId dfun_name dfun_ty
427 (class_tyvars, sc_theta, _, _, _) = classBigSig clas
428 sc_theta' = substTopTheta (zipVarEnv class_tyvars inst_tys) sc_theta
430 dfun_theta = case inst_decl_theta of
431 [] -> [] -- If inst_decl_theta is empty, then we don't
432 -- want to have any dict arguments, so that we can
433 -- expose the constant methods.
435 other -> nub (inst_decl_theta ++ sc_theta')
436 -- Otherwise we pass the superclass dictionaries to
437 -- the dictionary function; the Mark Jones optimisation.
439 -- NOTE the "nub". I got caught by this one:
440 -- class Monad m => MonadT t m where ...
441 -- instance Monad m => MonadT (EnvT env) m where ...
442 -- Here, the inst_decl_theta has (Monad m); but so
443 -- does the sc_theta'!
445 dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)