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, wrapNewTypeBody, unwrapNewTypeBody,
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 Coercion ( mkSymCoercion, mkUnsafeCoercion )
50 import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
51 mkTyConApp, mkTyVarTys, mkClassPred,
52 mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy,
53 isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
54 tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta
56 import CoreUtils ( exprType )
57 import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding )
58 import Literal ( nullAddrLit, mkStringLit )
59 import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
60 tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon,
61 newTyConCo, tyConArity )
62 import Class ( Class, classTyCon, classSelIds )
63 import Var ( Id, TyVar, Var )
64 import VarSet ( isEmptyVarSet, subVarSet, varSetElems )
65 import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) )
66 import OccName ( mkOccNameFS, varName )
67 import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag )
68 import ForeignCall ( ForeignCall )
69 import DataCon ( DataCon, DataConIds(..), dataConTyCon, dataConUnivTyVars,
70 dataConFieldLabels, dataConRepArity, dataConResTys,
71 dataConRepArgTys, dataConRepType,
72 dataConSig, dataConStrictMarks, dataConExStricts,
73 splitProductType, isVanillaDataCon, dataConFieldType,
76 import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
77 mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
78 mkTemplateLocal, idName
80 import IdInfo ( IdInfo, noCafIdInfo, setUnfoldingInfo,
81 setArityInfo, setSpecInfo, setCafInfo,
82 setAllStrictnessInfo, vanillaIdInfo,
83 GlobalIdDetails(..), CafInfo(..)
85 import NewDemand ( mkStrictSig, DmdResult(..),
86 mkTopDmdType, topDmd, evalDmd, lazyDmd, retCPR,
87 Demand(..), Demands(..) )
88 import DmdAnal ( dmdAnalTopRhs )
90 import Unique ( mkBuiltinUnique, mkPrimOpIdUnique )
93 import Util ( dropList, isSingleton )
96 import ListSetOps ( assoc )
99 %************************************************************************
101 \subsection{Wired in Ids}
103 %************************************************************************
107 = [ -- These error-y things are wired in because we don't yet have
108 -- a way to express in an interface file that the result type variable
109 -- is 'open'; that is can be unified with an unboxed type
111 -- [The interface file format now carry such information, but there's
112 -- no way yet of expressing at the definition site for these
113 -- error-reporting functions that they have an 'open'
114 -- result type. -- sof 1/99]
116 eRROR_ID, -- This one isn't used anywhere else in the compiler
117 -- But we still need it in wiredInIds so that when GHC
118 -- compiles a program that mentions 'error' we don't
119 -- import its type from the interface file; we just get
120 -- the Id defined here. Which has an 'open-tyvar' type.
123 iRREFUT_PAT_ERROR_ID,
124 nON_EXHAUSTIVE_GUARDS_ERROR_ID,
125 nO_METHOD_BINDING_ERROR_ID,
132 -- These Ids are exported from GHC.Prim
134 = [ -- These can't be defined in Haskell, but they have
135 -- perfectly reasonable unfoldings in Core
143 %************************************************************************
145 \subsection{Data constructors}
147 %************************************************************************
149 The wrapper for a constructor is an ordinary top-level binding that evaluates
150 any strict args, unboxes any args that are going to be flattened, and calls
153 We're going to build a constructor that looks like:
155 data (Data a, C b) => T a b = T1 !a !Int b
158 \d1::Data a, d2::C b ->
159 \p q r -> case p of { p ->
161 Con T1 [a,b] [p,q,r]}}
165 * d2 is thrown away --- a context in a data decl is used to make sure
166 one *could* construct dictionaries at the site the constructor
167 is used, but the dictionary isn't actually used.
169 * We have to check that we can construct Data dictionaries for
170 the types a and Int. Once we've done that we can throw d1 away too.
172 * We use (case p of q -> ...) to evaluate p, rather than "seq" because
173 all that matters is that the arguments are evaluated. "seq" is
174 very careful to preserve evaluation order, which we don't need
177 You might think that we could simply give constructors some strictness
178 info, like PrimOps, and let CoreToStg do the let-to-case transformation.
179 But we don't do that because in the case of primops and functions strictness
180 is a *property* not a *requirement*. In the case of constructors we need to
181 do something active to evaluate the argument.
183 Making an explicit case expression allows the simplifier to eliminate
184 it in the (common) case where the constructor arg is already evaluated.
188 mkDataConIds :: Name -> Name -> DataCon -> DataConIds
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 (tvs, theta, orig_arg_tys) = dataConSig data_con
200 tycon = dataConTyCon data_con
202 dict_tys = mkPredTys theta
203 all_arg_tys = dict_tys ++ orig_arg_tys
204 tycon_args = dataConUnivTyVars data_con
205 result_ty_args = (mkTyVarTys tycon_args)
206 result_ty = mkTyConApp tycon result_ty_args
208 wrap_ty = mkForAllTys tvs (mkFunTys all_arg_tys result_ty)
209 -- We used to include the stupid theta in the wrapper's args
210 -- but now we don't. Instead the type checker just injects these
211 -- extra constraints where necessary.
213 ----------- Worker (algebraic data types only) --------------
214 -- The *worker* for the data constructor is the function that
215 -- takes the representation arguments and builds the constructor.
216 wrk_id = mkGlobalId (DataConWorkId data_con) wkr_name
217 (dataConRepType data_con) wkr_info
219 wkr_arity = dataConRepArity data_con
220 wkr_info = noCafIdInfo
221 `setArityInfo` wkr_arity
222 `setAllStrictnessInfo` Just wkr_sig
223 `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
226 wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
227 -- Notice that we do *not* say the worker is strict
228 -- even if the data constructor is declared strict
229 -- e.g. data T = MkT !(Int,Int)
230 -- Why? Because the *wrapper* is strict (and its unfolding has case
231 -- expresssions that do the evals) but the *worker* itself is not.
232 -- If we pretend it is strict then when we see
233 -- case x of y -> $wMkT y
234 -- the simplifier thinks that y is "sure to be evaluated" (because
235 -- $wMkT is strict) and drops the case. No, $wMkT is not strict.
237 -- When the simplifer sees a pattern
238 -- case e of MkT x -> ...
239 -- it uses the dataConRepStrictness of MkT to mark x as evaluated;
240 -- but that's fine... dataConRepStrictness comes from the data con
241 -- not from the worker Id.
243 cpr_info | isProductTyCon tycon &&
246 wkr_arity <= mAX_CPR_SIZE = retCPR
248 -- RetCPR is only true for products that are real data types;
249 -- that is, not unboxed tuples or [non-recursive] newtypes
251 ----------- Wrappers for newtypes --------------
252 nt_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty nt_wrap_info
253 nt_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
254 `setArityInfo` 1 -- Arity 1
255 `setUnfoldingInfo` newtype_unf
256 newtype_unf = ASSERT( isVanillaDataCon data_con &&
257 isSingleton orig_arg_tys )
258 -- No existentials on a newtype, but it can have a context
259 -- e.g. newtype Eq a => T a = MkT (...)
260 mkCompulsoryUnfolding $
261 mkLams tvs $ Lam id_arg1 $
262 wrapNewTypeBody tycon result_ty_args
265 id_arg1 = mkTemplateLocal 1 (head orig_arg_tys)
267 ----------- Wrappers for algebraic data types --------------
268 alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info
269 alg_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
270 `setArityInfo` alg_arity
271 -- It's important to specify the arity, so that partial
272 -- applications are treated as values
273 `setUnfoldingInfo` alg_unf
274 `setAllStrictnessInfo` Just wrap_sig
276 all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con
277 wrap_sig = mkStrictSig (mkTopDmdType arg_dmds cpr_info)
278 arg_dmds = map mk_dmd all_strict_marks
279 mk_dmd str | isMarkedStrict str = evalDmd
280 | otherwise = lazyDmd
281 -- The Cpr info can be important inside INLINE rhss, where the
282 -- wrapper constructor isn't inlined.
283 -- And the argument strictness can be important too; we
284 -- may not inline a contructor when it is partially applied.
286 -- data W = C !Int !Int !Int
287 -- ...(let w = C x in ...(w p q)...)...
288 -- we want to see that w is strict in its two arguments
290 alg_unf = mkTopUnfolding $ Note InlineMe $
292 mkLams dict_args $ mkLams id_args $
293 foldr mk_case con_app
294 (zip (dict_args ++ id_args) all_strict_marks)
297 con_app i rep_ids = mkApps (Var wrk_id)
298 (map varToCoreExpr (tvs ++ reverse rep_ids))
300 (dict_args,i2) = mkLocals 1 dict_tys
301 (id_args,i3) = mkLocals i2 orig_arg_tys
305 :: (Id, StrictnessMark) -- Arg, strictness
306 -> (Int -> [Id] -> CoreExpr) -- Body
307 -> Int -- Next rep arg id
308 -> [Id] -- Rep args so far, reversed
310 mk_case (arg,strict) body i rep_args
312 NotMarkedStrict -> body i (arg:rep_args)
314 | isUnLiftedType (idType arg) -> body i (arg:rep_args)
316 Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))]
319 -> case splitProductType "do_unbox" (idType arg) of
320 (tycon, tycon_args, con, tys) ->
321 Case (Var arg) arg result_ty
324 body i' (reverse con_args ++ rep_args))]
326 (con_args, i') = mkLocals i tys
328 mAX_CPR_SIZE :: Arity
330 -- We do not treat very big tuples as CPR-ish:
331 -- a) for a start we get into trouble because there aren't
332 -- "enough" unboxed tuple types (a tiresome restriction,
334 -- b) more importantly, big unboxed tuples get returned mainly
335 -- on the stack, and are often then allocated in the heap
336 -- by the caller. So doing CPR for them may in fact make
339 mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
345 %************************************************************************
347 \subsection{Record selectors}
349 %************************************************************************
351 We're going to build a record selector unfolding that looks like this:
353 data T a b c = T1 { ..., op :: a, ...}
354 | T2 { ..., op :: a, ...}
357 sel = /\ a b c -> \ d -> case d of
362 Similarly for newtypes
364 newtype N a = MkN { unN :: a->a }
367 unN n = coerce (a->a) n
369 We need to take a little care if the field has a polymorphic type:
371 data R = R { f :: forall a. a->a }
375 f :: forall a. R -> a -> a
376 f = /\ a \ r = case r of
379 (not f :: R -> forall a. a->a, which gives the type inference mechanism
380 problems at call sites)
382 Similarly for (recursive) newtypes
384 newtype N = MkN { unN :: forall a. a->a }
386 unN :: forall b. N -> b -> b
387 unN = /\b -> \n:N -> (coerce (forall a. a->a) n)
390 Note [Naughty record selectors]
391 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
392 A "naughty" field is one for which we can't define a record
393 selector, because an existential type variable would escape. For example:
394 data T = forall a. MkT { x,y::a }
395 We obviously can't define
397 Nevertheless we *do* put a RecordSelId into the type environment
398 so that if the user tries to use 'x' as a selector we can bleat
399 helpfully, rather than saying unhelpfully that 'x' is not in scope.
400 Hence the sel_naughty flag, to identify record selectors that don't really exist.
402 In general, a field is naughty if its type mentions a type variable that
403 isn't in the result type of the constructor.
405 Note [GADT record selectors]
406 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
407 For GADTs, we require that all constructors with a common field 'f' have the same
408 result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon]
411 T1 { f :: a } :: T [a]
412 T2 { f :: a, y :: b } :: T [a]
413 and now the selector takes that type as its argument:
414 f :: forall a. T [a] -> a
418 Note the forall'd tyvars of the selector are just the free tyvars
419 of the result type; there may be other tyvars in the constructor's
420 type (e.g. 'b' in T2).
424 -- Steps for handling "naughty" vs "non-naughty" selectors:
425 -- 1. Determine naughtiness by comparing field type vs result type
426 -- 2. Install naughty ones with selector_ty of type _|_ and fill in mzero for info
427 -- 3. If it's not naughty, do the normal plan.
429 mkRecordSelId :: TyCon -> FieldLabel -> Id
430 mkRecordSelId tycon field_label
431 -- Assumes that all fields with the same field label have the same type
432 | is_naughty = naughty_id
435 is_naughty = not (tyVarsOfType field_ty `subVarSet` res_tv_set)
436 sel_id_details = RecordSelId tycon field_label is_naughty
438 -- Escapist case here for naughty construcotrs
439 -- We give it no IdInfo, and a type of forall a.a (never looked at)
440 naughty_id = mkGlobalId sel_id_details field_label forall_a_a noCafIdInfo
441 forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
443 -- Normal case starts here
444 sel_id = mkGlobalId sel_id_details field_label selector_ty info
445 data_cons = tyConDataCons tycon
446 data_cons_w_field = filter has_field data_cons -- Can't be empty!
447 has_field con = field_label `elem` dataConFieldLabels con
449 con1 = head data_cons_w_field
450 res_tys = dataConResTys con1
451 res_tv_set = tyVarsOfTypes res_tys
452 res_tvs = varSetElems res_tv_set
453 data_ty = mkTyConApp tycon res_tys
454 field_ty = dataConFieldType con1 field_label
456 -- *Very* tiresomely, the selectors are (unnecessarily!) overloaded over
457 -- just the dictionaries in the types of the constructors that contain
458 -- the relevant field. [The Report says that pattern matching on a
459 -- constructor gives the same constraints as applying it.] Urgh.
461 -- However, not all data cons have all constraints (because of
462 -- BuildTyCl.mkDataConStupidTheta). So we need to find all the data cons
463 -- involved in the pattern match and take the union of their constraints.
464 stupid_dict_tys = mkPredTys (dataConsStupidTheta data_cons_w_field)
465 n_stupid_dicts = length stupid_dict_tys
467 (field_tyvars,field_theta,field_tau) = tcSplitSigmaTy field_ty
468 field_dict_tys = mkPredTys field_theta
469 n_field_dict_tys = length field_dict_tys
470 -- If the field has a universally quantified type we have to
471 -- be a bit careful. Suppose we have
472 -- data R = R { op :: forall a. Foo a => a -> a }
473 -- Then we can't give op the type
474 -- op :: R -> forall a. Foo a => a -> a
475 -- because the typechecker doesn't understand foralls to the
476 -- right of an arrow. The "right" type to give it is
477 -- op :: forall a. Foo a => R -> a -> a
478 -- But then we must generate the right unfolding too:
479 -- op = /\a -> \dfoo -> \ r ->
482 -- Note that this is exactly the type we'd infer from a user defn
486 selector_ty = mkForAllTys res_tvs $ mkForAllTys field_tyvars $
487 mkFunTys stupid_dict_tys $ mkFunTys field_dict_tys $
488 mkFunTy data_ty field_tau
490 arity = 1 + n_stupid_dicts + n_field_dict_tys
492 (strict_sig, rhs_w_str) = dmdAnalTopRhs sel_rhs
493 -- Use the demand analyser to work out strictness.
494 -- With all this unpackery it's not easy!
497 `setCafInfo` caf_info
499 `setUnfoldingInfo` mkTopUnfolding rhs_w_str
500 `setAllStrictnessInfo` Just strict_sig
502 -- Allocate Ids. We do it a funny way round because field_dict_tys is
503 -- almost always empty. Also note that we use max_dict_tys
504 -- rather than n_dict_tys, because the latter gives an infinite loop:
505 -- n_dict tys depends on the_alts, which depens on arg_ids, which depends
506 -- on arity, which depends on n_dict tys. Sigh! Mega sigh!
507 stupid_dict_ids = mkTemplateLocalsNum 1 stupid_dict_tys
508 max_stupid_dicts = length (tyConStupidTheta tycon)
509 field_dict_base = max_stupid_dicts + 1
510 field_dict_ids = mkTemplateLocalsNum field_dict_base field_dict_tys
511 dict_id_base = field_dict_base + n_field_dict_tys
512 data_id = mkTemplateLocal dict_id_base data_ty
513 arg_base = dict_id_base + 1
515 the_alts :: [CoreAlt]
516 the_alts = map mk_alt data_cons_w_field -- Already sorted by data-con
517 no_default = length data_cons == length data_cons_w_field -- No default needed
519 default_alt | no_default = []
520 | otherwise = [(DEFAULT, [], error_expr)]
522 -- The default branch may have CAF refs, because it calls recSelError etc.
523 caf_info | no_default = NoCafRefs
524 | otherwise = MayHaveCafRefs
526 sel_rhs = mkLams res_tvs $ mkLams field_tyvars $
527 mkLams stupid_dict_ids $ mkLams field_dict_ids $
528 Lam data_id $ mk_result sel_body
530 -- NB: A newtype always has a vanilla DataCon; no existentials etc
531 -- res_tys will simply be the dataConUnivTyVars
532 sel_body | isNewTyCon tycon = unwrapNewTypeBody tycon res_tys (Var data_id)
533 | otherwise = Case (Var data_id) data_id field_tau (default_alt ++ the_alts)
535 mk_result poly_result = mkVarApps (mkVarApps poly_result field_tyvars) field_dict_ids
536 -- We pull the field lambdas to the top, so we need to
537 -- apply them in the body. For example:
538 -- data T = MkT { foo :: forall a. a->a }
540 -- foo :: forall a. T -> a -> a
541 -- foo = /\a. \t:T. case t of { MkT f -> f a }
544 = -- In the non-vanilla case, the pattern must bind type variables and
545 -- the context stuff; hence the arg_prefix binding below
546 mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids) (Var the_arg_id)
548 (arg_prefix, arg_ids)
549 | isVanillaDataCon data_con -- Instantiate from commmon base
550 = ([], mkTemplateLocalsNum arg_base (dataConInstOrigArgTys data_con res_tys))
551 | otherwise -- The case pattern binds type variables, which are used
552 -- in the types of the arguments of the pattern
553 = (dc_tvs ++ mkTemplateLocalsNum arg_base (mkPredTys dc_theta),
554 mkTemplateLocalsNum arg_base' dc_arg_tys)
556 (dc_tvs, dc_theta, dc_arg_tys) = dataConSig data_con
557 arg_base' = arg_base + length dc_theta
559 unpack_base = arg_base' + length dc_arg_tys
560 uniqs = map mkBuiltinUnique [unpack_base..]
562 the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` arg_ids) field_label
563 field_lbls = dataConFieldLabels data_con
565 error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg
566 full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
569 -- (mkReboxingAlt us con xs rhs) basically constructs the case
570 -- alternative (con, xs, rhs)
571 -- but it does the reboxing necessary to construct the *source*
572 -- arguments, xs, from the representation arguments ys.
574 -- data T = MkT !(Int,Int) Bool
576 -- mkReboxingAlt MkT [x,b] r
577 -- = (DataAlt MkT, [y::Int,z::Int,b], let x = (y,z) in r)
579 -- mkDataAlt should really be in DataCon, but it can't because
580 -- it manipulates CoreSyn.
583 :: [Unique] -- Uniques for the new Ids
585 -> [Var] -- Source-level args, including existential dicts
589 mkReboxingAlt us con args rhs
590 | not (any isMarkedUnboxed stricts)
591 = (DataAlt con, args, rhs)
595 (binds, args') = go args stricts us
597 (DataAlt con, args', mkLets binds rhs)
600 stricts = dataConExStricts con ++ dataConStrictMarks con
602 go [] stricts us = ([], [])
604 -- Type variable case
605 go (arg:args) stricts us
607 = let (binds, args') = go args stricts us
608 in (binds, arg:args')
610 -- Term variable case
611 go (arg:args) (str:stricts) us
612 | isMarkedUnboxed str
616 (tycon, tycon_args, pack_con, con_arg_tys)
617 = splitProductType "mkReboxingAlt" ty
619 unpacked_args = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
620 (binds, args') = go args stricts (dropList con_arg_tys us)
621 con_app | isNewTyCon tycon = ASSERT( isSingleton unpacked_args )
622 wrapNewTypeBody tycon tycon_args (Var (head unpacked_args))
623 -- ToDo: is this right? Jun06
624 | otherwise = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
626 (NonRec arg con_app : binds, unpacked_args ++ args')
629 = let (binds, args') = go args stricts us
630 in (binds, arg:args')
634 %************************************************************************
636 \subsection{Dictionary selectors}
638 %************************************************************************
640 Selecting a field for a dictionary. If there is just one field, then
641 there's nothing to do.
643 Dictionary selectors may get nested forall-types. Thus:
646 op :: forall b. Ord b => a -> b -> b
648 Then the top-level type for op is
650 op :: forall a. Foo a =>
654 This is unlike ordinary record selectors, which have all the for-alls
655 at the outside. When dealing with classes it's very convenient to
656 recover the original type signature from the class op selector.
659 mkDictSelId :: Name -> Class -> Id
660 mkDictSelId name clas
661 = mkGlobalId (ClassOpId clas) name sel_ty info
663 sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id))
664 -- We can't just say (exprType rhs), because that would give a type
666 -- for a single-op class (after all, the selector is the identity)
667 -- But it's type must expose the representation of the dictionary
668 -- to gat (say) C a -> (a -> a)
672 `setUnfoldingInfo` mkTopUnfolding rhs
673 `setAllStrictnessInfo` Just strict_sig
675 -- We no longer use 'must-inline' on record selectors. They'll
676 -- inline like crazy if they scrutinise a constructor
678 -- The strictness signature is of the form U(AAAVAAAA) -> T
679 -- where the V depends on which item we are selecting
680 -- It's worth giving one, so that absence info etc is generated
681 -- even if the selector isn't inlined
682 strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes)
683 arg_dmd | isNewTyCon tycon = evalDmd
684 | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
687 tycon = classTyCon clas
688 [data_con] = tyConDataCons tycon
689 tyvars = dataConUnivTyVars data_con
690 arg_tys = ASSERT( isVanillaDataCon data_con ) dataConRepArgTys data_con
691 the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name
693 pred = mkClassPred clas (mkTyVarTys tyvars)
694 (dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys)
696 rhs = mkLams tyvars (Lam dict_id rhs_body)
697 rhs_body | isNewTyCon tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
698 | otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
699 [(DataAlt data_con, arg_ids, Var the_arg_id)]
701 wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
702 -- The wrapper for the data constructor for a newtype looks like this:
703 -- newtype T a = MkT (a,Int)
704 -- MkT :: forall a. (a,Int) -> T a
705 -- MkT = /\a. \(x:(a,Int)). x `cast` CoT a
706 -- where CoT is the coercion TyCon assoicated with the newtype
708 -- The call (wrapNewTypeBody T [a] e) returns the
709 -- body of the wrapper, namely
712 -- For non-recursive newtypes, GHC currently treats them like type
713 -- synonyms, so no cast is necessary. This function is the only
714 -- place in the compiler that generates
716 wrapNewTypeBody tycon args result_expr
717 -- | isRecursiveTyCon tycon -- Recursive case; use a coerce
718 = Cast result_expr co
722 co = mkTyConApp (newTyConCo tycon) args
724 unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
725 unwrapNewTypeBody tycon args result_expr
726 -- | isRecursiveTyCon tycon -- Recursive case; use a coerce
727 = Cast result_expr sym_co
731 sym_co = mkSymCoercion co
732 co = mkTyConApp (newTyConCo tycon) args
734 -- Old Definition of mkNewTypeBody
735 -- Used for both wrapping and unwrapping
736 --mkNewTypeBody tycon result_ty result_expr
737 -- | isRecursiveTyCon tycon -- Recursive case; use a coerce
738 -- = Note (Coerce result_ty (exprType result_expr)) result_expr
739 -- | otherwise -- Normal case
744 %************************************************************************
746 \subsection{Primitive operations
748 %************************************************************************
751 mkPrimOpId :: PrimOp -> Id
755 (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op
756 ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
757 name = mkWiredInName gHC_PRIM (primOpOcc prim_op)
758 (mkPrimOpIdUnique (primOpTag prim_op))
759 Nothing (AnId id) UserSyntax
760 id = mkGlobalId (PrimOpId prim_op) name ty info
763 `setSpecInfo` mkSpecInfo (primOpRules prim_op name)
765 `setAllStrictnessInfo` Just strict_sig
767 -- For each ccall we manufacture a separate CCallOpId, giving it
768 -- a fresh unique, a type that is correct for this particular ccall,
769 -- and a CCall structure that gives the correct details about calling
772 -- The *name* of this Id is a local name whose OccName gives the full
773 -- details of the ccall, type and all. This means that the interface
774 -- file reader can reconstruct a suitable Id
776 mkFCallId :: Unique -> ForeignCall -> Type -> Id
777 mkFCallId uniq fcall ty
778 = ASSERT( isEmptyVarSet (tyVarsOfType ty) )
779 -- A CCallOpId should have no free type variables;
780 -- when doing substitutions won't substitute over it
781 mkGlobalId (FCallId fcall) name ty info
783 occ_str = showSDoc (braces (ppr fcall <+> ppr ty))
784 -- The "occurrence name" of a ccall is the full info about the
785 -- ccall; it is encoded, but may have embedded spaces etc!
787 name = mkFCallName uniq occ_str
791 `setAllStrictnessInfo` Just strict_sig
793 (_, tau) = tcSplitForAllTys ty
794 (arg_tys, _) = tcSplitFunTys tau
795 arity = length arg_tys
796 strict_sig = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
800 %************************************************************************
802 \subsection{DictFuns and default methods}
804 %************************************************************************
806 Important notes about dict funs and default methods
807 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
808 Dict funs and default methods are *not* ImplicitIds. Their definition
809 involves user-written code, so we can't figure out their strictness etc
810 based on fixed info, as we can for constructors and record selectors (say).
812 We build them as LocalIds, but with External Names. This ensures that
813 they are taken to account by free-variable finding and dependency
814 analysis (e.g. CoreFVs.exprFreeVars).
816 Why shouldn't they be bound as GlobalIds? Because, in particular, if
817 they are globals, the specialiser floats dict uses above their defns,
818 which prevents good simplifications happening. Also the strictness
819 analyser treats a occurrence of a GlobalId as imported and assumes it
820 contains strictness in its IdInfo, which isn't true if the thing is
821 bound in the same module as the occurrence.
823 It's OK for dfuns to be LocalIds, because we form the instance-env to
824 pass on to the next module (md_insts) in CoreTidy, afer tidying
825 and globalising the top-level Ids.
827 BUT make sure they are *exported* LocalIds (mkExportedLocalId) so
828 that they aren't discarded by the occurrence analyser.
831 mkDefaultMethodId dm_name ty = mkExportedLocalId dm_name ty
833 mkDictFunId :: Name -- Name to use for the dict fun;
840 mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys
841 = mkExportedLocalId dfun_name dfun_ty
843 dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
845 {- 1 dec 99: disable the Mark Jones optimisation for the sake
846 of compatibility with Hugs.
847 See `types/InstEnv' for a discussion related to this.
849 (class_tyvars, sc_theta, _, _) = classBigSig clas
850 not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
851 sc_theta' = substClasses (zipTopTvSubst class_tyvars inst_tys) sc_theta
852 dfun_theta = case inst_decl_theta of
853 [] -> [] -- If inst_decl_theta is empty, then we don't
854 -- want to have any dict arguments, so that we can
855 -- expose the constant methods.
857 other -> nub (inst_decl_theta ++ filter not_const sc_theta')
858 -- Otherwise we pass the superclass dictionaries to
859 -- the dictionary function; the Mark Jones optimisation.
861 -- NOTE the "nub". I got caught by this one:
862 -- class Monad m => MonadT t m where ...
863 -- instance Monad m => MonadT (EnvT env) m where ...
864 -- Here, the inst_decl_theta has (Monad m); but so
865 -- does the sc_theta'!
867 -- NOTE the "not_const". I got caught by this one too:
868 -- class Foo a => Baz a b where ...
869 -- instance Wob b => Baz T b where..
870 -- Now sc_theta' has Foo T
875 %************************************************************************
877 \subsection{Un-definable}
879 %************************************************************************
881 These Ids can't be defined in Haskell. They could be defined in
882 unfoldings in the wired-in GHC.Prim interface file, but we'd have to
883 ensure that they were definitely, definitely inlined, because there is
884 no curried identifier for them. That's what mkCompulsoryUnfolding
885 does. If we had a way to get a compulsory unfolding from an interface
886 file, we could do that, but we don't right now.
888 unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
889 just gets expanded into a type coercion wherever it occurs. Hence we
890 add it as a built-in Id with an unfolding here.
892 The type variables we use here are "open" type variables: this means
893 they can unify with both unlifted and lifted types. Hence we provide
894 another gun with which to shoot yourself in the foot.
897 mkWiredInIdName mod fs uniq id
898 = mkWiredInName mod (mkOccNameFS varName fs) uniq Nothing (AnId id) UserSyntax
900 unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId
901 nullAddrName = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#") nullAddrIdKey nullAddrId
902 seqName = mkWiredInIdName gHC_PRIM FSLIT("seq") seqIdKey seqId
903 realWorldName = mkWiredInIdName gHC_PRIM FSLIT("realWorld#") realWorldPrimIdKey realWorldPrimId
904 lazyIdName = mkWiredInIdName gHC_BASE FSLIT("lazy") lazyIdKey lazyId
906 errorName = mkWiredInIdName gHC_ERR FSLIT("error") errorIdKey eRROR_ID
907 recSelErrorName = mkWiredInIdName gHC_ERR FSLIT("recSelError") recSelErrorIdKey rEC_SEL_ERROR_ID
908 runtimeErrorName = mkWiredInIdName gHC_ERR FSLIT("runtimeError") runtimeErrorIdKey rUNTIME_ERROR_ID
909 irrefutPatErrorName = mkWiredInIdName gHC_ERR FSLIT("irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
910 recConErrorName = mkWiredInIdName gHC_ERR FSLIT("recConError") recConErrorIdKey rEC_CON_ERROR_ID
911 patErrorName = mkWiredInIdName gHC_ERR FSLIT("patError") patErrorIdKey pAT_ERROR_ID
912 noMethodBindingErrorName = mkWiredInIdName gHC_ERR FSLIT("noMethodBindingError")
913 noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
914 nonExhaustiveGuardsErrorName
915 = mkWiredInIdName gHC_ERR FSLIT("nonExhaustiveGuardsError")
916 nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
920 -- unsafeCoerce# :: forall a b. a -> b
922 = pcMiscPrelId unsafeCoerceName ty info
924 info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
927 ty = mkForAllTys [openAlphaTyVar,openBetaTyVar]
928 (mkFunTy openAlphaTy openBetaTy)
929 [x] = mkTemplateLocals [openAlphaTy]
930 rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
931 -- Note (Coerce openBetaTy openAlphaTy) (Var x)
932 Cast (Var x) (mkUnsafeCoercion openAlphaTy openBetaTy)
934 -- nullAddr# :: Addr#
935 -- The reason is is here is because we don't provide
936 -- a way to write this literal in Haskell.
938 = pcMiscPrelId nullAddrName addrPrimTy info
940 info = noCafIdInfo `setUnfoldingInfo`
941 mkCompulsoryUnfolding (Lit nullAddrLit)
944 = pcMiscPrelId seqName ty info
946 info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
949 ty = mkForAllTys [alphaTyVar,openBetaTyVar]
950 (mkFunTy alphaTy (mkFunTy openBetaTy openBetaTy))
951 [x,y] = mkTemplateLocals [alphaTy, openBetaTy]
952 rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x openBetaTy [(DEFAULT, [], Var y)])
954 -- lazy :: forall a?. a? -> a? (i.e. works for unboxed types too)
955 -- Used to lazify pseq: pseq a b = a `seq` lazy b
957 -- Also, no strictness: by being a built-in Id, all the info about lazyId comes from here,
958 -- not from GHC.Base.hi. This is important, because the strictness
959 -- analyser will spot it as strict!
961 -- Also no unfolding in lazyId: it gets "inlined" by a HACK in the worker/wrapper pass
962 -- (see WorkWrap.wwExpr)
963 -- We could use inline phases to do this, but that would be vulnerable to changes in
964 -- phase numbering....we must inline precisely after strictness analysis.
966 = pcMiscPrelId lazyIdName ty info
969 ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
971 lazyIdUnfolding :: CoreExpr -- Used to expand 'lazyId' after strictness anal
972 lazyIdUnfolding = mkLams [openAlphaTyVar,x] (Var x)
974 [x] = mkTemplateLocals [openAlphaTy]
977 @realWorld#@ used to be a magic literal, \tr{void#}. If things get
978 nasty as-is, change it back to a literal (@Literal@).
980 voidArgId is a Local Id used simply as an argument in functions
981 where we just want an arg to avoid having a thunk of unlifted type.
983 x = \ void :: State# RealWorld -> (# p, q #)
985 This comes up in strictness analysis
988 realWorldPrimId -- :: State# RealWorld
989 = pcMiscPrelId realWorldName realWorldStatePrimTy
990 (noCafIdInfo `setUnfoldingInfo` evaldUnfolding)
991 -- The evaldUnfolding makes it look that realWorld# is evaluated
992 -- which in turn makes Simplify.interestingArg return True,
993 -- which in turn makes INLINE things applied to realWorld# likely
996 voidArgId -- :: State# RealWorld
997 = mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy
1001 %************************************************************************
1003 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
1005 %************************************************************************
1007 GHC randomly injects these into the code.
1009 @patError@ is just a version of @error@ for pattern-matching
1010 failures. It knows various ``codes'' which expand to longer
1011 strings---this saves space!
1013 @absentErr@ is a thing we put in for ``absent'' arguments. They jolly
1014 well shouldn't be yanked on, but if one is, then you will get a
1015 friendly message from @absentErr@ (rather than a totally random
1018 @parError@ is a special version of @error@ which the compiler does
1019 not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
1020 templates, but we don't ever expect to generate code for it.
1024 :: Id -- Should be of type (forall a. Addr# -> a)
1025 -- where Addr# points to a UTF8 encoded string
1026 -> Type -- The type to instantiate 'a'
1027 -> String -- The string to print
1030 mkRuntimeErrorApp err_id res_ty err_msg
1031 = mkApps (Var err_id) [Type res_ty, err_string]
1033 err_string = Lit (mkStringLit err_msg)
1035 rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName
1036 rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName
1037 iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName
1038 rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName
1039 pAT_ERROR_ID = mkRuntimeErrorId patErrorName
1040 nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName
1041 nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
1043 -- The runtime error Ids take a UTF8-encoded string as argument
1044 mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
1045 runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
1049 eRROR_ID = pc_bottoming_Id errorName errorTy
1052 errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
1053 -- Notice the openAlphaTyVar. It says that "error" can be applied
1054 -- to unboxed as well as boxed types. This is OK because it never
1055 -- returns, so the return type is irrelevant.
1059 %************************************************************************
1061 \subsection{Utilities}
1063 %************************************************************************
1066 pcMiscPrelId :: Name -> Type -> IdInfo -> Id
1067 pcMiscPrelId name ty info
1068 = mkVanillaGlobal name ty info
1069 -- We lie and say the thing is imported; otherwise, we get into
1070 -- a mess with dependency analysis; e.g., core2stg may heave in
1071 -- random calls to GHCbase.unpackPS__. If GHCbase is the module
1072 -- being compiled, then it's just a matter of luck if the definition
1073 -- will be in "the right place" to be in scope.
1075 pc_bottoming_Id name ty
1076 = pcMiscPrelId name ty bottoming_info
1078 bottoming_info = vanillaIdInfo `setAllStrictnessInfo` Just strict_sig
1079 -- Do *not* mark them as NoCafRefs, because they can indeed have
1080 -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle,
1081 -- which has some CAFs
1082 -- In due course we may arrange that these error-y things are
1083 -- regarded by the GC as permanently live, in which case we
1084 -- can give them NoCaf info. As it is, any function that calls
1085 -- any pc_bottoming_Id will itself have CafRefs, which bloats
1088 strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
1089 -- These "bottom" out, no matter what their arguments
1091 (openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars
1092 openAlphaTy = mkTyVarTy openAlphaTyVar
1093 openBetaTy = mkTyVarTy openBetaTyVar