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 PrelRules ( primOpRule )
43 import Rules ( addRule )
44 import Type ( Type, ClassContext, mkDictTy, mkTyConApp, mkTyVarTys,
45 mkFunTys, mkFunTy, mkSigmaTy, classesToPreds,
46 isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfTypes,
47 splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp,
48 splitFunTys, splitForAllTys, unUsgTy,
51 import Module ( Module )
52 import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding )
53 import Subst ( mkTopTyVarSubst, substClasses )
54 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon )
55 import Class ( Class, classBigSig, classTyCon, classTyVars, classSelIds )
56 import Var ( Id, TyVar )
57 import VarSet ( isEmptyVarSet )
58 import Const ( Con(..) )
59 import Name ( mkDerivedName, mkWiredInIdName, mkLocalName,
60 mkWorkerOcc, mkSuperDictSelOcc,
63 import OccName ( mkSrcVarOcc )
64 import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName, primOpArity, primOpStrictness )
65 import Demand ( wwStrict )
66 import DataCon ( DataCon, StrictnessMark(..), dataConStrictMarks, dataConFieldLabels,
67 dataConArgTys, dataConSig, dataConRawArgTys
69 import Id ( idType, mkId,
70 mkVanillaId, mkTemplateLocals,
71 mkTemplateLocal, setInlinePragma
73 import IdInfo ( vanillaIdInfo, mkIdInfo,
74 exactArity, setUnfoldingInfo, setCafInfo,
75 setArityInfo, setInlinePragInfo, setSpecInfo,
76 mkStrictnessInfo, setStrictnessInfo,
77 IdFlavour(..), InlinePragInfo(..), CafInfo(..), IdInfo
79 import FieldLabel ( FieldLabel, FieldLabelTag, mkFieldLabel, fieldLabelName,
80 firstFieldLabelTag, allFieldLabelTags
84 import BasicTypes ( Arity )
86 import Maybe ( isJust )
93 %************************************************************************
95 \subsection{Wired in Ids}
97 %************************************************************************
101 = [ -- These error-y things are wired in because we don't yet have
102 -- a way to express in an interface file that the result type variable
103 -- is 'open'; that is can be unified with an unboxed type
105 -- [The interface file format now carry such information, but there's
106 -- no way yet of expressing at the definition site for these error-reporting
107 -- functions that they have an 'open' result type. -- sof 1/99]
111 , iRREFUT_PAT_ERROR_ID
112 , nON_EXHAUSTIVE_GUARDS_ERROR_ID
113 , nO_METHOD_BINDING_ERROR_ID
119 -- These two can't be defined in Haskell
126 %************************************************************************
128 \subsection{Easy ones}
130 %************************************************************************
133 mkSpecPragmaId occ uniq ty loc
134 = mkId (mkLocalName uniq occ loc) ty (mkIdInfo SpecPragmaId)
135 -- Maybe a SysLocal? But then we'd lose the location
137 mkDefaultMethodId dm_name rec_c ty
138 = mkVanillaId dm_name ty
140 mkWorkerId uniq unwrkr ty
141 = mkVanillaId (mkDerivedName mkWorkerOcc (getName unwrkr) uniq) ty
144 %************************************************************************
146 \subsection{Data constructors}
148 %************************************************************************
151 mkDataConId :: DataCon -> Id
153 = mkId (getName data_con)
155 (dataConInfo data_con)
157 (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon) = dataConSig data_con
158 id_ty = mkSigmaTy (tyvars ++ ex_tyvars)
159 (classesToPreds (theta ++ ex_theta))
160 (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)))
163 We're going to build a constructor that looks like:
165 data (Data a, C b) => T a b = T1 !a !Int b
168 \d1::Data a, d2::C b ->
169 \p q r -> case p of { p ->
171 Con T1 [a,b] [p,q,r]}}
175 * d2 is thrown away --- a context in a data decl is used to make sure
176 one *could* construct dictionaries at the site the constructor
177 is used, but the dictionary isn't actually used.
179 * We have to check that we can construct Data dictionaries for
180 the types a and Int. Once we've done that we can throw d1 away too.
182 * We use (case p of q -> ...) to evaluate p, rather than "seq" because
183 all that matters is that the arguments are evaluated. "seq" is
184 very careful to preserve evaluation order, which we don't need
187 You might think that we could simply give constructors some strictness
188 info, like PrimOps, and let CoreToStg do the let-to-case transformation.
189 But we don't do that because in the case of primops and functions strictness
190 is a *property* not a *requirement*. In the case of constructors we need to
191 do something active to evaluate the argument.
193 Making an explicit case expression allows the simplifier to eliminate
194 it in the (common) case where the constructor arg is already evaluated.
197 dataConInfo :: DataCon -> IdInfo
200 = mkIdInfo (ConstantId (DataCon data_con))
201 `setArityInfo` exactArity (n_dicts + n_ex_dicts + n_id_args)
202 `setUnfoldingInfo` unfolding
204 unfolding = mkTopUnfolding (Note InlineMe con_rhs)
205 -- The dictionary constructors of a class don't get a binding,
206 -- but they are always saturated, so they should always be inlined.
208 (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon)
209 = dataConSig data_con
210 rep_arg_tys = dataConRawArgTys data_con
211 all_tyvars = tyvars ++ ex_tyvars
213 dict_tys = [mkDictTy clas tys | (clas,tys) <- theta]
214 ex_dict_tys = [mkDictTy clas tys | (clas,tys) <- ex_theta]
216 n_dicts = length dict_tys
217 n_ex_dicts = length ex_dict_tys
218 n_id_args = length orig_arg_tys
219 n_rep_args = length rep_arg_tys
221 result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
223 mkLocals i n tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
224 (dict_args, i1) = mkLocals 1 n_dicts dict_tys
225 (ex_dict_args,i2) = mkLocals i1 n_ex_dicts ex_dict_tys
226 (id_args,i3) = mkLocals i2 n_id_args orig_arg_tys
228 (id_arg1:_) = id_args -- Used for newtype only
229 strict_marks = dataConStrictMarks data_con
233 = ASSERT( length orig_arg_tys == 1 )
234 Note (Coerce result_ty (head orig_arg_tys)) (Var id_arg1)
237 (map Type (mkTyVarTys all_tyvars) ++
238 map Var (reverse rep_ids))
240 con_rhs = mkLams all_tyvars $ mkLams dict_args $
241 mkLams ex_dict_args $ mkLams id_args $
242 foldr mk_case con_app
243 (zip (ex_dict_args++id_args) strict_marks) i3 []
246 :: (Id, StrictnessMark) -- arg, strictness
247 -> (Int -> [Id] -> CoreExpr) -- body
248 -> Int -- next rep arg id
249 -> [Id] -- rep args so far
251 mk_case (arg,strict) body i rep_args
253 NotMarkedStrict -> body i (arg:rep_args)
255 | isUnLiftedType (idType arg) -> body i (arg:rep_args)
257 Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))]
259 MarkedUnboxed con tys ->
260 Case (Var arg) arg [(DataCon con, con_args,
261 body i' (reverse con_args++rep_args))]
262 where n_tys = length tys
263 (con_args,i') = mkLocals i (length tys) tys
267 %************************************************************************
269 \subsection{Record selectors}
271 %************************************************************************
273 We're going to build a record selector unfolding that looks like this:
275 data T a b c = T1 { ..., op :: a, ...}
276 | T2 { ..., op :: a, ...}
279 sel = /\ a b c -> \ d -> case d of
285 mkRecordSelId field_label selector_ty
286 = ASSERT( null theta && isDataTyCon tycon )
289 sel_id = mkId (fieldLabelName field_label) selector_ty info
291 info = mkIdInfo (RecordSelId field_label)
292 `setArityInfo` exactArity 1
293 `setUnfoldingInfo` unfolding
295 -- ToDo: consider adding further IdInfo
297 unfolding = mkTopUnfolding sel_rhs
299 (tyvars, theta, tau) = splitSigmaTy selector_ty
300 (data_ty,rhs_ty) = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
301 -- tau is of form (T a b c -> field-type)
302 (tycon, _, data_cons) = splitAlgTyConApp data_ty
303 tyvar_tys = mkTyVarTys tyvars
305 [data_id] = mkTemplateLocals [data_ty]
306 alts = map mk_maybe_alt data_cons
307 the_alts = catMaybes alts
308 default_alt | all isJust alts = [] -- No default needed
309 | otherwise = [(DEFAULT, [], error_expr)]
311 sel_rhs = mkLams tyvars $ Lam data_id $
312 Case (Var data_id) data_id (the_alts ++ default_alt)
314 mk_maybe_alt data_con
315 = case maybe_the_arg_id of
317 Just the_arg_id -> Just (DataCon data_con, arg_ids, Var the_arg_id)
319 arg_ids = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
320 -- The first one will shadow data_id, but who cares
321 field_lbls = dataConFieldLabels data_con
322 maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
324 error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy rhs_ty), mkStringLit full_msg]
325 -- preserves invariant that type args are *not* usage-annotated on top. KSW 1999-04.
326 full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
330 %************************************************************************
332 \subsection{Newtype field selectors}
334 %************************************************************************
336 Possibly overkill to do it this way:
339 mkNewTySelId field_label selector_ty = sel_id
341 sel_id = mkId (fieldLabelName field_label) selector_ty info
344 info = mkIdInfo (RecordSelId field_label)
345 `setArityInfo` exactArity 1
346 `setUnfoldingInfo` unfolding
348 -- ToDo: consider adding further IdInfo
350 unfolding = mkTopUnfolding sel_rhs
352 (tyvars, theta, tau) = splitSigmaTy selector_ty
353 (data_ty,rhs_ty) = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
354 -- tau is of form (T a b c -> field-type)
355 (tycon, _, data_cons) = splitAlgTyConApp data_ty
356 tyvar_tys = mkTyVarTys tyvars
358 [data_id] = mkTemplateLocals [data_ty]
359 sel_rhs = mkLams tyvars $ Lam data_id $
360 Note (Coerce (unUsgTy rhs_ty) (unUsgTy data_ty)) (Var data_id)
364 %************************************************************************
366 \subsection{Dictionary selectors}
368 %************************************************************************
370 Selecting a field for a dictionary. If there is just one field, then
371 there's nothing to do.
374 mkDictSelId name clas ty
377 sel_id = mkId name ty info
378 field_lbl = mkFieldLabel name ty tag
379 tag = assoc "MkId.mkDictSelId" (classSelIds clas `zip` allFieldLabelTags) sel_id
381 info = mkIdInfo (RecordSelId field_lbl)
382 `setUnfoldingInfo` unfolding
384 -- We no longer use 'must-inline' on record selectors. They'll
385 -- inline like crazy if they scrutinise a constructor
387 unfolding = mkTopUnfolding rhs
389 tyvars = classTyVars clas
391 tycon = classTyCon clas
392 [data_con] = tyConDataCons tycon
393 tyvar_tys = mkTyVarTys tyvars
394 arg_tys = dataConArgTys data_con tyvar_tys
395 the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
397 dict_ty = mkDictTy clas tyvar_tys
398 (dict_id:arg_ids) = mkTemplateLocals (dict_ty : arg_tys)
400 rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
401 Note (Coerce (head arg_tys) dict_ty) (Var dict_id)
402 | otherwise = mkLams tyvars $ Lam dict_id $
403 Case (Var dict_id) dict_id
404 [(DataCon data_con, arg_ids, Var the_arg_id)]
408 %************************************************************************
410 \subsection{Primitive operations
412 %************************************************************************
415 mkPrimitiveId :: PrimOp -> Id
416 mkPrimitiveId prim_op
419 (tyvars,arg_tys,res_ty) = primOpSig prim_op
420 ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
421 name = mkPrimOpIdName prim_op id
422 id = mkId name ty info
424 info = mkIdInfo (ConstantId (PrimOp prim_op))
425 `setUnfoldingInfo` unfolding
428 -- `setSpecInfo` rules
429 -- `setArityInfo` exactArity arity
430 -- `setStrictnessInfo` strict_info
432 arity = primOpArity prim_op
433 (dmds, result_bot) = primOpStrictness prim_op
434 strict_info = mkStrictnessInfo (take arity dmds, result_bot)
435 -- primOpStrictness can return an infinite list of demands
436 -- (cheap hack) but Ids mustn't have such things.
439 rules = addRule id emptyCoreRules (primOpRule prim_op)
441 unfolding = mkCompulsoryUnfolding rhs
442 -- The mkCompulsoryUnfolding says that this Id absolutely
443 -- must be inlined. It's only used for primitives,
444 -- because we don't want to make a closure for each of them.
446 args = mkTemplateLocals arg_tys
447 rhs = mkLams tyvars $ mkLams args $
448 mkPrimApp prim_op (map Type (mkTyVarTys tyvars) ++ map Var args)
452 %************************************************************************
454 \subsection{DictFuns}
456 %************************************************************************
459 mkDictFunId :: Name -- Name to use for the dict fun;
466 mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
467 = mkVanillaId dfun_name dfun_ty
469 (class_tyvars, sc_theta, _, _) = classBigSig clas
470 sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
472 dfun_theta = classesToPreds inst_decl_theta
474 {- 1 dec 99: disable the Mark Jones optimisation for the sake
475 of compatibility with Hugs.
476 See `types/InstEnv' for a discussion related to this.
478 dfun_theta = case inst_decl_theta of
479 [] -> [] -- If inst_decl_theta is empty, then we don't
480 -- want to have any dict arguments, so that we can
481 -- expose the constant methods.
483 other -> nub (inst_decl_theta ++ filter not_const sc_theta')
484 -- Otherwise we pass the superclass dictionaries to
485 -- the dictionary function; the Mark Jones optimisation.
487 -- NOTE the "nub". I got caught by this one:
488 -- class Monad m => MonadT t m where ...
489 -- instance Monad m => MonadT (EnvT env) m where ...
490 -- Here, the inst_decl_theta has (Monad m); but so
491 -- does the sc_theta'!
493 -- NOTE the "not_const". I got caught by this one too:
494 -- class Foo a => Baz a b where ...
495 -- instance Wob b => Baz T b where..
496 -- Now sc_theta' has Foo T
498 dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
500 not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
504 %************************************************************************
506 \subsection{Un-definable}
508 %************************************************************************
510 These two can't be defined in Haskell.
512 unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
513 just gets expanded into a type coercion wherever it occurs. Hence we
514 add it as a built-in Id with an unfolding here.
516 The type variables we use here are "open" type variables: this means
517 they can unify with both unlifted and lifted types. Hence we provide
518 another gun with which to shoot yourself in the foot.
522 = pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info
525 `setUnfoldingInfo` mkCompulsoryUnfolding rhs
528 ty = mkForAllTys [openAlphaTyVar,openBetaTyVar]
529 (mkFunTy openAlphaTy openBetaTy)
530 [x] = mkTemplateLocals [openAlphaTy]
531 rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
532 Note (Coerce openBetaTy openAlphaTy) (Var x)
536 @getTag#@ is another function which can't be defined in Haskell. It needs to
537 evaluate its argument and call the dataToTag# primitive.
541 = pcMiscPrelId getTagIdKey pREL_GHC SLIT("getTag#") ty info
544 `setUnfoldingInfo` mkCompulsoryUnfolding rhs
545 -- We don't provide a defn for this; you must inline it
547 ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy intPrimTy)
548 [x,y] = mkTemplateLocals [alphaTy,alphaTy]
549 rhs = mkLams [alphaTyVar,x] $
550 Case (Var x) y [ (DEFAULT, [],
551 Con (PrimOp DataToTagOp) [Type alphaTy, Var y]) ]
554 @realWorld#@ used to be a magic literal, \tr{void#}. If things get
555 nasty as-is, change it back to a literal (@Literal@).
558 realWorldPrimId -- :: State# RealWorld
559 = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#")
565 %************************************************************************
567 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
569 %************************************************************************
571 GHC randomly injects these into the code.
573 @patError@ is just a version of @error@ for pattern-matching
574 failures. It knows various ``codes'' which expand to longer
575 strings---this saves space!
577 @absentErr@ is a thing we put in for ``absent'' arguments. They jolly
578 well shouldn't be yanked on, but if one is, then you will get a
579 friendly message from @absentErr@ (rather than a totally random
582 @parError@ is a special version of @error@ which the compiler does
583 not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
584 templates, but we don't ever expect to generate code for it.
588 = pc_bottoming_Id errorIdKey pREL_ERR SLIT("error") errorTy
590 = generic_ERROR_ID recSelErrIdKey SLIT("patError")
592 = generic_ERROR_ID patErrorIdKey SLIT("patError")
594 = generic_ERROR_ID recConErrorIdKey SLIT("recConError")
596 = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError")
598 = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
599 nON_EXHAUSTIVE_GUARDS_ERROR_ID
600 = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError")
601 nO_METHOD_BINDING_ERROR_ID
602 = generic_ERROR_ID noMethodBindingErrorIdKey SLIT("noMethodBindingError")
605 = pc_bottoming_Id absentErrorIdKey pREL_ERR SLIT("absentErr")
606 (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
609 = pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError")
610 (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafIdInfo
615 %************************************************************************
617 \subsection{Utilities}
619 %************************************************************************
622 pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
623 pcMiscPrelId key mod str ty info
625 name = mkWiredInIdName key mod (mkSrcVarOcc str) imp
626 imp = mkId name ty info -- the usual case...
629 -- We lie and say the thing is imported; otherwise, we get into
630 -- a mess with dependency analysis; e.g., core2stg may heave in
631 -- random calls to GHCbase.unpackPS__. If GHCbase is the module
632 -- being compiled, then it's just a matter of luck if the definition
633 -- will be in "the right place" to be in scope.
635 pc_bottoming_Id key mod name ty
636 = pcMiscPrelId key mod name ty bottoming_info
638 bottoming_info = noCafIdInfo
639 `setStrictnessInfo` mkStrictnessInfo ([wwStrict], True)
641 -- these "bottom" out, no matter what their arguments
643 generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy
646 noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs
648 (openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars
649 openAlphaTy = mkTyVarTy openAlphaTyVar
650 openBetaTy = mkTyVarTy openBetaTyVar
653 errorTy = mkUsgTy UsMany $
654 mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkUsgTy UsOnce (mkListTy charTy)]
655 (mkUsgTy UsMany openAlphaTy))
656 -- Notice the openAlphaTyVar. It says that "error" can be applied
657 -- to unboxed as well as boxed types. This is OK because it never
658 -- returns, so the return type is irrelevant.