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 IMustBeINLINEd $
181 -- Always inline constructors; we don't create a binding for them
182 -- (well, at least not for dict constructors, since they are
184 setArityInfo (exactArity (length locals)) $
185 setUnfoldingInfo unfolding $
188 unfolding = mkUnfolding con_rhs
190 (tyvars, theta, con_tyvars, con_theta, arg_tys, tycon) = dataConSig con_id
192 dict_tys = [mkDictTy clas tys | (clas,tys) <- theta]
193 con_dict_tys = [mkDictTy clas tys | (clas,tys) <- con_theta]
194 n_dicts = length dict_tys
195 result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
197 locals = mkTemplateLocals (dict_tys ++ con_dict_tys ++ arg_tys)
198 data_args = drop n_dicts locals
199 (data_arg1:_) = data_args -- Used for newtype only
200 strict_marks = dataConStrictMarks con_id
201 strict_args = [arg | (arg,MarkedStrict) <- data_args `zip` strict_marks]
202 -- NB: we can't call mkTemplateLocals twice, because it
203 -- always starts from the same unique.
205 con_app | isNewTyCon tycon
206 = ASSERT( length arg_tys == 1)
207 Note (Coerce result_ty (head arg_tys)) (Var data_arg1)
209 = Con con_id (map TyArg (mkTyVarTys tyvars) ++ map VarArg data_args)
211 con_rhs = mkTyLam tyvars $
213 foldr mk_case con_app strict_args
215 mk_case arg body | isUnpointedType (idType arg)
216 = body -- "!" on unboxed arg does nothing
218 = Case (Var arg) (AlgAlts [] (BindDefault arg body))
219 -- This case shadows "arg" but that's fine
223 %************************************************************************
225 \subsection{Record selectors}
227 %************************************************************************
229 We're going to build a record selector unfolding that looks like this:
231 data T a b c = T1 { ..., op :: a, ...}
232 | T2 { ..., op :: a, ...}
235 sel = /\ a b c -> \ d -> case d of
241 mkRecordSelId field_label selector_ty
242 = ASSERT( null theta && isDataTyCon tycon )
245 sel_id = mkId (fieldLabelName field_label) selector_ty
246 (RecordSelId field_label) info
248 info = exactArity 1 `setArityInfo` (
249 unfolding `setUnfoldingInfo`
251 -- ToDo: consider adding further IdInfo
253 unfolding = mkUnfolding sel_rhs
255 (tyvars, theta, tau) = splitSigmaTy selector_ty
256 (data_ty,rhs_ty) = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
257 -- tau is of form (T a b c -> field-type)
258 (tycon, _, data_cons) = splitAlgTyConApp data_ty
259 tyvar_tys = mkTyVarTys tyvars
261 [data_id] = mkTemplateLocals [data_ty]
262 alts = map mk_maybe_alt data_cons
263 the_alts = catMaybes alts
265 sel_rhs = mkTyLam tyvars $
268 -- if any of the constructors don't have the label, ...
269 (if any (not . isJust) alts then
270 AlgAlts the_alts(BindDefault data_id error_expr)
272 AlgAlts the_alts NoDefault)
274 mk_maybe_alt data_con
275 = case maybe_the_arg_id of
277 Just the_arg_id -> Just (data_con, arg_ids, Var the_arg_id)
279 arg_ids = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
280 -- The first one will shadow data_id, but who cares
281 field_lbls = dataConFieldLabels data_con
282 maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
284 error_expr = mkApp (Var rEC_SEL_ERROR_ID) [rhs_ty] [LitArg msg_lit]
285 full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
286 msg_lit = NoRepStr (_PK_ full_msg)
290 %************************************************************************
292 \subsection{Dictionary selectors}
294 %************************************************************************
297 mkSuperDictSelId :: Unique -> Class -> FieldLabelTag -> Type -> Id
298 -- The FieldLabelTag says which superclass is selected
300 -- class (C a, C b) => Foo a b where ...
301 -- we get superclass selectors
304 mkSuperDictSelId uniq clas index ty
305 = mkDictSelId name clas ty
307 name = mkCompoundName name_fn uniq (getName clas)
308 name_fn clas_str = clas_str _APPEND_ SLIT("_sc") _APPEND_ (_PK_ (show index))
310 -- For method selectors the clean thing to do is
311 -- to give the method selector the same name as the class op itself.
312 mkMethodSelId name clas ty
313 = mkDictSelId name clas ty
316 Selecting a field for a dictionary. If there is just one field, then
317 there's nothing to do.
320 mkDictSelId name clas ty
323 sel_id = mkId name ty (RecordSelId field_lbl) info
324 field_lbl = mkFieldLabel name ty tag
325 tag = assoc "MkId.mkDictSelId" ((sc_sel_ids ++ op_sel_ids) `zip` allFieldLabelTags) sel_id
327 info = setInlinePragInfo IMustBeINLINEd $
328 setUnfoldingInfo unfolding noIdInfo
329 -- The always-inline thing means we don't need any other IdInfo
330 -- We need "Must" inline because we don't create any bindigs for
333 unfolding = mkUnfolding rhs
335 (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
337 tycon = classTyCon clas
338 [data_con] = tyConDataCons tycon
339 tyvar_tys = mkTyVarTys tyvars
340 arg_tys = dataConArgTys data_con tyvar_tys
341 the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
343 dict_ty = mkDictTy clas tyvar_tys
344 (dict_id:arg_ids) = mkTemplateLocals (dict_ty : arg_tys)
346 rhs | isNewTyCon tycon = mkLam tyvars [dict_id] $
347 Note (Coerce (head arg_tys) dict_ty) (Var dict_id)
348 | otherwise = mkLam tyvars [dict_id] $
350 AlgAlts [(data_con, arg_ids, Var the_arg_id)] NoDefault
354 %************************************************************************
356 \subsection{Primitive operations
358 %************************************************************************
362 mkPrimitiveId name ty prim_op
363 = mkId name ty (PrimitiveId prim_op) info
366 info = setUnfoldingInfo unfolding $
367 setInlinePragInfo IMustBeINLINEd $
368 -- The pragma @IMustBeINLINEd@ says that this Id absolutely
369 -- must be inlined. It's only used for primitives,
370 -- because we don't want to make a closure for each of them.
373 unfolding = mkUnfolding rhs
375 (tyvars, tau) = splitForAllTys ty
376 (arg_tys, _) = splitFunTys tau
378 args = mkTemplateLocals arg_tys
379 rhs = mkLam tyvars args $
381 ([TyArg (mkTyVarTy tv) | tv <- tyvars] ++
382 [VarArg v | v <- args])
386 %************************************************************************
388 \subsection{Catch-all}
390 %************************************************************************
394 = pprTrace "addStandardIdInfo missing:" (ppr id) id