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 mkDictFunId, mkDefaultMethodId,
21 mkPrimOpId, mkFCallId,
23 mkReboxingAlt, mkNewTypeBody,
25 -- And some particular Ids; see below for why they are wired in
26 wiredInIds, ghcPrimIds,
27 unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId,
28 lazyId, lazyIdUnfolding, lazyIdKey,
31 rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
32 nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
33 pAT_ERROR_ID, eRROR_ID,
38 #include "HsVersions.h"
41 import BasicTypes ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
42 import Rules ( mkSpecInfo )
43 import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy,
44 realWorldStatePrimTy, addrPrimTy
46 import TysWiredIn ( charTy, mkListTy )
47 import PrelRules ( primOpRules )
48 import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes )
49 import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
50 mkTyConApp, mkTyVarTys, mkClassPred,
51 mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy,
52 isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
53 tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta
55 import CoreUtils ( exprType )
56 import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding )
57 import Literal ( nullAddrLit, mkStringLit )
58 import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
59 tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
60 import Class ( Class, classTyCon, classSelIds )
61 import Var ( Id, TyVar, Var )
62 import VarSet ( isEmptyVarSet, subVarSet, varSetElems )
63 import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) )
64 import OccName ( mkOccNameFS, varName )
65 import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag )
66 import ForeignCall ( ForeignCall )
67 import DataCon ( DataCon, DataConIds(..), dataConTyVars,
68 dataConFieldLabels, dataConRepArity, dataConResTys,
69 dataConRepArgTys, dataConRepType,
70 dataConSig, dataConStrictMarks, dataConExStricts,
71 splitProductType, isVanillaDataCon, dataConFieldType,
74 import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
75 mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
76 mkTemplateLocal, idName
78 import IdInfo ( IdInfo, noCafIdInfo, setUnfoldingInfo,
79 setArityInfo, setSpecInfo, setCafInfo,
80 setAllStrictnessInfo, vanillaIdInfo,
81 GlobalIdDetails(..), CafInfo(..)
83 import NewDemand ( mkStrictSig, DmdResult(..),
84 mkTopDmdType, topDmd, evalDmd, lazyDmd, retCPR,
85 Demand(..), Demands(..) )
86 import DmdAnal ( dmdAnalTopRhs )
88 import Unique ( mkBuiltinUnique, mkPrimOpIdUnique )
91 import Util ( dropList, isSingleton )
94 import ListSetOps ( assoc )
97 %************************************************************************
99 \subsection{Wired in Ids}
101 %************************************************************************
105 = [ -- These error-y things are wired in because we don't yet have
106 -- a way to express in an interface file that the result type variable
107 -- is 'open'; that is can be unified with an unboxed type
109 -- [The interface file format now carry such information, but there's
110 -- no way yet of expressing at the definition site for these
111 -- error-reporting functions that they have an 'open'
112 -- result type. -- sof 1/99]
114 eRROR_ID, -- This one isn't used anywhere else in the compiler
115 -- But we still need it in wiredInIds so that when GHC
116 -- compiles a program that mentions 'error' we don't
117 -- import its type from the interface file; we just get
118 -- the Id defined here. Which has an 'open-tyvar' type.
121 iRREFUT_PAT_ERROR_ID,
122 nON_EXHAUSTIVE_GUARDS_ERROR_ID,
123 nO_METHOD_BINDING_ERROR_ID,
130 -- These Ids are exported from GHC.Prim
132 = [ -- These can't be defined in Haskell, but they have
133 -- perfectly reasonable unfoldings in Core
141 %************************************************************************
143 \subsection{Data constructors}
145 %************************************************************************
147 The wrapper for a constructor is an ordinary top-level binding that evaluates
148 any strict args, unboxes any args that are going to be flattened, and calls
151 We're going to build a constructor that looks like:
153 data (Data a, C b) => T a b = T1 !a !Int b
156 \d1::Data a, d2::C b ->
157 \p q r -> case p of { p ->
159 Con T1 [a,b] [p,q,r]}}
163 * d2 is thrown away --- a context in a data decl is used to make sure
164 one *could* construct dictionaries at the site the constructor
165 is used, but the dictionary isn't actually used.
167 * We have to check that we can construct Data dictionaries for
168 the types a and Int. Once we've done that we can throw d1 away too.
170 * We use (case p of q -> ...) to evaluate p, rather than "seq" because
171 all that matters is that the arguments are evaluated. "seq" is
172 very careful to preserve evaluation order, which we don't need
175 You might think that we could simply give constructors some strictness
176 info, like PrimOps, and let CoreToStg do the let-to-case transformation.
177 But we don't do that because in the case of primops and functions strictness
178 is a *property* not a *requirement*. In the case of constructors we need to
179 do something active to evaluate the argument.
181 Making an explicit case expression allows the simplifier to eliminate
182 it in the (common) case where the constructor arg is already evaluated.
186 mkDataConIds :: Name -> Name -> DataCon -> DataConIds
187 -- Makes the *worker* for the data constructor; that is, the function
188 -- that takes the reprsentation arguments and builds the constructor.
189 mkDataConIds wrap_name wkr_name data_con
193 | any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper
194 = AlgDC (Just alg_wrap_id) wrk_id
196 | otherwise -- Algebraic, no wrapper
197 = AlgDC Nothing wrk_id
199 (tyvars, theta, orig_arg_tys, tycon, res_tys) = dataConSig data_con
201 dict_tys = mkPredTys theta
202 all_arg_tys = dict_tys ++ orig_arg_tys
203 result_ty = mkTyConApp tycon res_tys
205 wrap_ty = mkForAllTys tyvars (mkFunTys all_arg_tys result_ty)
206 -- We used to include the stupid theta in the wrapper's args
207 -- but now we don't. Instead the type checker just injects these
208 -- extra constraints where necessary.
210 ----------- Worker (algebraic data types only) --------------
211 wrk_id = mkGlobalId (DataConWorkId data_con) wkr_name
212 (dataConRepType data_con) wkr_info
214 wkr_arity = dataConRepArity data_con
215 wkr_info = noCafIdInfo
216 `setArityInfo` wkr_arity
217 `setAllStrictnessInfo` Just wkr_sig
218 `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
221 wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
222 -- Notice that we do *not* say the worker is strict
223 -- even if the data constructor is declared strict
224 -- e.g. data T = MkT !(Int,Int)
225 -- Why? Because the *wrapper* is strict (and its unfolding has case
226 -- expresssions that do the evals) but the *worker* itself is not.
227 -- If we pretend it is strict then when we see
228 -- case x of y -> $wMkT y
229 -- the simplifier thinks that y is "sure to be evaluated" (because
230 -- $wMkT is strict) and drops the case. No, $wMkT is not strict.
232 -- When the simplifer sees a pattern
233 -- case e of MkT x -> ...
234 -- it uses the dataConRepStrictness of MkT to mark x as evaluated;
235 -- but that's fine... dataConRepStrictness comes from the data con
236 -- not from the worker Id.
238 cpr_info | isProductTyCon tycon &&
241 wkr_arity <= mAX_CPR_SIZE = retCPR
243 -- RetCPR is only true for products that are real data types;
244 -- that is, not unboxed tuples or [non-recursive] newtypes
246 ----------- Wrappers for newtypes --------------
247 nt_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty nt_wrap_info
248 nt_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
249 `setArityInfo` 1 -- Arity 1
250 `setUnfoldingInfo` newtype_unf
251 newtype_unf = ASSERT( isVanillaDataCon data_con &&
252 isSingleton orig_arg_tys )
253 -- No existentials on a newtype, but it can have a context
254 -- e.g. newtype Eq a => T a = MkT (...)
255 mkCompulsoryUnfolding $
256 mkLams tyvars $ Lam id_arg1 $
257 mkNewTypeBody tycon result_ty (Var id_arg1)
259 id_arg1 = mkTemplateLocal 1 (head orig_arg_tys)
261 ----------- Wrappers for algebraic data types --------------
262 alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info
263 alg_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
264 `setArityInfo` alg_arity
265 -- It's important to specify the arity, so that partial
266 -- applications are treated as values
267 `setUnfoldingInfo` alg_unf
268 `setAllStrictnessInfo` Just wrap_sig
270 all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con
271 wrap_sig = mkStrictSig (mkTopDmdType arg_dmds cpr_info)
272 arg_dmds = map mk_dmd all_strict_marks
273 mk_dmd str | isMarkedStrict str = evalDmd
274 | otherwise = lazyDmd
275 -- The Cpr info can be important inside INLINE rhss, where the
276 -- wrapper constructor isn't inlined.
277 -- And the argument strictness can be important too; we
278 -- may not inline a contructor when it is partially applied.
280 -- data W = C !Int !Int !Int
281 -- ...(let w = C x in ...(w p q)...)...
282 -- we want to see that w is strict in its two arguments
284 alg_unf = mkTopUnfolding $ Note InlineMe $
286 mkLams dict_args $ mkLams id_args $
287 foldr mk_case con_app
288 (zip (dict_args ++ id_args) all_strict_marks)
291 con_app i rep_ids = mkApps (Var wrk_id)
292 (map varToCoreExpr (tyvars ++ reverse rep_ids))
294 (dict_args,i2) = mkLocals 1 dict_tys
295 (id_args,i3) = mkLocals i2 orig_arg_tys
299 :: (Id, StrictnessMark) -- Arg, strictness
300 -> (Int -> [Id] -> CoreExpr) -- Body
301 -> Int -- Next rep arg id
302 -> [Id] -- Rep args so far, reversed
304 mk_case (arg,strict) body i rep_args
306 NotMarkedStrict -> body i (arg:rep_args)
308 | isUnLiftedType (idType arg) -> body i (arg:rep_args)
310 Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))]
313 -> case splitProductType "do_unbox" (idType arg) of
314 (tycon, tycon_args, con, tys) ->
315 Case (Var arg) arg result_ty
318 body i' (reverse con_args ++ rep_args))]
320 (con_args, i') = mkLocals i tys
322 mAX_CPR_SIZE :: Arity
324 -- We do not treat very big tuples as CPR-ish:
325 -- a) for a start we get into trouble because there aren't
326 -- "enough" unboxed tuple types (a tiresome restriction,
328 -- b) more importantly, big unboxed tuples get returned mainly
329 -- on the stack, and are often then allocated in the heap
330 -- by the caller. So doing CPR for them may in fact make
333 mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
339 %************************************************************************
341 \subsection{Record selectors}
343 %************************************************************************
345 We're going to build a record selector unfolding that looks like this:
347 data T a b c = T1 { ..., op :: a, ...}
348 | T2 { ..., op :: a, ...}
351 sel = /\ a b c -> \ d -> case d of
356 Similarly for newtypes
358 newtype N a = MkN { unN :: a->a }
361 unN n = coerce (a->a) n
363 We need to take a little care if the field has a polymorphic type:
365 data R = R { f :: forall a. a->a }
369 f :: forall a. R -> a -> a
370 f = /\ a \ r = case r of
373 (not f :: R -> forall a. a->a, which gives the type inference mechanism
374 problems at call sites)
376 Similarly for (recursive) newtypes
378 newtype N = MkN { unN :: forall a. a->a }
380 unN :: forall b. N -> b -> b
381 unN = /\b -> \n:N -> (coerce (forall a. a->a) n)
384 Note [Naughty record selectors]
385 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
386 A "naughty" field is one for which we can't define a record
387 selector, because an existential type variable would escape. For example:
388 data T = forall a. MkT { x,y::a }
389 We obviously can't define
391 Nevertheless we *do* put a RecordSelId into the type environment
392 so that if the user tries to use 'x' as a selector we can bleat
393 helpfully, rather than saying unhelpfully that 'x' is not in scope.
394 Hence the sel_naughty flag, to identify record selcectors that don't really exist.
396 In general, a field is naughty if its type mentions a type variable that
397 isn't in the result type of the constructor.
399 For GADTs, we require that all constructors with a common field 'f' have the same
400 result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon]
403 T1 { f :: a } :: T [a]
404 T2 { f :: a, y :: b } :: T [a]
405 and now the selector takes that type as its argument:
406 f :: forall a. T [a] -> a
410 Note the forall'd tyvars of the selector are just the free tyvars
411 of the result type; there may be other tyvars in the constructor's
412 type (e.g. 'b' in T2).
416 -- Steps for handling "naughty" vs "non-naughty" selectors:
417 -- 1. Determine naughtiness by comparing field type vs result type
418 -- 2. Install naughty ones with selector_ty of type _|_ and fill in mzero for info
419 -- 3. If it's not naughty, do the normal plan.
421 mkRecordSelId :: TyCon -> FieldLabel -> Id
422 mkRecordSelId tycon field_label
423 -- Assumes that all fields with the same field label have the same type
424 | is_naughty = naughty_id
427 is_naughty = not (tyVarsOfType field_ty `subVarSet` tyvar_set)
428 sel_id_details = RecordSelId tycon field_label is_naughty
430 -- Escapist case here for naughty construcotrs
431 -- We give it no IdInfo, and a type of forall a.a (never looked at)
432 naughty_id = mkGlobalId sel_id_details field_label forall_a_a noCafIdInfo
433 forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
435 -- Normal case starts here
436 sel_id = mkGlobalId sel_id_details field_label selector_ty info
437 data_cons = tyConDataCons tycon
438 data_cons_w_field = filter has_field data_cons -- Can't be empty!
439 has_field con = field_label `elem` dataConFieldLabels con
441 con1 = head data_cons_w_field
442 res_tys = dataConResTys con1
443 tyvar_set = tyVarsOfTypes res_tys
444 tyvars = varSetElems tyvar_set
445 data_ty = mkTyConApp tycon res_tys
446 field_ty = dataConFieldType con1 field_label
448 -- *Very* tiresomely, the selectors are (unnecessarily!) overloaded over
449 -- just the dictionaries in the types of the constructors that contain
450 -- the relevant field. [The Report says that pattern matching on a
451 -- constructor gives the same constraints as applying it.] Urgh.
453 -- However, not all data cons have all constraints (because of
454 -- BuildTyCl.mkDataConStupidTheta). So we need to find all the data cons
455 -- involved in the pattern match and take the union of their constraints.
456 stupid_dict_tys = mkPredTys (dataConsStupidTheta data_cons_w_field)
457 n_stupid_dicts = length stupid_dict_tys
459 (field_tyvars,field_theta,field_tau) = tcSplitSigmaTy field_ty
460 field_dict_tys = mkPredTys field_theta
461 n_field_dict_tys = length field_dict_tys
462 -- If the field has a universally quantified type we have to
463 -- be a bit careful. Suppose we have
464 -- data R = R { op :: forall a. Foo a => a -> a }
465 -- Then we can't give op the type
466 -- op :: R -> forall a. Foo a => a -> a
467 -- because the typechecker doesn't understand foralls to the
468 -- right of an arrow. The "right" type to give it is
469 -- op :: forall a. Foo a => R -> a -> a
470 -- But then we must generate the right unfolding too:
471 -- op = /\a -> \dfoo -> \ r ->
474 -- Note that this is exactly the type we'd infer from a user defn
478 selector_ty = mkForAllTys tyvars $ mkForAllTys field_tyvars $
479 mkFunTys stupid_dict_tys $ mkFunTys field_dict_tys $
480 mkFunTy data_ty field_tau
482 arity = 1 + n_stupid_dicts + n_field_dict_tys
484 (strict_sig, rhs_w_str) = dmdAnalTopRhs sel_rhs
485 -- Use the demand analyser to work out strictness.
486 -- With all this unpackery it's not easy!
489 `setCafInfo` caf_info
491 `setUnfoldingInfo` mkTopUnfolding rhs_w_str
492 `setAllStrictnessInfo` Just strict_sig
494 -- Allocate Ids. We do it a funny way round because field_dict_tys is
495 -- almost always empty. Also note that we use max_dict_tys
496 -- rather than n_dict_tys, because the latter gives an infinite loop:
497 -- n_dict tys depends on the_alts, which depens on arg_ids, which depends
498 -- on arity, which depends on n_dict tys. Sigh! Mega sigh!
499 stupid_dict_ids = mkTemplateLocalsNum 1 stupid_dict_tys
500 max_stupid_dicts = length (tyConStupidTheta tycon)
501 field_dict_base = max_stupid_dicts + 1
502 field_dict_ids = mkTemplateLocalsNum field_dict_base field_dict_tys
503 dict_id_base = field_dict_base + n_field_dict_tys
504 data_id = mkTemplateLocal dict_id_base data_ty
505 arg_base = dict_id_base + 1
507 the_alts :: [CoreAlt]
508 the_alts = map mk_alt data_cons_w_field -- Already sorted by data-con
509 no_default = length data_cons == length data_cons_w_field -- No default needed
511 default_alt | no_default = []
512 | otherwise = [(DEFAULT, [], error_expr)]
514 -- The default branch may have CAF refs, because it calls recSelError etc.
515 caf_info | no_default = NoCafRefs
516 | otherwise = MayHaveCafRefs
518 sel_rhs = mkLams tyvars $ mkLams field_tyvars $
519 mkLams stupid_dict_ids $ mkLams field_dict_ids $
520 Lam data_id $ sel_body
522 sel_body | isNewTyCon tycon = mk_result (mkNewTypeBody tycon field_ty (Var data_id))
523 | otherwise = Case (Var data_id) data_id field_tau (default_alt ++ the_alts)
525 mk_result poly_result = mkVarApps (mkVarApps poly_result field_tyvars) field_dict_ids
526 -- We pull the field lambdas to the top, so we need to
527 -- apply them in the body. For example:
528 -- data T = MkT { foo :: forall a. a->a }
530 -- foo :: forall a. T -> a -> a
531 -- foo = /\a. \t:T. case t of { MkT f -> f a }
534 = -- In the non-vanilla case, the pattern must bind type variables and
535 -- the context stuff; hence the arg_prefix binding below
536 mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids)
537 (mk_result (Var the_arg_id))
539 (arg_prefix, arg_ids)
540 | isVanillaDataCon data_con -- Instantiate from commmon base
541 = ([], mkTemplateLocalsNum arg_base (dataConInstOrigArgTys data_con res_tys))
542 | otherwise -- The case pattern binds type variables, which are used
543 -- in the types of the arguments of the pattern
544 = (dc_tyvars ++ mkTemplateLocalsNum arg_base (mkPredTys dc_theta),
545 mkTemplateLocalsNum arg_base' dc_arg_tys)
547 (dc_tyvars, dc_theta, dc_arg_tys, _, _) = dataConSig data_con
548 arg_base' = arg_base + length dc_theta
550 unpack_base = arg_base' + length dc_arg_tys
551 uniqs = map mkBuiltinUnique [unpack_base..]
553 the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` arg_ids) field_label
554 field_lbls = dataConFieldLabels data_con
556 error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg
557 full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
560 -- (mkReboxingAlt us con xs rhs) basically constructs the case
561 -- alternative (con, xs, rhs)
562 -- but it does the reboxing necessary to construct the *source*
563 -- arguments, xs, from the representation arguments ys.
565 -- data T = MkT !(Int,Int) Bool
567 -- mkReboxingAlt MkT [x,b] r
568 -- = (DataAlt MkT, [y::Int,z::Int,b], let x = (y,z) in r)
570 -- mkDataAlt should really be in DataCon, but it can't because
571 -- it manipulates CoreSyn.
574 :: [Unique] -- Uniques for the new Ids
576 -> [Var] -- Source-level args, including existential dicts
580 mkReboxingAlt us con args rhs
581 | not (any isMarkedUnboxed stricts)
582 = (DataAlt con, args, rhs)
586 (binds, args') = go args stricts us
588 (DataAlt con, args', mkLets binds rhs)
591 stricts = dataConExStricts con ++ dataConStrictMarks con
593 go [] stricts us = ([], [])
595 -- Type variable case
596 go (arg:args) stricts us
598 = let (binds, args') = go args stricts us
599 in (binds, arg:args')
601 -- Term variable case
602 go (arg:args) (str:stricts) us
603 | isMarkedUnboxed str
605 (_, tycon_args, pack_con, con_arg_tys)
606 = splitProductType "mkReboxingAlt" (idType arg)
608 unpacked_args = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
609 (binds, args') = go args stricts (dropList con_arg_tys us)
610 con_app = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
612 (NonRec arg con_app : binds, unpacked_args ++ args')
615 = let (binds, args') = go args stricts us
616 in (binds, arg:args')
620 %************************************************************************
622 \subsection{Dictionary selectors}
624 %************************************************************************
626 Selecting a field for a dictionary. If there is just one field, then
627 there's nothing to do.
629 Dictionary selectors may get nested forall-types. Thus:
632 op :: forall b. Ord b => a -> b -> b
634 Then the top-level type for op is
636 op :: forall a. Foo a =>
640 This is unlike ordinary record selectors, which have all the for-alls
641 at the outside. When dealing with classes it's very convenient to
642 recover the original type signature from the class op selector.
645 mkDictSelId :: Name -> Class -> Id
646 mkDictSelId name clas
647 = mkGlobalId (ClassOpId clas) name sel_ty info
649 sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id))
650 -- We can't just say (exprType rhs), because that would give a type
652 -- for a single-op class (after all, the selector is the identity)
653 -- But it's type must expose the representation of the dictionary
654 -- to gat (say) C a -> (a -> a)
658 `setUnfoldingInfo` mkTopUnfolding rhs
659 `setAllStrictnessInfo` Just strict_sig
661 -- We no longer use 'must-inline' on record selectors. They'll
662 -- inline like crazy if they scrutinise a constructor
664 -- The strictness signature is of the form U(AAAVAAAA) -> T
665 -- where the V depends on which item we are selecting
666 -- It's worth giving one, so that absence info etc is generated
667 -- even if the selector isn't inlined
668 strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes)
669 arg_dmd | isNewTyCon tycon = evalDmd
670 | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
673 tycon = classTyCon clas
674 [data_con] = tyConDataCons tycon
675 tyvars = dataConTyVars data_con
676 arg_tys = dataConRepArgTys data_con
677 the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name
679 pred = mkClassPred clas (mkTyVarTys tyvars)
680 (dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys)
682 rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
683 mkNewTypeBody tycon (head arg_tys) (Var dict_id)
684 | otherwise = mkLams tyvars $ Lam dict_id $
685 Case (Var dict_id) dict_id (idType the_arg_id)
686 [(DataAlt data_con, arg_ids, Var the_arg_id)]
688 mkNewTypeBody tycon result_ty result_expr
689 -- Adds a coerce where necessary
690 -- Used for both wrapping and unwrapping
691 | isRecursiveTyCon tycon -- Recursive case; use a coerce
692 = Note (Coerce result_ty (exprType result_expr)) result_expr
693 | otherwise -- Normal case
698 %************************************************************************
700 \subsection{Primitive operations
702 %************************************************************************
705 mkPrimOpId :: PrimOp -> Id
709 (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op
710 ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
711 name = mkWiredInName gHC_PRIM (primOpOcc prim_op)
712 (mkPrimOpIdUnique (primOpTag prim_op))
713 Nothing (AnId id) UserSyntax
714 id = mkGlobalId (PrimOpId prim_op) name ty info
717 `setSpecInfo` mkSpecInfo (primOpRules prim_op name)
719 `setAllStrictnessInfo` Just strict_sig
721 -- For each ccall we manufacture a separate CCallOpId, giving it
722 -- a fresh unique, a type that is correct for this particular ccall,
723 -- and a CCall structure that gives the correct details about calling
726 -- The *name* of this Id is a local name whose OccName gives the full
727 -- details of the ccall, type and all. This means that the interface
728 -- file reader can reconstruct a suitable Id
730 mkFCallId :: Unique -> ForeignCall -> Type -> Id
731 mkFCallId uniq fcall ty
732 = ASSERT( isEmptyVarSet (tyVarsOfType ty) )
733 -- A CCallOpId should have no free type variables;
734 -- when doing substitutions won't substitute over it
735 mkGlobalId (FCallId fcall) name ty info
737 occ_str = showSDoc (braces (ppr fcall <+> ppr ty))
738 -- The "occurrence name" of a ccall is the full info about the
739 -- ccall; it is encoded, but may have embedded spaces etc!
741 name = mkFCallName uniq occ_str
745 `setAllStrictnessInfo` Just strict_sig
747 (_, tau) = tcSplitForAllTys ty
748 (arg_tys, _) = tcSplitFunTys tau
749 arity = length arg_tys
750 strict_sig = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
754 %************************************************************************
756 \subsection{DictFuns and default methods}
758 %************************************************************************
760 Important notes about dict funs and default methods
761 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
762 Dict funs and default methods are *not* ImplicitIds. Their definition
763 involves user-written code, so we can't figure out their strictness etc
764 based on fixed info, as we can for constructors and record selectors (say).
766 We build them as LocalIds, but with External Names. This ensures that
767 they are taken to account by free-variable finding and dependency
768 analysis (e.g. CoreFVs.exprFreeVars).
770 Why shouldn't they be bound as GlobalIds? Because, in particular, if
771 they are globals, the specialiser floats dict uses above their defns,
772 which prevents good simplifications happening. Also the strictness
773 analyser treats a occurrence of a GlobalId as imported and assumes it
774 contains strictness in its IdInfo, which isn't true if the thing is
775 bound in the same module as the occurrence.
777 It's OK for dfuns to be LocalIds, because we form the instance-env to
778 pass on to the next module (md_insts) in CoreTidy, afer tidying
779 and globalising the top-level Ids.
781 BUT make sure they are *exported* LocalIds (mkExportedLocalId) so
782 that they aren't discarded by the occurrence analyser.
785 mkDefaultMethodId dm_name ty = mkExportedLocalId dm_name ty
787 mkDictFunId :: Name -- Name to use for the dict fun;
794 mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys
795 = mkExportedLocalId dfun_name dfun_ty
797 dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
799 {- 1 dec 99: disable the Mark Jones optimisation for the sake
800 of compatibility with Hugs.
801 See `types/InstEnv' for a discussion related to this.
803 (class_tyvars, sc_theta, _, _) = classBigSig clas
804 not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
805 sc_theta' = substClasses (zipTopTvSubst class_tyvars inst_tys) sc_theta
806 dfun_theta = case inst_decl_theta of
807 [] -> [] -- If inst_decl_theta is empty, then we don't
808 -- want to have any dict arguments, so that we can
809 -- expose the constant methods.
811 other -> nub (inst_decl_theta ++ filter not_const sc_theta')
812 -- Otherwise we pass the superclass dictionaries to
813 -- the dictionary function; the Mark Jones optimisation.
815 -- NOTE the "nub". I got caught by this one:
816 -- class Monad m => MonadT t m where ...
817 -- instance Monad m => MonadT (EnvT env) m where ...
818 -- Here, the inst_decl_theta has (Monad m); but so
819 -- does the sc_theta'!
821 -- NOTE the "not_const". I got caught by this one too:
822 -- class Foo a => Baz a b where ...
823 -- instance Wob b => Baz T b where..
824 -- Now sc_theta' has Foo T
829 %************************************************************************
831 \subsection{Un-definable}
833 %************************************************************************
835 These Ids can't be defined in Haskell. They could be defined in
836 unfoldings in the wired-in GHC.Prim interface file, but we'd have to
837 ensure that they were definitely, definitely inlined, because there is
838 no curried identifier for them. That's what mkCompulsoryUnfolding
839 does. If we had a way to get a compulsory unfolding from an interface
840 file, we could do that, but we don't right now.
842 unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
843 just gets expanded into a type coercion wherever it occurs. Hence we
844 add it as a built-in Id with an unfolding here.
846 The type variables we use here are "open" type variables: this means
847 they can unify with both unlifted and lifted types. Hence we provide
848 another gun with which to shoot yourself in the foot.
851 mkWiredInIdName mod fs uniq id
852 = mkWiredInName mod (mkOccNameFS varName fs) uniq Nothing (AnId id) UserSyntax
854 unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId
855 nullAddrName = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#") nullAddrIdKey nullAddrId
856 seqName = mkWiredInIdName gHC_PRIM FSLIT("seq") seqIdKey seqId
857 realWorldName = mkWiredInIdName gHC_PRIM FSLIT("realWorld#") realWorldPrimIdKey realWorldPrimId
858 lazyIdName = mkWiredInIdName gHC_BASE FSLIT("lazy") lazyIdKey lazyId
860 errorName = mkWiredInIdName gHC_ERR FSLIT("error") errorIdKey eRROR_ID
861 recSelErrorName = mkWiredInIdName gHC_ERR FSLIT("recSelError") recSelErrorIdKey rEC_SEL_ERROR_ID
862 runtimeErrorName = mkWiredInIdName gHC_ERR FSLIT("runtimeError") runtimeErrorIdKey rUNTIME_ERROR_ID
863 irrefutPatErrorName = mkWiredInIdName gHC_ERR FSLIT("irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
864 recConErrorName = mkWiredInIdName gHC_ERR FSLIT("recConError") recConErrorIdKey rEC_CON_ERROR_ID
865 patErrorName = mkWiredInIdName gHC_ERR FSLIT("patError") patErrorIdKey pAT_ERROR_ID
866 noMethodBindingErrorName = mkWiredInIdName gHC_ERR FSLIT("noMethodBindingError")
867 noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
868 nonExhaustiveGuardsErrorName
869 = mkWiredInIdName gHC_ERR FSLIT("nonExhaustiveGuardsError")
870 nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
874 -- unsafeCoerce# :: forall a b. a -> b
876 = pcMiscPrelId unsafeCoerceName ty info
878 info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
881 ty = mkForAllTys [openAlphaTyVar,openBetaTyVar]
882 (mkFunTy openAlphaTy openBetaTy)
883 [x] = mkTemplateLocals [openAlphaTy]
884 rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
885 Note (Coerce openBetaTy openAlphaTy) (Var x)
887 -- nullAddr# :: Addr#
888 -- The reason is is here is because we don't provide
889 -- a way to write this literal in Haskell.
891 = pcMiscPrelId nullAddrName addrPrimTy info
893 info = noCafIdInfo `setUnfoldingInfo`
894 mkCompulsoryUnfolding (Lit nullAddrLit)
897 = pcMiscPrelId seqName ty info
899 info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
902 ty = mkForAllTys [alphaTyVar,openBetaTyVar]
903 (mkFunTy alphaTy (mkFunTy openBetaTy openBetaTy))
904 [x,y] = mkTemplateLocals [alphaTy, openBetaTy]
905 rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x openBetaTy [(DEFAULT, [], Var y)])
907 -- lazy :: forall a?. a? -> a? (i.e. works for unboxed types too)
908 -- Used to lazify pseq: pseq a b = a `seq` lazy b
910 -- Also, no strictness: by being a built-in Id, all the info about lazyId comes from here,
911 -- not from GHC.Base.hi. This is important, because the strictness
912 -- analyser will spot it as strict!
914 -- Also no unfolding in lazyId: it gets "inlined" by a HACK in the worker/wrapper pass
915 -- (see WorkWrap.wwExpr)
916 -- We could use inline phases to do this, but that would be vulnerable to changes in
917 -- phase numbering....we must inline precisely after strictness analysis.
919 = pcMiscPrelId lazyIdName ty info
922 ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
924 lazyIdUnfolding :: CoreExpr -- Used to expand 'lazyId' after strictness anal
925 lazyIdUnfolding = mkLams [openAlphaTyVar,x] (Var x)
927 [x] = mkTemplateLocals [openAlphaTy]
930 @realWorld#@ used to be a magic literal, \tr{void#}. If things get
931 nasty as-is, change it back to a literal (@Literal@).
933 voidArgId is a Local Id used simply as an argument in functions
934 where we just want an arg to avoid having a thunk of unlifted type.
936 x = \ void :: State# RealWorld -> (# p, q #)
938 This comes up in strictness analysis
941 realWorldPrimId -- :: State# RealWorld
942 = pcMiscPrelId realWorldName realWorldStatePrimTy
943 (noCafIdInfo `setUnfoldingInfo` evaldUnfolding)
944 -- The evaldUnfolding makes it look that realWorld# is evaluated
945 -- which in turn makes Simplify.interestingArg return True,
946 -- which in turn makes INLINE things applied to realWorld# likely
949 voidArgId -- :: State# RealWorld
950 = mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy
954 %************************************************************************
956 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
958 %************************************************************************
960 GHC randomly injects these into the code.
962 @patError@ is just a version of @error@ for pattern-matching
963 failures. It knows various ``codes'' which expand to longer
964 strings---this saves space!
966 @absentErr@ is a thing we put in for ``absent'' arguments. They jolly
967 well shouldn't be yanked on, but if one is, then you will get a
968 friendly message from @absentErr@ (rather than a totally random
971 @parError@ is a special version of @error@ which the compiler does
972 not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
973 templates, but we don't ever expect to generate code for it.
977 :: Id -- Should be of type (forall a. Addr# -> a)
978 -- where Addr# points to a UTF8 encoded string
979 -> Type -- The type to instantiate 'a'
980 -> String -- The string to print
983 mkRuntimeErrorApp err_id res_ty err_msg
984 = mkApps (Var err_id) [Type res_ty, err_string]
986 err_string = Lit (mkStringLit err_msg)
988 rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName
989 rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName
990 iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName
991 rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName
992 pAT_ERROR_ID = mkRuntimeErrorId patErrorName
993 nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName
994 nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
996 -- The runtime error Ids take a UTF8-encoded string as argument
997 mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
998 runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
1002 eRROR_ID = pc_bottoming_Id errorName errorTy
1005 errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
1006 -- Notice the openAlphaTyVar. It says that "error" can be applied
1007 -- to unboxed as well as boxed types. This is OK because it never
1008 -- returns, so the return type is irrelevant.
1012 %************************************************************************
1014 \subsection{Utilities}
1016 %************************************************************************
1019 pcMiscPrelId :: Name -> Type -> IdInfo -> Id
1020 pcMiscPrelId name ty info
1021 = mkVanillaGlobal name ty info
1022 -- We lie and say the thing is imported; otherwise, we get into
1023 -- a mess with dependency analysis; e.g., core2stg may heave in
1024 -- random calls to GHCbase.unpackPS__. If GHCbase is the module
1025 -- being compiled, then it's just a matter of luck if the definition
1026 -- will be in "the right place" to be in scope.
1028 pc_bottoming_Id name ty
1029 = pcMiscPrelId name ty bottoming_info
1031 bottoming_info = vanillaIdInfo `setAllStrictnessInfo` Just strict_sig
1032 -- Do *not* mark them as NoCafRefs, because they can indeed have
1033 -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle,
1034 -- which has some CAFs
1035 -- In due course we may arrange that these error-y things are
1036 -- regarded by the GC as permanently live, in which case we
1037 -- can give them NoCaf info. As it is, any function that calls
1038 -- any pc_bottoming_Id will itself have CafRefs, which bloats
1041 strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
1042 -- These "bottom" out, no matter what their arguments
1044 (openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars
1045 openAlphaTy = mkTyVarTy openAlphaTyVar
1046 openBetaTy = mkTyVarTy openBetaTyVar