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 the_alts = catMaybes alts
263 sel_rhs = mkTyLam tyvars $
266 -- if any of the constructors don't have the label, ...
267 (if any (not . isJust) alts then
268 AlgAlts the_alts(BindDefault data_id error_expr)
270 AlgAlts the_alts NoDefault)
272 mk_maybe_alt data_con
273 = case maybe_the_arg_id of
275 Just the_arg_id -> Just (data_con, arg_ids, Var the_arg_id)
277 arg_ids = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
278 -- The first one will shadow data_id, but who cares
279 field_lbls = dataConFieldLabels data_con
280 maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
282 error_expr = mkApp (Var rEC_SEL_ERROR_ID) [rhs_ty] [LitArg msg_lit]
283 full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
284 msg_lit = NoRepStr (_PK_ full_msg)
288 %************************************************************************
290 \subsection{Dictionary selectors}
292 %************************************************************************
295 mkSuperDictSelId :: Unique -> Class -> FieldLabelTag -> Type -> Id
296 -- The FieldLabelTag says which superclass is selected
298 -- class (C a, C b) => Foo a b where ...
299 -- we get superclass selectors
302 mkSuperDictSelId uniq clas index ty
303 = mkDictSelId name clas ty
305 name = mkCompoundName name_fn uniq (getName clas)
306 name_fn clas_str = clas_str _APPEND_ SLIT("_sc") _APPEND_ (_PK_ (show index))
308 -- For method selectors the clean thing to do is
309 -- to give the method selector the same name as the class op itself.
310 mkMethodSelId name clas ty
311 = mkDictSelId name clas ty
314 Selecting a field for a dictionary. If there is just one field, then
315 there's nothing to do.
318 mkDictSelId name clas ty
321 sel_id = mkId name ty (RecordSelId field_lbl) info
322 field_lbl = mkFieldLabel name ty tag
323 tag = assoc "MkId.mkDictSelId" ((sc_sel_ids ++ op_sel_ids) `zip` allFieldLabelTags) sel_id
325 info = setInlinePragInfo IMustBeINLINEd $
326 setUnfoldingInfo unfolding noIdInfo
327 -- The always-inline thing means we don't need any other IdInfo
328 -- We need "Must" inline because we don't create any bindigs for
331 unfolding = mkUnfolding rhs
333 (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
335 tycon = classTyCon clas
336 [data_con] = tyConDataCons tycon
337 tyvar_tys = mkTyVarTys tyvars
338 arg_tys = dataConArgTys data_con tyvar_tys
339 the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
341 dict_ty = mkDictTy clas tyvar_tys
342 (dict_id:arg_ids) = mkTemplateLocals (dict_ty : arg_tys)
344 rhs | isNewTyCon tycon = mkLam tyvars [dict_id] $
345 Note (Coerce (head arg_tys) dict_ty) (Var dict_id)
346 | otherwise = mkLam tyvars [dict_id] $
348 AlgAlts [(data_con, arg_ids, Var the_arg_id)] NoDefault
352 %************************************************************************
354 \subsection{Primitive operations
356 %************************************************************************
360 mkPrimitiveId name ty prim_op
361 = mkId name ty (PrimitiveId prim_op) info
364 info = setUnfoldingInfo unfolding $
365 setInlinePragInfo IMustBeINLINEd $
366 -- The pragma @IMustBeINLINEd@ says that this Id absolutely
367 -- must be inlined. It's only used for primitives,
368 -- because we don't want to make a closure for each of them.
371 unfolding = mkUnfolding rhs
373 (tyvars, tau) = splitForAllTys ty
374 (arg_tys, _) = splitFunTys tau
376 args = mkTemplateLocals arg_tys
377 rhs = mkLam tyvars args $
379 ([TyArg (mkTyVarTy tv) | tv <- tyvars] ++
380 [VarArg v | v <- args])
384 %************************************************************************
386 \subsection{Catch-all}
388 %************************************************************************
392 = pprTrace "addStandardIdInfo missing:" (ppr id) id