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
36 #include "HsVersions.h"
39 import BasicTypes ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
40 import Rules ( mkSpecInfo )
41 import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy,
42 realWorldStatePrimTy, addrPrimTy
44 import TysWiredIn ( charTy, mkListTy )
45 import PrelRules ( primOpRules )
46 import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes )
47 import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
48 mkTyConApp, mkTyVarTys, mkClassPred,
49 mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy,
50 isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
51 tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta
53 import CoreUtils ( exprType )
54 import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding )
55 import Literal ( nullAddrLit, mkStringLit )
56 import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
57 tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
58 import Class ( Class, classTyCon, classSelIds )
59 import Var ( Id, TyVar, Var )
60 import VarSet ( isEmptyVarSet, subVarSet, varSetElems )
61 import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) )
62 import OccName ( mkOccNameFS, varName )
63 import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag )
64 import ForeignCall ( ForeignCall )
65 import DataCon ( DataCon, DataConIds(..), dataConTyVars,
66 dataConFieldLabels, dataConRepArity, dataConResTys,
67 dataConRepArgTys, dataConRepType,
68 dataConSig, dataConStrictMarks, dataConExStricts,
69 splitProductType, isVanillaDataCon, dataConFieldType,
72 import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
73 mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
74 mkTemplateLocal, idName
76 import IdInfo ( IdInfo, noCafIdInfo, setUnfoldingInfo,
77 setArityInfo, setSpecInfo, setCafInfo,
78 setAllStrictnessInfo, vanillaIdInfo,
79 GlobalIdDetails(..), CafInfo(..)
81 import NewDemand ( mkStrictSig, DmdResult(..),
82 mkTopDmdType, topDmd, evalDmd, lazyDmd, retCPR,
83 Demand(..), Demands(..) )
84 import DmdAnal ( dmdAnalTopRhs )
86 import Unique ( mkBuiltinUnique, mkPrimOpIdUnique )
89 import Util ( dropList, isSingleton )
92 import ListSetOps ( assoc )
95 %************************************************************************
97 \subsection{Wired in Ids}
99 %************************************************************************
103 = [ -- These error-y things are wired in because we don't yet have
104 -- a way to express in an interface file that the result type variable
105 -- is 'open'; that is can be unified with an unboxed type
107 -- [The interface file format now carry such information, but there's
108 -- no way yet of expressing at the definition site for these
109 -- error-reporting functions that they have an 'open'
110 -- result type. -- sof 1/99]
112 eRROR_ID, -- This one isn't used anywhere else in the compiler
113 -- But we still need it in wiredInIds so that when GHC
114 -- compiles a program that mentions 'error' we don't
115 -- import its type from the interface file; we just get
116 -- the Id defined here. Which has an 'open-tyvar' type.
119 iRREFUT_PAT_ERROR_ID,
120 nON_EXHAUSTIVE_GUARDS_ERROR_ID,
121 nO_METHOD_BINDING_ERROR_ID,
128 -- These Ids are exported from GHC.Prim
130 = [ -- These can't be defined in Haskell, but they have
131 -- perfectly reasonable unfoldings in Core
139 %************************************************************************
141 \subsection{Data constructors}
143 %************************************************************************
145 The wrapper for a constructor is an ordinary top-level binding that evaluates
146 any strict args, unboxes any args that are going to be flattened, and calls
149 We're going to build a constructor that looks like:
151 data (Data a, C b) => T a b = T1 !a !Int b
154 \d1::Data a, d2::C b ->
155 \p q r -> case p of { p ->
157 Con T1 [a,b] [p,q,r]}}
161 * d2 is thrown away --- a context in a data decl is used to make sure
162 one *could* construct dictionaries at the site the constructor
163 is used, but the dictionary isn't actually used.
165 * We have to check that we can construct Data dictionaries for
166 the types a and Int. Once we've done that we can throw d1 away too.
168 * We use (case p of q -> ...) to evaluate p, rather than "seq" because
169 all that matters is that the arguments are evaluated. "seq" is
170 very careful to preserve evaluation order, which we don't need
173 You might think that we could simply give constructors some strictness
174 info, like PrimOps, and let CoreToStg do the let-to-case transformation.
175 But we don't do that because in the case of primops and functions strictness
176 is a *property* not a *requirement*. In the case of constructors we need to
177 do something active to evaluate the argument.
179 Making an explicit case expression allows the simplifier to eliminate
180 it in the (common) case where the constructor arg is already evaluated.
184 mkDataConIds :: Name -> Name -> DataCon -> DataConIds
185 -- Makes the *worker* for the data constructor; that is, the function
186 -- that takes the reprsentation arguments and builds the constructor.
187 mkDataConIds wrap_name wkr_name data_con
191 | any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper
192 = AlgDC (Just alg_wrap_id) wrk_id
194 | otherwise -- Algebraic, no wrapper
195 = AlgDC Nothing wrk_id
197 (tyvars, theta, orig_arg_tys, tycon, res_tys) = dataConSig data_con
199 dict_tys = mkPredTys theta
200 all_arg_tys = dict_tys ++ orig_arg_tys
201 result_ty = mkTyConApp tycon res_tys
203 wrap_ty = mkForAllTys tyvars (mkFunTys all_arg_tys result_ty)
204 -- We used to include the stupid theta in the wrapper's args
205 -- but now we don't. Instead the type checker just injects these
206 -- extra constraints where necessary.
208 ----------- Worker (algebraic data types only) --------------
209 wrk_id = mkGlobalId (DataConWorkId data_con) wkr_name
210 (dataConRepType data_con) wkr_info
212 wkr_arity = dataConRepArity data_con
213 wkr_info = noCafIdInfo
214 `setArityInfo` wkr_arity
215 `setAllStrictnessInfo` Just wkr_sig
216 `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
219 wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
220 -- Notice that we do *not* say the worker is strict
221 -- even if the data constructor is declared strict
222 -- e.g. data T = MkT !(Int,Int)
223 -- Why? Because the *wrapper* is strict (and its unfolding has case
224 -- expresssions that do the evals) but the *worker* itself is not.
225 -- If we pretend it is strict then when we see
226 -- case x of y -> $wMkT y
227 -- the simplifier thinks that y is "sure to be evaluated" (because
228 -- $wMkT is strict) and drops the case. No, $wMkT is not strict.
230 -- When the simplifer sees a pattern
231 -- case e of MkT x -> ...
232 -- it uses the dataConRepStrictness of MkT to mark x as evaluated;
233 -- but that's fine... dataConRepStrictness comes from the data con
234 -- not from the worker Id.
236 cpr_info | isProductTyCon tycon &&
239 wkr_arity <= mAX_CPR_SIZE = retCPR
241 -- RetCPR is only true for products that are real data types;
242 -- that is, not unboxed tuples or [non-recursive] newtypes
244 ----------- Wrappers for newtypes --------------
245 nt_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty nt_wrap_info
246 nt_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
247 `setArityInfo` 1 -- Arity 1
248 `setUnfoldingInfo` newtype_unf
249 newtype_unf = ASSERT( isVanillaDataCon data_con &&
250 isSingleton orig_arg_tys )
251 -- No existentials on a newtype, but it can have a context
252 -- e.g. newtype Eq a => T a = MkT (...)
253 mkTopUnfolding $ Note InlineMe $
254 mkLams tyvars $ Lam id_arg1 $
255 mkNewTypeBody tycon result_ty (Var id_arg1)
257 id_arg1 = mkTemplateLocal 1 (head orig_arg_tys)
259 ----------- Wrappers for algebraic data types --------------
260 alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info
261 alg_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
262 `setArityInfo` alg_arity
263 -- It's important to specify the arity, so that partial
264 -- applications are treated as values
265 `setUnfoldingInfo` alg_unf
266 `setAllStrictnessInfo` Just wrap_sig
268 all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con
269 wrap_sig = mkStrictSig (mkTopDmdType arg_dmds cpr_info)
270 arg_dmds = map mk_dmd all_strict_marks
271 mk_dmd str | isMarkedStrict str = evalDmd
272 | otherwise = lazyDmd
273 -- The Cpr info can be important inside INLINE rhss, where the
274 -- wrapper constructor isn't inlined.
275 -- And the argument strictness can be important too; we
276 -- may not inline a contructor when it is partially applied.
278 -- data W = C !Int !Int !Int
279 -- ...(let w = C x in ...(w p q)...)...
280 -- we want to see that w is strict in its two arguments
282 alg_unf = mkTopUnfolding $ Note InlineMe $
284 mkLams dict_args $ mkLams id_args $
285 foldr mk_case con_app
286 (zip (dict_args ++ id_args) all_strict_marks)
289 con_app i rep_ids = mkApps (Var wrk_id)
290 (map varToCoreExpr (tyvars ++ reverse rep_ids))
292 (dict_args,i2) = mkLocals 1 dict_tys
293 (id_args,i3) = mkLocals i2 orig_arg_tys
297 :: (Id, StrictnessMark) -- Arg, strictness
298 -> (Int -> [Id] -> CoreExpr) -- Body
299 -> Int -- Next rep arg id
300 -> [Id] -- Rep args so far, reversed
302 mk_case (arg,strict) body i rep_args
304 NotMarkedStrict -> body i (arg:rep_args)
306 | isUnLiftedType (idType arg) -> body i (arg:rep_args)
308 Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))]
311 -> case splitProductType "do_unbox" (idType arg) of
312 (tycon, tycon_args, con, tys) ->
313 Case (Var arg) arg result_ty
316 body i' (reverse con_args ++ rep_args))]
318 (con_args, i') = mkLocals i tys
320 mAX_CPR_SIZE :: Arity
322 -- We do not treat very big tuples as CPR-ish:
323 -- a) for a start we get into trouble because there aren't
324 -- "enough" unboxed tuple types (a tiresome restriction,
326 -- b) more importantly, big unboxed tuples get returned mainly
327 -- on the stack, and are often then allocated in the heap
328 -- by the caller. So doing CPR for them may in fact make
331 mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
337 %************************************************************************
339 \subsection{Record selectors}
341 %************************************************************************
343 We're going to build a record selector unfolding that looks like this:
345 data T a b c = T1 { ..., op :: a, ...}
346 | T2 { ..., op :: a, ...}
349 sel = /\ a b c -> \ d -> case d of
354 Similarly for newtypes
356 newtype N a = MkN { unN :: a->a }
359 unN n = coerce (a->a) n
361 We need to take a little care if the field has a polymorphic type:
363 data R = R { f :: forall a. a->a }
367 f :: forall a. R -> a -> a
368 f = /\ a \ r = case r of
371 (not f :: R -> forall a. a->a, which gives the type inference mechanism
372 problems at call sites)
374 Similarly for (recursive) newtypes
376 newtype N = MkN { unN :: forall a. a->a }
378 unN :: forall b. N -> b -> b
379 unN = /\b -> \n:N -> (coerce (forall a. a->a) n)
382 Note [Naughty record selectors]
383 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
384 A "naughty" field is one for which we can't define a record
385 selector, because an existential type variable would escape. For example:
386 data T = forall a. MkT { x,y::a }
387 We obviously can't define
389 Nevertheless we *do* put a RecordSelId into the type environment
390 so that if the user tries to use 'x' as a selector we can bleat
391 helpfully, rather than saying unhelpfully that 'x' is not in scope.
392 Hence the sel_naughty flag, to identify record selcectors that don't really exist.
394 In general, a field is naughty if its type mentions a type variable that
395 isn't in the result type of the constructor.
397 For GADTs, we require that all constructors with a common field 'f' have the same
398 result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon]
401 T1 { f :: a } :: T [a]
402 T2 { f :: a, y :: b } :: T [a]
403 and now the selector takes that type as its argument:
404 f :: forall a. T [a] -> a
408 Note the forall'd tyvars of the selector are just the free tyvars
409 of the result type; there may be other tyvars in the constructor's
410 type (e.g. 'b' in T2).
415 -- Plan: 1. Determine naughtiness by comparing field type vs result type
416 -- 2. Install naughty ones with selector_ty of type _|_ and fill in mzero for info
417 -- 3. If it's not naughty, do the normal plan.
419 mkRecordSelId :: TyCon -> FieldLabel -> Id
420 mkRecordSelId tycon field_label
421 -- Assumes that all fields with the same field label have the same type
422 | is_naughty = naughty_id
425 is_naughty = not (tyVarsOfType field_ty `subVarSet` tyvar_set)
426 sel_id_details = RecordSelId tycon field_label is_naughty
428 -- Escapist case here for naughty construcotrs
429 -- We give it no IdInfo, and a type of forall a.a (never looked at)
430 naughty_id = mkGlobalId sel_id_details field_label forall_a_a noCafIdInfo
431 forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
433 -- Normal case starts here
434 sel_id = mkGlobalId sel_id_details field_label selector_ty info
435 data_cons = tyConDataCons tycon
436 data_cons_w_field = filter has_field data_cons -- Can't be empty!
437 has_field con = field_label `elem` dataConFieldLabels con
439 con1 = head data_cons_w_field
440 res_tys = dataConResTys con1
441 tyvar_set = tyVarsOfTypes res_tys
442 tyvars = varSetElems tyvar_set
443 data_ty = mkTyConApp tycon res_tys
444 field_ty = dataConFieldType con1 field_label
446 -- *Very* tiresomely, the selectors are (unnecessarily!) overloaded over
447 -- just the dictionaries in the types of the constructors that contain
448 -- the relevant field. [The Report says that pattern matching on a
449 -- constructor gives the same constraints as applying it.] Urgh.
451 -- However, not all data cons have all constraints (because of
452 -- BuildTyCl.mkDataConStupidTheta). So we need to find all the data cons
453 -- involved in the pattern match and take the union of their constraints.
454 stupid_dict_tys = mkPredTys (dataConsStupidTheta data_cons_w_field)
455 n_stupid_dicts = length stupid_dict_tys
457 (field_tyvars,field_theta,field_tau) = tcSplitSigmaTy field_ty
458 field_dict_tys = mkPredTys field_theta
459 n_field_dict_tys = length field_dict_tys
460 -- If the field has a universally quantified type we have to
461 -- be a bit careful. Suppose we have
462 -- data R = R { op :: forall a. Foo a => a -> a }
463 -- Then we can't give op the type
464 -- op :: R -> forall a. Foo a => a -> a
465 -- because the typechecker doesn't understand foralls to the
466 -- right of an arrow. The "right" type to give it is
467 -- op :: forall a. Foo a => R -> a -> a
468 -- But then we must generate the right unfolding too:
469 -- op = /\a -> \dfoo -> \ r ->
472 -- Note that this is exactly the type we'd infer from a user defn
476 selector_ty = mkForAllTys tyvars $ mkForAllTys field_tyvars $
477 mkFunTys stupid_dict_tys $ mkFunTys field_dict_tys $
478 mkFunTy data_ty field_tau
480 arity = 1 + n_stupid_dicts + n_field_dict_tys
482 (strict_sig, rhs_w_str) = dmdAnalTopRhs sel_rhs
483 -- Use the demand analyser to work out strictness.
484 -- With all this unpackery it's not easy!
487 `setCafInfo` caf_info
489 `setUnfoldingInfo` mkTopUnfolding rhs_w_str
490 `setAllStrictnessInfo` Just strict_sig
492 -- Allocate Ids. We do it a funny way round because field_dict_tys is
493 -- almost always empty. Also note that we use max_dict_tys
494 -- rather than n_dict_tys, because the latter gives an infinite loop:
495 -- n_dict tys depends on the_alts, which depens on arg_ids, which depends
496 -- on arity, which depends on n_dict tys. Sigh! Mega sigh!
497 stupid_dict_ids = mkTemplateLocalsNum 1 stupid_dict_tys
498 max_stupid_dicts = length (tyConStupidTheta tycon)
499 field_dict_base = max_stupid_dicts + 1
500 field_dict_ids = mkTemplateLocalsNum field_dict_base field_dict_tys
501 dict_id_base = field_dict_base + n_field_dict_tys
502 data_id = mkTemplateLocal dict_id_base data_ty
503 arg_base = dict_id_base + 1
505 the_alts :: [CoreAlt]
506 the_alts = map mk_alt data_cons_w_field -- Already sorted by data-con
507 no_default = length data_cons == length data_cons_w_field -- No default needed
509 default_alt | no_default = []
510 | otherwise = [(DEFAULT, [], error_expr)]
512 -- The default branch may have CAF refs, because it calls recSelError etc.
513 caf_info | no_default = NoCafRefs
514 | otherwise = MayHaveCafRefs
516 sel_rhs = mkLams tyvars $ mkLams field_tyvars $
517 mkLams stupid_dict_ids $ mkLams field_dict_ids $
518 Lam data_id $ sel_body
520 sel_body | isNewTyCon tycon = mk_result (mkNewTypeBody tycon field_ty (Var data_id))
521 | otherwise = Case (Var data_id) data_id field_tau (default_alt ++ the_alts)
523 mk_result poly_result = mkVarApps (mkVarApps poly_result field_tyvars) field_dict_ids
524 -- We pull the field lambdas to the top, so we need to
525 -- apply them in the body. For example:
526 -- data T = MkT { foo :: forall a. a->a }
528 -- foo :: forall a. T -> a -> a
529 -- foo = /\a. \t:T. case t of { MkT f -> f a }
532 = -- In the non-vanilla case, the pattern must bind type variables and
533 -- the context stuff; hence the arg_prefix binding below
534 mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids)
535 (mk_result (Var the_arg_id))
537 (arg_prefix, arg_ids)
538 | isVanillaDataCon data_con -- Instantiate from commmon base
539 = ([], mkTemplateLocalsNum arg_base (dataConInstOrigArgTys data_con res_tys))
540 | otherwise -- The case pattern binds type variables, which are used
541 -- in the types of the arguments of the pattern
542 = (dc_tyvars ++ mkTemplateLocalsNum arg_base (mkPredTys dc_theta),
543 mkTemplateLocalsNum arg_base' dc_arg_tys)
545 (dc_tyvars, dc_theta, dc_arg_tys, _, _) = dataConSig data_con
546 arg_base' = arg_base + length dc_theta
548 unpack_base = arg_base' + length dc_arg_tys
549 uniqs = map mkBuiltinUnique [unpack_base..]
551 the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` arg_ids) field_label
552 field_lbls = dataConFieldLabels data_con
554 error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg
555 full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
558 -- (mkReboxingAlt us con xs rhs) basically constructs the case
559 -- alternative (con, xs, rhs)
560 -- but it does the reboxing necessary to construct the *source*
561 -- arguments, xs, from the representation arguments ys.
563 -- data T = MkT !(Int,Int) Bool
565 -- mkReboxingAlt MkT [x,b] r
566 -- = (DataAlt MkT, [y::Int,z::Int,b], let x = (y,z) in r)
568 -- mkDataAlt should really be in DataCon, but it can't because
569 -- it manipulates CoreSyn.
572 :: [Unique] -- Uniques for the new Ids
574 -> [Var] -- Source-level args, including existential dicts
578 mkReboxingAlt us con args rhs
579 | not (any isMarkedUnboxed stricts)
580 = (DataAlt con, args, rhs)
584 (binds, args') = go args stricts us
586 (DataAlt con, args', mkLets binds rhs)
589 stricts = dataConExStricts con ++ dataConStrictMarks con
591 go [] stricts us = ([], [])
593 -- Type variable case
594 go (arg:args) stricts us
596 = let (binds, args') = go args stricts us
597 in (binds, arg:args')
599 -- Term variable case
600 go (arg:args) (str:stricts) us
601 | isMarkedUnboxed str
603 (_, tycon_args, pack_con, con_arg_tys)
604 = splitProductType "mkReboxingAlt" (idType arg)
606 unpacked_args = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
607 (binds, args') = go args stricts (dropList con_arg_tys us)
608 con_app = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
610 (NonRec arg con_app : binds, unpacked_args ++ args')
613 = let (binds, args') = go args stricts us
614 in (binds, arg:args')
618 %************************************************************************
620 \subsection{Dictionary selectors}
622 %************************************************************************
624 Selecting a field for a dictionary. If there is just one field, then
625 there's nothing to do.
627 Dictionary selectors may get nested forall-types. Thus:
630 op :: forall b. Ord b => a -> b -> b
632 Then the top-level type for op is
634 op :: forall a. Foo a =>
638 This is unlike ordinary record selectors, which have all the for-alls
639 at the outside. When dealing with classes it's very convenient to
640 recover the original type signature from the class op selector.
643 mkDictSelId :: Name -> Class -> Id
644 mkDictSelId name clas
645 = mkGlobalId (ClassOpId clas) name sel_ty info
647 sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id))
648 -- We can't just say (exprType rhs), because that would give a type
650 -- for a single-op class (after all, the selector is the identity)
651 -- But it's type must expose the representation of the dictionary
652 -- to gat (say) C a -> (a -> a)
656 `setUnfoldingInfo` mkTopUnfolding rhs
657 `setAllStrictnessInfo` Just strict_sig
659 -- We no longer use 'must-inline' on record selectors. They'll
660 -- inline like crazy if they scrutinise a constructor
662 -- The strictness signature is of the form U(AAAVAAAA) -> T
663 -- where the V depends on which item we are selecting
664 -- It's worth giving one, so that absence info etc is generated
665 -- even if the selector isn't inlined
666 strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes)
667 arg_dmd | isNewTyCon tycon = evalDmd
668 | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
671 tycon = classTyCon clas
672 [data_con] = tyConDataCons tycon
673 tyvars = dataConTyVars data_con
674 arg_tys = dataConRepArgTys data_con
675 the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name
677 pred = mkClassPred clas (mkTyVarTys tyvars)
678 (dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys)
680 rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
681 mkNewTypeBody tycon (head arg_tys) (Var dict_id)
682 | otherwise = mkLams tyvars $ Lam dict_id $
683 Case (Var dict_id) dict_id (idType the_arg_id)
684 [(DataAlt data_con, arg_ids, Var the_arg_id)]
686 mkNewTypeBody tycon result_ty result_expr
687 -- Adds a coerce where necessary
688 -- Used for both wrapping and unwrapping
689 | isRecursiveTyCon tycon -- Recursive case; use a coerce
690 = Note (Coerce result_ty (exprType result_expr)) result_expr
691 | otherwise -- Normal case
696 %************************************************************************
698 \subsection{Primitive operations
700 %************************************************************************
703 mkPrimOpId :: PrimOp -> Id
707 (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op
708 ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
709 name = mkWiredInName gHC_PRIM (primOpOcc prim_op)
710 (mkPrimOpIdUnique (primOpTag prim_op))
711 Nothing (AnId id) UserSyntax
712 id = mkGlobalId (PrimOpId prim_op) name ty info
715 `setSpecInfo` mkSpecInfo (primOpRules prim_op name)
717 `setAllStrictnessInfo` Just strict_sig
719 -- For each ccall we manufacture a separate CCallOpId, giving it
720 -- a fresh unique, a type that is correct for this particular ccall,
721 -- and a CCall structure that gives the correct details about calling
724 -- The *name* of this Id is a local name whose OccName gives the full
725 -- details of the ccall, type and all. This means that the interface
726 -- file reader can reconstruct a suitable Id
728 mkFCallId :: Unique -> ForeignCall -> Type -> Id
729 mkFCallId uniq fcall ty
730 = ASSERT( isEmptyVarSet (tyVarsOfType ty) )
731 -- A CCallOpId should have no free type variables;
732 -- when doing substitutions won't substitute over it
733 mkGlobalId (FCallId fcall) name ty info
735 occ_str = showSDoc (braces (ppr fcall <+> ppr ty))
736 -- The "occurrence name" of a ccall is the full info about the
737 -- ccall; it is encoded, but may have embedded spaces etc!
739 name = mkFCallName uniq occ_str
743 `setAllStrictnessInfo` Just strict_sig
745 (_, tau) = tcSplitForAllTys ty
746 (arg_tys, _) = tcSplitFunTys tau
747 arity = length arg_tys
748 strict_sig = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
752 %************************************************************************
754 \subsection{DictFuns and default methods}
756 %************************************************************************
758 Important notes about dict funs and default methods
759 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
760 Dict funs and default methods are *not* ImplicitIds. Their definition
761 involves user-written code, so we can't figure out their strictness etc
762 based on fixed info, as we can for constructors and record selectors (say).
764 We build them as LocalIds, but with External Names. This ensures that
765 they are taken to account by free-variable finding and dependency
766 analysis (e.g. CoreFVs.exprFreeVars).
768 Why shouldn't they be bound as GlobalIds? Because, in particular, if
769 they are globals, the specialiser floats dict uses above their defns,
770 which prevents good simplifications happening. Also the strictness
771 analyser treats a occurrence of a GlobalId as imported and assumes it
772 contains strictness in its IdInfo, which isn't true if the thing is
773 bound in the same module as the occurrence.
775 It's OK for dfuns to be LocalIds, because we form the instance-env to
776 pass on to the next module (md_insts) in CoreTidy, afer tidying
777 and globalising the top-level Ids.
779 BUT make sure they are *exported* LocalIds (mkExportedLocalId) so
780 that they aren't discarded by the occurrence analyser.
783 mkDefaultMethodId dm_name ty = mkExportedLocalId dm_name ty
785 mkDictFunId :: Name -- Name to use for the dict fun;
792 mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys
793 = mkExportedLocalId dfun_name dfun_ty
795 dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
797 {- 1 dec 99: disable the Mark Jones optimisation for the sake
798 of compatibility with Hugs.
799 See `types/InstEnv' for a discussion related to this.
801 (class_tyvars, sc_theta, _, _) = classBigSig clas
802 not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
803 sc_theta' = substClasses (zipTopTvSubst class_tyvars inst_tys) sc_theta
804 dfun_theta = case inst_decl_theta of
805 [] -> [] -- If inst_decl_theta is empty, then we don't
806 -- want to have any dict arguments, so that we can
807 -- expose the constant methods.
809 other -> nub (inst_decl_theta ++ filter not_const sc_theta')
810 -- Otherwise we pass the superclass dictionaries to
811 -- the dictionary function; the Mark Jones optimisation.
813 -- NOTE the "nub". I got caught by this one:
814 -- class Monad m => MonadT t m where ...
815 -- instance Monad m => MonadT (EnvT env) m where ...
816 -- Here, the inst_decl_theta has (Monad m); but so
817 -- does the sc_theta'!
819 -- NOTE the "not_const". I got caught by this one too:
820 -- class Foo a => Baz a b where ...
821 -- instance Wob b => Baz T b where..
822 -- Now sc_theta' has Foo T
827 %************************************************************************
829 \subsection{Un-definable}
831 %************************************************************************
833 These Ids can't be defined in Haskell. They could be defined in
834 unfoldings in the wired-in GHC.Prim interface file, but we'd have to
835 ensure that they were definitely, definitely inlined, because there is
836 no curried identifier for them. That's what mkCompulsoryUnfolding
837 does. If we had a way to get a compulsory unfolding from an interface
838 file, we could do that, but we don't right now.
840 unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
841 just gets expanded into a type coercion wherever it occurs. Hence we
842 add it as a built-in Id with an unfolding here.
844 The type variables we use here are "open" type variables: this means
845 they can unify with both unlifted and lifted types. Hence we provide
846 another gun with which to shoot yourself in the foot.
849 mkWiredInIdName mod fs uniq id
850 = mkWiredInName mod (mkOccNameFS varName fs) uniq Nothing (AnId id) UserSyntax
852 unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId
853 nullAddrName = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#") nullAddrIdKey nullAddrId
854 seqName = mkWiredInIdName gHC_PRIM FSLIT("seq") seqIdKey seqId
855 realWorldName = mkWiredInIdName gHC_PRIM FSLIT("realWorld#") realWorldPrimIdKey realWorldPrimId
856 lazyIdName = mkWiredInIdName pREL_BASE FSLIT("lazy") lazyIdKey lazyId
858 errorName = mkWiredInIdName pREL_ERR FSLIT("error") errorIdKey eRROR_ID
859 recSelErrorName = mkWiredInIdName pREL_ERR FSLIT("recSelError") recSelErrorIdKey rEC_SEL_ERROR_ID
860 runtimeErrorName = mkWiredInIdName pREL_ERR FSLIT("runtimeError") runtimeErrorIdKey rUNTIME_ERROR_ID
861 irrefutPatErrorName = mkWiredInIdName pREL_ERR FSLIT("irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
862 recConErrorName = mkWiredInIdName pREL_ERR FSLIT("recConError") recConErrorIdKey rEC_CON_ERROR_ID
863 patErrorName = mkWiredInIdName pREL_ERR FSLIT("patError") patErrorIdKey pAT_ERROR_ID
864 noMethodBindingErrorName = mkWiredInIdName pREL_ERR FSLIT("noMethodBindingError")
865 noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
866 nonExhaustiveGuardsErrorName
867 = mkWiredInIdName pREL_ERR FSLIT("nonExhaustiveGuardsError")
868 nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
872 -- unsafeCoerce# :: forall a b. a -> b
874 = pcMiscPrelId unsafeCoerceName ty info
876 info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
879 ty = mkForAllTys [openAlphaTyVar,openBetaTyVar]
880 (mkFunTy openAlphaTy openBetaTy)
881 [x] = mkTemplateLocals [openAlphaTy]
882 rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
883 Note (Coerce openBetaTy openAlphaTy) (Var x)
885 -- nullAddr# :: Addr#
886 -- The reason is is here is because we don't provide
887 -- a way to write this literal in Haskell.
889 = pcMiscPrelId nullAddrName addrPrimTy info
891 info = noCafIdInfo `setUnfoldingInfo`
892 mkCompulsoryUnfolding (Lit nullAddrLit)
895 = pcMiscPrelId seqName ty info
897 info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
900 ty = mkForAllTys [alphaTyVar,openBetaTyVar]
901 (mkFunTy alphaTy (mkFunTy openBetaTy openBetaTy))
902 [x,y] = mkTemplateLocals [alphaTy, openBetaTy]
904 rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x openBetaTy [(DEFAULT, [], Var y)])
906 -- lazy :: forall a?. a? -> a? (i.e. works for unboxed types too)
907 -- Used to lazify pseq: pseq a b = a `seq` lazy b
908 -- No unfolding: it gets "inlined" by the worker/wrapper pass
909 -- Also, no strictness: by being a built-in Id, it overrides all
910 -- the info in PrelBase.hi. This is important, because the strictness
911 -- analyser will spot it as strict!
913 = pcMiscPrelId lazyIdName ty info
916 ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
918 lazyIdUnfolding :: CoreExpr -- Used to expand LazyOp after strictness anal
919 lazyIdUnfolding = mkLams [openAlphaTyVar,x] (Var x)
921 [x] = mkTemplateLocals [openAlphaTy]
924 @realWorld#@ used to be a magic literal, \tr{void#}. If things get
925 nasty as-is, change it back to a literal (@Literal@).
927 voidArgId is a Local Id used simply as an argument in functions
928 where we just want an arg to avoid having a thunk of unlifted type.
930 x = \ void :: State# RealWorld -> (# p, q #)
932 This comes up in strictness analysis
935 realWorldPrimId -- :: State# RealWorld
936 = pcMiscPrelId realWorldName realWorldStatePrimTy
937 (noCafIdInfo `setUnfoldingInfo` evaldUnfolding)
938 -- The evaldUnfolding makes it look that realWorld# is evaluated
939 -- which in turn makes Simplify.interestingArg return True,
940 -- which in turn makes INLINE things applied to realWorld# likely
943 voidArgId -- :: State# RealWorld
944 = mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy
948 %************************************************************************
950 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
952 %************************************************************************
954 GHC randomly injects these into the code.
956 @patError@ is just a version of @error@ for pattern-matching
957 failures. It knows various ``codes'' which expand to longer
958 strings---this saves space!
960 @absentErr@ is a thing we put in for ``absent'' arguments. They jolly
961 well shouldn't be yanked on, but if one is, then you will get a
962 friendly message from @absentErr@ (rather than a totally random
965 @parError@ is a special version of @error@ which the compiler does
966 not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
967 templates, but we don't ever expect to generate code for it.
971 :: Id -- Should be of type (forall a. Addr# -> a)
972 -- where Addr# points to a UTF8 encoded string
973 -> Type -- The type to instantiate 'a'
974 -> String -- The string to print
977 mkRuntimeErrorApp err_id res_ty err_msg
978 = mkApps (Var err_id) [Type res_ty, err_string]
980 err_string = Lit (mkStringLit err_msg)
982 rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName
983 rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName
984 iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName
985 rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName
986 pAT_ERROR_ID = mkRuntimeErrorId patErrorName
987 nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName
988 nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
990 -- The runtime error Ids take a UTF8-encoded string as argument
991 mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
992 runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
996 eRROR_ID = pc_bottoming_Id errorName errorTy
999 errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
1000 -- Notice the openAlphaTyVar. It says that "error" can be applied
1001 -- to unboxed as well as boxed types. This is OK because it never
1002 -- returns, so the return type is irrelevant.
1006 %************************************************************************
1008 \subsection{Utilities}
1010 %************************************************************************
1013 pcMiscPrelId :: Name -> Type -> IdInfo -> Id
1014 pcMiscPrelId name ty info
1015 = mkVanillaGlobal name ty info
1016 -- We lie and say the thing is imported; otherwise, we get into
1017 -- a mess with dependency analysis; e.g., core2stg may heave in
1018 -- random calls to GHCbase.unpackPS__. If GHCbase is the module
1019 -- being compiled, then it's just a matter of luck if the definition
1020 -- will be in "the right place" to be in scope.
1022 pc_bottoming_Id name ty
1023 = pcMiscPrelId name ty bottoming_info
1025 bottoming_info = vanillaIdInfo `setAllStrictnessInfo` Just strict_sig
1026 -- Do *not* mark them as NoCafRefs, because they can indeed have
1027 -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle,
1028 -- which has some CAFs
1029 -- In due course we may arrange that these error-y things are
1030 -- regarded by the GC as permanently live, in which case we
1031 -- can give them NoCaf info. As it is, any function that calls
1032 -- any pc_bottoming_Id will itself have CafRefs, which bloats
1035 strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
1036 -- These "bottom" out, no matter what their arguments
1038 (openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars
1039 openAlphaTy = mkTyVarTy openAlphaTyVar
1040 openBetaTy = mkTyVarTy openBetaTyVar