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,
26 -- And some particular Ids; see below for why they are wired in
28 unsafeCoerceId, realWorldPrimId,
29 eRROR_ID, rEC_SEL_ERROR_ID, pAT_ERROR_ID, rEC_CON_ERROR_ID,
30 rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID,
31 nO_METHOD_BINDING_ERROR_ID, aBSENT_ERROR_ID, pAR_ERROR_ID
34 #include "HsVersions.h"
37 import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy,
38 intPrimTy, realWorldStatePrimTy
40 import TysWiredIn ( boolTy, charTy, mkListTy )
41 import PrelMods ( pREL_ERR, pREL_GHC )
42 import Type ( Type, ThetaType,
43 mkDictTy, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy,
44 isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfTypes,
45 splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp,
46 splitFunTys, splitForAllTys, unUsgTy,
49 import Module ( Module )
50 import CoreUnfold ( mkUnfolding )
51 import Subst ( mkTopTyVarSubst, substTheta )
52 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon )
53 import Class ( Class, classBigSig, classTyCon )
54 import Var ( Id, TyVar )
55 import VarSet ( isEmptyVarSet )
56 import Const ( Con(..) )
57 import Name ( mkDerivedName, mkWiredInIdName, mkLocalName,
58 mkWorkerOcc, mkSuperDictSelOcc,
61 import OccName ( mkSrcVarOcc )
62 import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName )
63 import Demand ( wwStrict )
64 import DataCon ( DataCon, StrictnessMark(..), dataConStrictMarks, dataConFieldLabels,
65 dataConArgTys, dataConSig, dataConRawArgTys
67 import Id ( idType, mkId,
68 mkVanillaId, mkTemplateLocals,
69 mkTemplateLocal, setInlinePragma
71 import IdInfo ( vanillaIdInfo, mkIdInfo,
72 exactArity, setUnfoldingInfo, setCafInfo,
73 setArityInfo, setInlinePragInfo,
74 mkStrictnessInfo, setStrictnessInfo,
75 IdFlavour(..), InlinePragInfo(..), CafInfo(..), IdInfo
77 import FieldLabel ( FieldLabel, FieldLabelTag, mkFieldLabel, fieldLabelName,
78 firstFieldLabelTag, allFieldLabelTags
82 import BasicTypes ( Arity )
84 import Maybe ( isJust )
91 %************************************************************************
93 \subsection{Wired in Ids}
95 %************************************************************************
99 = [ -- These error-y things are wired in because we don't yet have
100 -- a way to express in an interface file that the result type variable
101 -- is 'open'; that is can be unified with an unboxed type
103 -- [The interface file format now carry such information, but there's
104 -- no way yet of expressing at the definition site for these error-reporting
105 -- functions that they have an 'open' result type. -- sof 1/99]
109 , iRREFUT_PAT_ERROR_ID
110 , nON_EXHAUSTIVE_GUARDS_ERROR_ID
111 , nO_METHOD_BINDING_ERROR_ID
117 -- These two can't be defined in Haskell
124 %************************************************************************
126 \subsection{Easy ones}
128 %************************************************************************
131 mkSpecPragmaId occ uniq ty loc
132 = mkId (mkLocalName uniq occ loc) ty (mkIdInfo SpecPragmaId)
133 -- Maybe a SysLocal? But then we'd lose the location
135 mkDefaultMethodId dm_name rec_c ty
136 = mkVanillaId dm_name ty
138 mkWorkerId uniq unwrkr ty
139 = mkVanillaId (mkDerivedName mkWorkerOcc (getName unwrkr) uniq) ty
142 %************************************************************************
144 \subsection{Data constructors}
146 %************************************************************************
149 mkDataConId :: DataCon -> Id
151 = mkId (getName data_con)
153 (dataConInfo data_con)
155 (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon) = dataConSig data_con
156 id_ty = mkSigmaTy (tyvars ++ ex_tyvars)
158 (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)))
161 We're going to build a constructor that looks like:
163 data (Data a, C b) => T a b = T1 !a !Int b
166 \d1::Data a, d2::C b ->
167 \p q r -> case p of { p ->
169 Con T1 [a,b] [p,q,r]}}
173 * d2 is thrown away --- a context in a data decl is used to make sure
174 one *could* construct dictionaries at the site the constructor
175 is used, but the dictionary isn't actually used.
177 * We have to check that we can construct Data dictionaries for
178 the types a and Int. Once we've done that we can throw d1 away too.
180 * We use (case p of q -> ...) to evaluate p, rather than "seq" because
181 all that matters is that the arguments are evaluated. "seq" is
182 very careful to preserve evaluation order, which we don't need
185 You might think that we could simply give constructors some strictness
186 info, like PrimOps, and let CoreToStg do the let-to-case transformation.
187 But we don't do that because in the case of primops and functions strictness
188 is a *property* not a *requirement*. In the case of constructors we need to
189 do something active to evaluate the argument.
191 Making an explicit case expression allows the simplifier to eliminate
192 it in the (common) case where the constructor arg is already evaluated.
195 dataConInfo :: DataCon -> IdInfo
198 = mkIdInfo (ConstantId (DataCon data_con))
199 `setArityInfo` exactArity (n_dicts + n_ex_dicts + n_id_args)
200 `setUnfoldingInfo` unfolding
202 unfolding = mkUnfolding (Note InlineMe con_rhs)
204 (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon)
205 = dataConSig data_con
206 rep_arg_tys = dataConRawArgTys data_con
207 all_tyvars = tyvars ++ ex_tyvars
209 dict_tys = [mkDictTy clas tys | (clas,tys) <- theta]
210 ex_dict_tys = [mkDictTy clas tys | (clas,tys) <- ex_theta]
212 n_dicts = length dict_tys
213 n_ex_dicts = length ex_dict_tys
214 n_id_args = length orig_arg_tys
215 n_rep_args = length rep_arg_tys
217 result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
219 mkLocals i n tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
220 (dict_args, i1) = mkLocals 1 n_dicts dict_tys
221 (ex_dict_args,i2) = mkLocals i1 n_ex_dicts ex_dict_tys
222 (id_args,i3) = mkLocals i2 n_id_args orig_arg_tys
224 (id_arg1:_) = id_args -- Used for newtype only
225 strict_marks = dataConStrictMarks data_con
229 = ASSERT( length orig_arg_tys == 1 )
230 Note (Coerce result_ty (head orig_arg_tys)) (Var id_arg1)
233 (map Type (mkTyVarTys all_tyvars) ++
234 map Var (reverse rep_ids))
236 con_rhs = mkLams all_tyvars $ mkLams dict_args $
237 mkLams ex_dict_args $ mkLams id_args $
238 foldr mk_case con_app
239 (zip (ex_dict_args++id_args) strict_marks) i3 []
242 :: (Id, StrictnessMark) -- arg, strictness
243 -> (Int -> [Id] -> CoreExpr) -- body
244 -> Int -- next rep arg id
245 -> [Id] -- rep args so far
247 mk_case (arg,strict) body i rep_args
249 NotMarkedStrict -> body i (arg:rep_args)
251 | isUnLiftedType (idType arg) -> body i (arg:rep_args)
253 Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))]
255 MarkedUnboxed con tys ->
256 Case (Var arg) arg [(DataCon con, con_args,
257 body i' (reverse con_args++rep_args))]
258 where n_tys = length tys
259 (con_args,i') = mkLocals i (length tys) tys
263 %************************************************************************
265 \subsection{Record selectors}
267 %************************************************************************
269 We're going to build a record selector unfolding that looks like this:
271 data T a b c = T1 { ..., op :: a, ...}
272 | T2 { ..., op :: a, ...}
275 sel = /\ a b c -> \ d -> case d of
281 mkRecordSelId field_label selector_ty
282 = ASSERT( null theta && isDataTyCon tycon )
285 sel_id = mkId (fieldLabelName field_label) selector_ty info
287 info = mkIdInfo (RecordSelId field_label)
288 `setArityInfo` exactArity 1
289 `setUnfoldingInfo` unfolding
291 -- ToDo: consider adding further IdInfo
293 unfolding = mkUnfolding sel_rhs
295 (tyvars, theta, tau) = splitSigmaTy selector_ty
296 (data_ty,rhs_ty) = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
297 -- tau is of form (T a b c -> field-type)
298 (tycon, _, data_cons) = splitAlgTyConApp data_ty
299 tyvar_tys = mkTyVarTys tyvars
301 [data_id] = mkTemplateLocals [data_ty]
302 alts = map mk_maybe_alt data_cons
303 the_alts = catMaybes alts
304 default_alt | all isJust alts = [] -- No default needed
305 | otherwise = [(DEFAULT, [], error_expr)]
307 sel_rhs = mkLams tyvars $ Lam data_id $
308 Case (Var data_id) data_id (the_alts ++ default_alt)
310 mk_maybe_alt data_con
311 = case maybe_the_arg_id of
313 Just the_arg_id -> Just (DataCon data_con, arg_ids, Var the_arg_id)
315 arg_ids = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
316 -- The first one will shadow data_id, but who cares
317 field_lbls = dataConFieldLabels data_con
318 maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
320 error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy rhs_ty), mkStringLit full_msg]
321 -- preserves invariant that type args are *not* usage-annotated on top. KSW 1999-04.
322 full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
326 %************************************************************************
328 \subsection{Newtype field selectors}
330 %************************************************************************
332 Possibly overkill to do it this way:
335 mkNewTySelId field_label selector_ty = sel_id
337 sel_id = mkId (fieldLabelName field_label) selector_ty info
340 info = mkIdInfo (RecordSelId field_label)
341 `setArityInfo` exactArity 1
342 `setUnfoldingInfo` unfolding
344 -- ToDo: consider adding further IdInfo
346 unfolding = mkUnfolding sel_rhs
348 (tyvars, theta, tau) = splitSigmaTy selector_ty
349 (data_ty,rhs_ty) = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
350 -- tau is of form (T a b c -> field-type)
351 (tycon, _, data_cons) = splitAlgTyConApp data_ty
352 tyvar_tys = mkTyVarTys tyvars
354 [data_id] = mkTemplateLocals [data_ty]
355 sel_rhs = mkLams tyvars $ Lam data_id $
356 Note (Coerce rhs_ty data_ty) (Var data_id)
360 %************************************************************************
362 \subsection{Dictionary selectors}
364 %************************************************************************
366 Selecting a field for a dictionary. If there is just one field, then
367 there's nothing to do.
370 mkDictSelId name clas ty
373 sel_id = mkId name ty info
374 field_lbl = mkFieldLabel name ty tag
375 tag = assoc "MkId.mkDictSelId" ((sc_sel_ids ++ op_sel_ids) `zip` allFieldLabelTags) sel_id
377 info = mkIdInfo (RecordSelId field_lbl)
378 `setUnfoldingInfo` unfolding
380 -- We no longer use 'must-inline' on record selectors. They'll
381 -- inline like crazy if they scrutinise a constructor
383 unfolding = mkUnfolding rhs
385 (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
387 tycon = classTyCon clas
388 [data_con] = tyConDataCons tycon
389 tyvar_tys = mkTyVarTys tyvars
390 arg_tys = dataConArgTys data_con tyvar_tys
391 the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
393 dict_ty = mkDictTy clas tyvar_tys
394 (dict_id:arg_ids) = mkTemplateLocals (dict_ty : arg_tys)
396 rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
397 Note (Coerce (head arg_tys) dict_ty) (Var dict_id)
398 | otherwise = mkLams tyvars $ Lam dict_id $
399 Case (Var dict_id) dict_id
400 [(DataCon data_con, arg_ids, Var the_arg_id)]
404 %************************************************************************
406 \subsection{Primitive operations
408 %************************************************************************
411 mkPrimitiveId :: PrimOp -> Id
412 mkPrimitiveId prim_op
415 (tyvars,arg_tys,res_ty) = primOpSig prim_op
416 ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
417 name = mkPrimOpIdName prim_op id
418 id = mkId name ty info
420 info = mkIdInfo (ConstantId (PrimOp prim_op))
421 `setUnfoldingInfo` unfolding
422 `setInlinePragInfo` IMustBeINLINEd
423 -- The pragma @IMustBeINLINEd@ says that this Id absolutely
424 -- must be inlined. It's only used for primitives,
425 -- because we don't want to make a closure for each of them.
428 unfolding = mkUnfolding rhs
430 args = mkTemplateLocals arg_tys
431 rhs = mkLams tyvars $ mkLams args $
432 mkPrimApp prim_op (map Type (mkTyVarTys tyvars) ++ map Var args)
436 %************************************************************************
438 \subsection{DictFuns}
440 %************************************************************************
443 mkDictFunId :: Name -- Name to use for the dict fun;
450 mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
451 = mkVanillaId dfun_name dfun_ty
453 (class_tyvars, sc_theta, _, _, _) = classBigSig clas
454 sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
456 dfun_theta = case inst_decl_theta of
457 [] -> [] -- If inst_decl_theta is empty, then we don't
458 -- want to have any dict arguments, so that we can
459 -- expose the constant methods.
461 other -> nub (inst_decl_theta ++ filter not_const sc_theta')
462 -- Otherwise we pass the superclass dictionaries to
463 -- the dictionary function; the Mark Jones optimisation.
465 -- NOTE the "nub". I got caught by this one:
466 -- class Monad m => MonadT t m where ...
467 -- instance Monad m => MonadT (EnvT env) m where ...
468 -- Here, the inst_decl_theta has (Monad m); but so
469 -- does the sc_theta'!
471 -- NOTE the "not_const". I got caught by this one too:
472 -- class Foo a => Baz a b where ...
473 -- instance Wob b => Baz T b where..
474 -- Now sc_theta' has Foo T
476 dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
478 not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
482 %************************************************************************
484 \subsection{Un-definable}
486 %************************************************************************
488 These two can't be defined in Haskell.
490 unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
491 just gets expanded into a type coercion wherever it occurs. Hence we
492 add it as a built-in Id with an unfolding here.
494 The type variables we use here are "open" type variables: this means
495 they can unify with both unlifted and lifted types. Hence we provide
496 another gun with which to shoot yourself in the foot.
500 = pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info
503 `setUnfoldingInfo` mkUnfolding rhs
504 `setInlinePragInfo` IMustBeINLINEd
507 ty = mkForAllTys [openAlphaTyVar,openBetaTyVar]
508 (mkFunTy openAlphaTy openBetaTy)
509 [x] = mkTemplateLocals [openAlphaTy]
510 rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
511 Note (Coerce openBetaTy openAlphaTy) (Var x)
515 @getTag#@ is another function which can't be defined in Haskell. It needs to
516 evaluate its argument and call the dataToTag# primitive.
520 = pcMiscPrelId getTagIdKey pREL_GHC SLIT("getTag#") ty info
523 `setUnfoldingInfo` mkUnfolding rhs
524 `setInlinePragInfo` IMustBeINLINEd
525 -- We don't provide a defn for this; you must inline it
527 ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy intPrimTy)
528 [x,y] = mkTemplateLocals [alphaTy,alphaTy]
529 rhs = mkLams [alphaTyVar,x] $
530 Case (Var x) y [ (DEFAULT, [],
531 Con (PrimOp DataToTagOp) [Type alphaTy, Var y]) ]
534 @realWorld#@ used to be a magic literal, \tr{void#}. If things get
535 nasty as-is, change it back to a literal (@Literal@).
538 realWorldPrimId -- :: State# RealWorld
539 = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#")
545 %************************************************************************
547 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
549 %************************************************************************
551 GHC randomly injects these into the code.
553 @patError@ is just a version of @error@ for pattern-matching
554 failures. It knows various ``codes'' which expand to longer
555 strings---this saves space!
557 @absentErr@ is a thing we put in for ``absent'' arguments. They jolly
558 well shouldn't be yanked on, but if one is, then you will get a
559 friendly message from @absentErr@ (rather than a totally random
562 @parError@ is a special version of @error@ which the compiler does
563 not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
564 templates, but we don't ever expect to generate code for it.
568 = pc_bottoming_Id errorIdKey pREL_ERR SLIT("error") errorTy
570 = generic_ERROR_ID recSelErrIdKey SLIT("patError")
572 = generic_ERROR_ID patErrorIdKey SLIT("patError")
574 = generic_ERROR_ID recConErrorIdKey SLIT("recConError")
576 = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError")
578 = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
579 nON_EXHAUSTIVE_GUARDS_ERROR_ID
580 = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError")
581 nO_METHOD_BINDING_ERROR_ID
582 = generic_ERROR_ID noMethodBindingErrorIdKey SLIT("noMethodBindingError")
585 = pc_bottoming_Id absentErrorIdKey pREL_ERR SLIT("absentErr")
586 (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
589 = pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError")
590 (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafIdInfo
595 %************************************************************************
597 \subsection{Utilities}
599 %************************************************************************
602 pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
603 pcMiscPrelId key mod str ty info
605 name = mkWiredInIdName key mod (mkSrcVarOcc str) imp
606 imp = mkId name ty info -- the usual case...
609 -- We lie and say the thing is imported; otherwise, we get into
610 -- a mess with dependency analysis; e.g., core2stg may heave in
611 -- random calls to GHCbase.unpackPS__. If GHCbase is the module
612 -- being compiled, then it's just a matter of luck if the definition
613 -- will be in "the right place" to be in scope.
615 pc_bottoming_Id key mod name ty
616 = pcMiscPrelId key mod name ty bottoming_info
618 bottoming_info = noCafIdInfo
619 `setStrictnessInfo` mkStrictnessInfo ([wwStrict], True)
621 -- these "bottom" out, no matter what their arguments
623 generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy
626 noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs
628 (openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars
629 openAlphaTy = mkTyVarTy openAlphaTyVar
630 openBetaTy = mkTyVarTy openBetaTyVar
633 errorTy = mkUsgTy UsMany $
634 mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkUsgTy UsOnce (mkListTy charTy)]
635 (mkUsgTy UsMany openAlphaTy))
636 -- Notice the openAlphaTyVar. It says that "error" can be applied
637 -- to unboxed as well as boxed types. This is OK because it never
638 -- returns, so the return type is irrelevant.