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
18 mkUserLocal, mkSysLocal,
21 mkDataCon, mkTupleCon,
24 mkMethodSelId, mkSuperDictSelId, mkDefaultMethodId,
33 #include "HsVersions.h"
35 import {-# SOURCE #-} CoreUnfold ( mkUnfolding )
40 import TysWiredIn ( tupleCon )
41 import Name ( mkLocalName, mkSysLocalName, mkCompoundName,
42 occNameString, Name, OccName, NamedThing(..)
44 import Id ( idType, fIRST_TAG,
45 mkTemplateLocals, mkId, mkVanillaId,
46 dataConStrictMarks, dataConFieldLabels, dataConArgTys,
47 recordSelectorFieldLabel, dataConSig,
49 Id, IdDetails(..), GenId
51 import IdInfo ( noIdInfo,
52 exactArity, setUnfoldingInfo,
53 setArityInfo, setInlinePragInfo,
54 InlinePragInfo(..), IdInfo
56 import Class ( Class, classBigSig, classTyCon )
57 import FieldLabel ( FieldLabel, FieldLabelTag, mkFieldLabel, fieldLabelName,
58 firstFieldLabelTag, allFieldLabelTags
60 import TyVar ( TyVar )
61 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon )
62 import PrelVals ( rEC_SEL_ERROR_ID )
64 import SrcLoc ( SrcLoc )
65 import BasicTypes ( Arity )
66 import Unique ( Unique )
67 import Maybe ( isJust )
73 %************************************************************************
75 \subsection{Easy ones}
77 %************************************************************************
80 mkImportedId :: Name -> ty -> IdInfo -> GenId ty
81 mkImportedId name ty info = mkId name ty (VanillaId True) info
83 -- SysLocal: for an Id being created by the compiler out of thin air...
84 -- UserLocal: an Id with a name the user might recognize...
85 mkSysLocal :: FAST_STRING -> Unique -> (GenType flexi) -> SrcLoc -> GenId (GenType flexi)
86 mkUserLocal :: OccName -> Unique -> (GenType flexi) -> SrcLoc -> GenId (GenType flexi)
88 mkSysLocal str uniq ty loc
89 = mkVanillaId (mkSysLocalName uniq str loc) ty noIdInfo
91 mkUserLocal occ uniq ty loc
92 = mkVanillaId (mkLocalName uniq occ loc) ty noIdInfo
94 mkSpecPragmaId occ uniq ty loc
95 = mkId (mkLocalName uniq occ loc) ty SpecPragmaId noIdInfo
97 mkUserId :: Name -> GenType flexi -> GenId (GenType flexi)
99 = mkVanillaId name ty noIdInfo
101 mkDefaultMethodId dm_name rec_c ty
102 = mkVanillaId dm_name ty noIdInfo
104 mkDictFunId dfun_name full_ty clas itys
105 = mkVanillaId dfun_name full_ty noIdInfo
107 mkWorkerId uniq unwrkr ty info
108 = mkVanillaId name ty info
110 name = mkCompoundName name_fn uniq (getName unwrkr)
111 name_fn wkr_str = SLIT("$w") _APPEND_ wkr_str
115 %************************************************************************
117 \subsection{Data constructors}
119 %************************************************************************
123 -> [StrictnessMark] -> [FieldLabel]
124 -> [TyVar] -> ThetaType
125 -> [TyVar] -> ThetaType
126 -> [TauType] -> TyCon
128 -- can get the tag and all the pieces of the type from the Type
130 mkDataCon name stricts fields tvs ctxt con_tvs con_ctxt args_tys tycon
131 = ASSERT(length stricts == length args_tys)
134 -- NB: data_con self-recursion; should be OK as tags are not
135 -- looked at until late in the game.
136 data_con = mkId name data_con_ty details (dataConInfo data_con)
137 details = AlgConId data_con_tag stricts fields tvs ctxt con_tvs con_ctxt args_tys tycon
139 data_con_tag = assoc "mkDataCon" (data_con_family `zip` [fIRST_TAG..]) data_con
140 data_con_family = tyConDataCons tycon
141 data_con_ty = mkSigmaTy (tvs++con_tvs) (ctxt++con_ctxt)
142 (mkFunTys args_tys (mkTyConApp tycon (mkTyVarTys tvs)))
145 mkTupleCon :: Arity -> Name -> Type -> Id
146 mkTupleCon arity name ty
149 con_id = mkId name ty (TupleConId arity) (dataConInfo con_id)
152 We're going to build a constructor that looks like:
154 data (Data a, C b) => T a b = T1 !a !Int b
157 \d1::Data a, d2::C b ->
158 \p q r -> case p of { p ->
160 Con T1 [a,b] [p,q,r]}}
164 * d2 is thrown away --- a context in a data decl is used to make sure
165 one *could* construct dictionaries at the site the constructor
166 is used, but the dictionary isn't actually used.
168 * We have to check that we can construct Data dictionaries for
169 the types a and Int. Once we've done that we can throw d1 away too.
171 * We use (case p of ...) to evaluate p, rather than "seq" because
172 all that matters is that the arguments are evaluated. "seq" is
173 very careful to preserve evaluation order, which we don't need
177 dataConInfo :: Id -> IdInfo
180 = setInlinePragInfo IWantToBeINLINEd $
181 -- Always inline constructors if possible
182 setArityInfo (exactArity (length locals)) $
183 setUnfoldingInfo unfolding $
186 unfolding = mkUnfolding con_rhs
188 (tyvars, theta, con_tyvars, con_theta, arg_tys, tycon) = dataConSig con_id
190 dict_tys = [mkDictTy clas tys | (clas,tys) <- theta]
191 con_dict_tys = [mkDictTy clas tys | (clas,tys) <- con_theta]
192 n_dicts = length dict_tys
193 result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
195 locals = mkTemplateLocals (dict_tys ++ con_dict_tys ++ arg_tys)
196 data_args = drop n_dicts locals
197 (data_arg1:_) = data_args -- Used for newtype only
198 strict_marks = dataConStrictMarks con_id
199 strict_args = [arg | (arg,MarkedStrict) <- data_args `zip` strict_marks]
200 -- NB: we can't call mkTemplateLocals twice, because it
201 -- always starts from the same unique.
203 con_app | isNewTyCon tycon
204 = ASSERT( length arg_tys == 1)
205 Note (Coerce result_ty (head arg_tys)) (Var data_arg1)
207 = Con con_id (map TyArg (mkTyVarTys tyvars) ++ map VarArg data_args)
209 con_rhs = mkTyLam tyvars $
211 foldr mk_case con_app strict_args
213 mk_case arg body | isUnpointedType (idType arg)
214 = body -- "!" on unboxed arg does nothing
216 = Case (Var arg) (AlgAlts [] (BindDefault arg body))
217 -- This case shadows "arg" but that's fine
221 %************************************************************************
223 \subsection{Record selectors}
225 %************************************************************************
227 We're going to build a record selector unfolding that looks like this:
229 data T a b c = T1 { ..., op :: a, ...}
230 | T2 { ..., op :: a, ...}
233 sel = /\ a b c -> \ d -> case d of
239 mkRecordSelId field_label selector_ty
240 = ASSERT( null theta && isDataTyCon tycon )
243 sel_id = mkId (fieldLabelName field_label) selector_ty
244 (RecordSelId field_label) info
246 info = exactArity 1 `setArityInfo` (
247 unfolding `setUnfoldingInfo`
249 -- ToDo: consider adding further IdInfo
251 unfolding = mkUnfolding sel_rhs
253 (tyvars, theta, tau) = splitSigmaTy selector_ty
254 (data_ty,rhs_ty) = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
255 -- tau is of form (T a b c -> field-type)
256 (tycon, _, data_cons) = splitAlgTyConApp data_ty
257 tyvar_tys = mkTyVarTys tyvars
259 [data_id] = mkTemplateLocals [data_ty]
260 alts = map mk_maybe_alt data_cons
261 sel_rhs = mkTyLam tyvars $
264 -- if any of the constructors don't have the label, ...
265 (if any (not . isJust) alts then
266 AlgAlts (catMaybes alts)
267 (BindDefault data_id error_expr)
269 AlgAlts (catMaybes alts) NoDefault)
271 mk_maybe_alt data_con
272 = case maybe_the_arg_id of
274 Just the_arg_id -> Just (data_con, arg_ids, Var the_arg_id)
276 arg_ids = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
277 -- The first one will shadow data_id, but who cares
278 field_lbls = dataConFieldLabels data_con
279 maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
281 error_expr = mkApp (Var rEC_SEL_ERROR_ID) [rhs_ty] [LitArg msg_lit]
282 full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
283 msg_lit = NoRepStr (_PK_ full_msg)
287 %************************************************************************
289 \subsection{Dictionary selectors}
291 %************************************************************************
294 mkSuperDictSelId :: Unique -> Class -> FieldLabelTag -> Type -> Id
295 -- The FieldLabelTag says which superclass is selected
297 -- class (C a, C b) => Foo a b where ...
298 -- we get superclass selectors
301 mkSuperDictSelId uniq clas index ty
302 = mkDictSelId name clas ty
304 name = mkCompoundName name_fn uniq (getName clas)
305 name_fn clas_str = clas_str _APPEND_ SLIT("_sc") _APPEND_ (_PK_ (show index))
307 -- For method selectors the clean thing to do is
308 -- to give the method selector the same name as the class op itself.
309 mkMethodSelId name clas ty
310 = mkDictSelId name clas ty
313 Selecting a field for a dictionary. If there is just one field, then
314 there's nothing to do.
317 mkDictSelId name clas ty
320 sel_id = mkId name ty (RecordSelId field_lbl) info
321 field_lbl = mkFieldLabel name ty tag
322 tag = assoc "MkId.mkDictSelId" ((sc_sel_ids ++ op_sel_ids) `zip` allFieldLabelTags) sel_id
324 info = setInlinePragInfo IWantToBeINLINEd $
325 setUnfoldingInfo unfolding noIdInfo
326 -- The always-inline thing means we don't need any other IdInfo
328 unfolding = mkUnfolding rhs
330 (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
332 tycon = classTyCon clas
333 [data_con] = tyConDataCons tycon
334 tyvar_tys = mkTyVarTys tyvars
335 arg_tys = dataConArgTys data_con tyvar_tys
336 the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
338 dict_ty = mkDictTy clas tyvar_tys
339 (dict_id:arg_ids) = mkTemplateLocals (dict_ty : arg_tys)
341 rhs | isNewTyCon tycon = mkLam tyvars [dict_id] $
342 Note (Coerce (head arg_tys) dict_ty) (Var dict_id)
343 | otherwise = mkLam tyvars [dict_id] $
345 AlgAlts [(data_con, arg_ids, Var the_arg_id)] NoDefault
349 %************************************************************************
351 \subsection{Primitive operations
353 %************************************************************************
357 mkPrimitiveId name ty prim_op
358 = mkId name ty (PrimitiveId prim_op) info
361 info = setUnfoldingInfo unfolding $
362 setInlinePragInfo IMustBeINLINEd $
363 -- The pragma @IMustBeINLINEd@ says that this Id absolutely
364 -- must be inlined. It's only used for primitives,
365 -- because we don't want to make a closure for each of them.
368 unfolding = mkUnfolding rhs
370 (tyvars, tau) = splitForAllTys ty
371 (arg_tys, _) = splitFunTys tau
373 args = mkTemplateLocals arg_tys
374 rhs = mkLam tyvars args $
376 ([TyArg (mkTyVarTy tv) | tv <- tyvars] ++
377 [VarArg v | v <- args])
381 %************************************************************************
383 \subsection{Catch-all}
385 %************************************************************************
389 = pprTrace "addStandardIdInfo missing:" (ppr id) id