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,
19 mkDataConId, mkDataConWrapId,
20 mkRecordSelId, rebuildConArgs,
21 mkPrimOpId, mkFCallId,
23 -- And some particular Ids; see below for why they are wired in
25 unsafeCoerceId, realWorldPrimId,
26 eRROR_ID, eRROR_CSTRING_ID, rEC_SEL_ERROR_ID, pAT_ERROR_ID, rEC_CON_ERROR_ID,
27 rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID,
28 nO_METHOD_BINDING_ERROR_ID, aBSENT_ERROR_ID, pAR_ERROR_ID
31 #include "HsVersions.h"
34 import BasicTypes ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
35 import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy,
36 intPrimTy, realWorldStatePrimTy, addrPrimTy
38 import TysWiredIn ( charTy, mkListTy )
39 import PrelRules ( primOpRule )
40 import Rules ( addRule )
41 import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
42 mkTyVarTys, mkClassPred, tcEqPred,
43 mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy,
44 isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
45 tcSplitFunTys, tcSplitForAllTys, mkPredTy
47 import Module ( Module )
48 import CoreUtils ( mkInlineMe )
49 import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
50 import Literal ( Literal(..) )
51 import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
52 tyConTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
53 import Class ( Class, classTyCon, classTyVars, classSelIds )
54 import Var ( Id, TyVar )
55 import VarSet ( isEmptyVarSet )
56 import Name ( mkWiredInName, mkFCallName, Name )
57 import OccName ( mkVarOcc )
58 import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName )
59 import ForeignCall ( ForeignCall )
60 import DataCon ( DataCon,
61 dataConFieldLabels, dataConRepArity, dataConTyCon,
62 dataConArgTys, dataConRepType,
63 dataConInstOrigArgTys,
64 dataConName, dataConTheta,
65 dataConSig, dataConStrictMarks, dataConId,
68 import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
69 mkTemplateLocals, mkTemplateLocalsNum,
70 mkTemplateLocal, idNewStrictness, idName
72 import IdInfo ( IdInfo, noCafNoTyGenIdInfo,
74 setArityInfo, setSpecInfo, setCgInfo,
75 mkNewStrictnessInfo, setNewStrictnessInfo,
76 GlobalIdDetails(..), CafInfo(..), CprInfo(..),
77 CgInfo(..), setCgArity
79 import NewDemand ( mkStrictSig, strictSigResInfo, DmdResult(..),
80 mkTopDmdType, topDmd, evalDmd, Demand(..), Keepity(..) )
81 import FieldLabel ( mkFieldLabel, fieldLabelName,
82 firstFieldLabelTag, allFieldLabelTags, fieldLabelType
84 import DmdAnal ( dmdAnalTopRhs )
86 import Unique ( mkBuiltinUnique )
89 import Maybe ( isJust )
91 import ListSetOps ( assoc, assocMaybe )
92 import UnicodeUtil ( stringToUtf8 )
96 %************************************************************************
98 \subsection{Wired in Ids}
100 %************************************************************************
104 = [ -- These error-y things are wired in because we don't yet have
105 -- a way to express in an interface file that the result type variable
106 -- is 'open'; that is can be unified with an unboxed type
108 -- [The interface file format now carry such information, but there's
109 -- no way yet of expressing at the definition site for these
111 -- functions that they have an 'open' result type. -- sof 1/99]
116 , iRREFUT_PAT_ERROR_ID
117 , nON_EXHAUSTIVE_GUARDS_ERROR_ID
118 , nO_METHOD_BINDING_ERROR_ID
124 -- These three can't be defined in Haskell
131 %************************************************************************
133 \subsection{Data constructors}
135 %************************************************************************
138 mkDataConId :: Name -> DataCon -> Id
139 -- Makes the *worker* for the data constructor; that is, the function
140 -- that takes the reprsentation arguments and builds the constructor.
141 mkDataConId work_name data_con
142 = mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info
144 info = noCafNoTyGenIdInfo
147 `setNewStrictnessInfo` Just strict_sig
149 arity = dataConRepArity data_con
150 strict_sig = mkStrictSig (mkTopDmdType (replicate arity topDmd) cpr_info)
152 tycon = dataConTyCon data_con
153 cpr_info | isProductTyCon tycon &&
156 arity <= mAX_CPR_SIZE = RetCPR
158 -- RetCPR is only true for products that are real data types;
159 -- that is, not unboxed tuples or [non-recursive] newtypes
161 mAX_CPR_SIZE :: Arity
163 -- We do not treat very big tuples as CPR-ish:
164 -- a) for a start we get into trouble because there aren't
165 -- "enough" unboxed tuple types (a tiresome restriction,
167 -- b) more importantly, big unboxed tuples get returned mainly
168 -- on the stack, and are often then allocated in the heap
169 -- by the caller. So doing CPR for them may in fact make
173 The wrapper for a constructor is an ordinary top-level binding that evaluates
174 any strict args, unboxes any args that are going to be flattened, and calls
177 We're going to build a constructor that looks like:
179 data (Data a, C b) => T a b = T1 !a !Int b
182 \d1::Data a, d2::C b ->
183 \p q r -> case p of { p ->
185 Con T1 [a,b] [p,q,r]}}
189 * d2 is thrown away --- a context in a data decl is used to make sure
190 one *could* construct dictionaries at the site the constructor
191 is used, but the dictionary isn't actually used.
193 * We have to check that we can construct Data dictionaries for
194 the types a and Int. Once we've done that we can throw d1 away too.
196 * We use (case p of q -> ...) to evaluate p, rather than "seq" because
197 all that matters is that the arguments are evaluated. "seq" is
198 very careful to preserve evaluation order, which we don't need
201 You might think that we could simply give constructors some strictness
202 info, like PrimOps, and let CoreToStg do the let-to-case transformation.
203 But we don't do that because in the case of primops and functions strictness
204 is a *property* not a *requirement*. In the case of constructors we need to
205 do something active to evaluate the argument.
207 Making an explicit case expression allows the simplifier to eliminate
208 it in the (common) case where the constructor arg is already evaluated.
211 mkDataConWrapId data_con
212 = mkGlobalId (DataConWrapId data_con) (dataConName data_con) wrap_ty info
214 work_id = dataConId data_con
216 info = noCafNoTyGenIdInfo
217 `setUnfoldingInfo` mkTopUnfolding (mkInlineMe wrap_rhs)
219 -- The NoCaf-ness is set by noCafNoTyGenIdInfo
221 -- It's important to specify the arity, so that partial
222 -- applications are treated as values
223 `setNewStrictnessInfo` Just wrap_sig
225 wrap_ty = mkForAllTys all_tyvars $
229 res_info = strictSigResInfo (idNewStrictness work_id)
230 wrap_sig = mkStrictSig (mkTopDmdType (replicate arity topDmd) res_info)
231 -- The Cpr info can be important inside INLINE rhss, where the
232 -- wrapper constructor isn't inlined
233 -- But we are sloppy about the argument demands, because we expect
234 -- to inline the constructor very vigorously.
236 wrap_rhs | isNewTyCon tycon
237 = ASSERT( null ex_tyvars && null ex_dict_args && length orig_arg_tys == 1 )
238 -- No existentials on a newtype, but it can have a context
239 -- e.g. newtype Eq a => T a = MkT (...)
240 mkLams tyvars $ mkLams dict_args $ Lam id_arg1 $
241 mkNewTypeBody tycon result_ty id_arg1
243 | null dict_args && not (any isMarkedStrict strict_marks)
244 = Var work_id -- The common case. Not only is this efficient,
245 -- but it also ensures that the wrapper is replaced
246 -- by the worker even when there are no args.
250 -- This is really important in rule matching,
251 -- (We could match on the wrappers,
252 -- but that makes it less likely that rules will match
253 -- when we bring bits of unfoldings together.)
255 -- NB: because of this special case, (map (:) ys) turns into
256 -- (map $w: ys), and thence into (map (\x xs. $w: x xs) ys)
257 -- in core-to-stg. The top-level defn for (:) is never used.
258 -- This is somewhat of a bore, but I'm currently leaving it
259 -- as is, so that there still is a top level curried (:) for
260 -- the interpreter to call.
263 = mkLams all_tyvars $ mkLams dict_args $
264 mkLams ex_dict_args $ mkLams id_args $
265 foldr mk_case con_app
266 (zip (ex_dict_args++id_args) strict_marks) i3 []
268 con_app i rep_ids = mkApps (Var work_id)
269 (map varToCoreExpr (all_tyvars ++ reverse rep_ids))
271 (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con
272 all_tyvars = tyvars ++ ex_tyvars
274 dict_tys = mkPredTys theta
275 ex_dict_tys = mkPredTys ex_theta
276 all_arg_tys = dict_tys ++ ex_dict_tys ++ orig_arg_tys
277 result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
279 mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
283 (dict_args, i1) = mkLocals 1 dict_tys
284 (ex_dict_args,i2) = mkLocals i1 ex_dict_tys
285 (id_args,i3) = mkLocals i2 orig_arg_tys
287 (id_arg1:_) = id_args -- Used for newtype only
289 strict_marks = dataConStrictMarks data_con
292 :: (Id, StrictnessMark) -- Arg, strictness
293 -> (Int -> [Id] -> CoreExpr) -- Body
294 -> Int -- Next rep arg id
295 -> [Id] -- Rep args so far, reversed
297 mk_case (arg,strict) body i rep_args
299 NotMarkedStrict -> body i (arg:rep_args)
301 | isUnLiftedType (idType arg) -> body i (arg:rep_args)
303 Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))]
306 -> case splitProductType "do_unbox" (idType arg) of
307 (tycon, tycon_args, con, tys) ->
308 Case (Var arg) arg [(DataAlt con, con_args,
309 body i' (reverse con_args ++ rep_args))]
311 (con_args, i') = mkLocals i tys
315 %************************************************************************
317 \subsection{Record selectors}
319 %************************************************************************
321 We're going to build a record selector unfolding that looks like this:
323 data T a b c = T1 { ..., op :: a, ...}
324 | T2 { ..., op :: a, ...}
327 sel = /\ a b c -> \ d -> case d of
332 Similarly for newtypes
334 newtype N a = MkN { unN :: a->a }
337 unN n = coerce (a->a) n
339 We need to take a little care if the field has a polymorphic type:
341 data R = R { f :: forall a. a->a }
345 f :: forall a. R -> a -> a
346 f = /\ a \ r = case r of
349 (not f :: R -> forall a. a->a, which gives the type inference mechanism
350 problems at call sites)
352 Similarly for newtypes
354 newtype N = MkN { unN :: forall a. a->a }
356 unN :: forall a. N -> a -> a
357 unN = /\a -> \n:N -> coerce (a->a) n
360 mkRecordSelId tycon field_label unpack_id unpackUtf8_id
361 -- Assumes that all fields with the same field label have the same type
363 -- Annoyingly, we have to pass in the unpackCString# Id, because
364 -- we can't conjure it up out of thin air
367 sel_id = mkGlobalId (RecordSelId field_label) (fieldLabelName field_label) selector_ty info
368 field_ty = fieldLabelType field_label
369 data_cons = tyConDataCons tycon
370 tyvars = tyConTyVars tycon -- These scope over the types in
371 -- the FieldLabels of constructors of this type
372 data_ty = mkTyConApp tycon tyvar_tys
373 tyvar_tys = mkTyVarTys tyvars
375 tycon_theta = tyConTheta tycon -- The context on the data decl
376 -- eg data (Eq a, Ord b) => T a b = ...
377 dict_tys = [mkPredTy pred | pred <- tycon_theta,
379 needed_dict pred = or [ tcEqPred pred p
380 | (DataAlt dc, _, _) <- the_alts, p <- dataConTheta dc]
381 n_dict_tys = length dict_tys
383 (field_tyvars,field_theta,field_tau) = tcSplitSigmaTy field_ty
384 field_dict_tys = map mkPredTy field_theta
385 n_field_dict_tys = length field_dict_tys
386 -- If the field has a universally quantified type we have to
387 -- be a bit careful. Suppose we have
388 -- data R = R { op :: forall a. Foo a => a -> a }
389 -- Then we can't give op the type
390 -- op :: R -> forall a. Foo a => a -> a
391 -- because the typechecker doesn't understand foralls to the
392 -- right of an arrow. The "right" type to give it is
393 -- op :: forall a. Foo a => R -> a -> a
394 -- But then we must generate the right unfolding too:
395 -- op = /\a -> \dfoo -> \ r ->
398 -- Note that this is exactly the type we'd infer from a user defn
401 -- Very tiresomely, the selectors are (unnecessarily!) overloaded over
402 -- just the dictionaries in the types of the constructors that contain
403 -- the relevant field. Urgh.
404 -- NB: this code relies on the fact that DataCons are quantified over
405 -- the identical type variables as their parent TyCon
408 selector_ty = mkForAllTys tyvars $ mkForAllTys field_tyvars $
409 mkFunTys dict_tys $ mkFunTys field_dict_tys $
410 mkFunTy data_ty field_tau
412 arity = 1 + n_dict_tys + n_field_dict_tys
414 (strict_sig, rhs_w_str) = dmdAnalTopRhs sel_rhs
415 -- Use the demand analyser to work out strictness.
416 -- With all this unpackery it's not easy!
418 info = noCafNoTyGenIdInfo
419 `setCgInfo` CgInfo arity caf_info
421 `setUnfoldingInfo` mkTopUnfolding rhs_w_str
422 `setNewStrictnessInfo` Just strict_sig
423 -- Unfolding and strictness added by dmdAnalTopId
425 -- Allocate Ids. We do it a funny way round because field_dict_tys is
426 -- almost always empty. Also note that we use length_tycon_theta
427 -- rather than n_dict_tys, because the latter gives an infinite loop:
428 -- n_dict tys depends on the_alts, which depens on arg_ids, which depends
429 -- on arity, which depends on n_dict tys. Sigh! Mega sigh!
430 field_dict_base = length tycon_theta + 1
431 dict_id_base = field_dict_base + n_field_dict_tys
432 field_base = dict_id_base + 1
433 dict_ids = mkTemplateLocalsNum 1 dict_tys
434 field_dict_ids = mkTemplateLocalsNum field_dict_base field_dict_tys
435 data_id = mkTemplateLocal dict_id_base data_ty
437 alts = map mk_maybe_alt data_cons
438 the_alts = catMaybes alts
440 no_default = all isJust alts -- No default needed
441 default_alt | no_default = []
442 | otherwise = [(DEFAULT, [], error_expr)]
444 -- the default branch may have CAF refs, because it calls recSelError etc.
445 caf_info | no_default = NoCafRefs
446 | otherwise = MayHaveCafRefs
448 sel_rhs = mkLams tyvars $ mkLams field_tyvars $
449 mkLams dict_ids $ mkLams field_dict_ids $
450 Lam data_id $ sel_body
452 sel_body | isNewTyCon tycon = mkNewTypeBody tycon field_tau data_id
453 | otherwise = Case (Var data_id) data_id (default_alt ++ the_alts)
455 mk_maybe_alt data_con
456 = case maybe_the_arg_id of
458 Just the_arg_id -> Just (DataAlt data_con, real_args, mkLets binds body)
460 body = mkVarApps (mkVarApps (Var the_arg_id) field_tyvars) field_dict_ids
461 strict_marks = dataConStrictMarks data_con
462 (binds, real_args) = rebuildConArgs arg_ids strict_marks
463 (map mkBuiltinUnique [unpack_base..])
465 arg_ids = mkTemplateLocalsNum field_base (dataConInstOrigArgTys data_con tyvar_tys)
467 unpack_base = field_base + length arg_ids
469 -- arity+1 avoids all shadowing
470 maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
471 field_lbls = dataConFieldLabels data_con
473 error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type field_tau, err_string]
475 | all safeChar full_msg
476 = App (Var unpack_id) (Lit (MachStr (_PK_ full_msg)))
478 = App (Var unpackUtf8_id) (Lit (MachStr (_PK_ (stringToUtf8 (map ord full_msg)))))
480 safeChar c = c >= '\1' && c <= '\xFF'
481 -- TODO: Putting this Unicode stuff here is ugly. Find a better
482 -- generic place to make string literals. This logic is repeated
484 full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
487 -- This rather ugly function converts the unpacked data con
488 -- arguments back into their packed form.
491 :: [Id] -- Source-level args
492 -> [StrictnessMark] -- Strictness annotations (per-arg)
493 -> [Unique] -- Uniques for the new Ids
494 -> ([CoreBind], [Id]) -- A binding for each source-level arg, plus
495 -- a list of the representation-level arguments
496 -- e.g. data T = MkT Int !Int
498 -- rebuild [x::Int, y::Int] [Not, Unbox]
499 -- = ([ y = I# t ], [x,t])
501 rebuildConArgs [] stricts us = ([], [])
503 -- Type variable case
504 rebuildConArgs (arg:args) stricts us
506 = let (binds, args') = rebuildConArgs args stricts us
507 in (binds, arg:args')
509 -- Term variable case
510 rebuildConArgs (arg:args) (str:stricts) us
511 | isMarkedUnboxed str
515 (_, tycon_args, pack_con, con_arg_tys)
516 = splitProductType "rebuildConArgs" arg_ty
518 unpacked_args = zipWith (mkSysLocal SLIT("rb")) us con_arg_tys
519 (binds, args') = rebuildConArgs args stricts (drop (length con_arg_tys) us)
520 con_app = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
522 (NonRec arg con_app : binds, unpacked_args ++ args')
525 = let (binds, args') = rebuildConArgs args stricts us
526 in (binds, arg:args')
530 %************************************************************************
532 \subsection{Dictionary selectors}
534 %************************************************************************
536 Selecting a field for a dictionary. If there is just one field, then
537 there's nothing to do.
539 ToDo: unify with mkRecordSelId.
542 mkDictSelId :: Name -> Class -> Id
543 mkDictSelId name clas
544 = mkGlobalId (RecordSelId field_lbl) name sel_ty info
546 sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id))
547 -- We can't just say (exprType rhs), because that would give a type
549 -- for a single-op class (after all, the selector is the identity)
550 -- But it's type must expose the representation of the dictionary
551 -- to gat (say) C a -> (a -> a)
553 field_lbl = mkFieldLabel name tycon sel_ty tag
554 tag = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name
556 info = noCafNoTyGenIdInfo
559 `setUnfoldingInfo` mkTopUnfolding rhs
560 `setNewStrictnessInfo` Just strict_sig
562 -- We no longer use 'must-inline' on record selectors. They'll
563 -- inline like crazy if they scrutinise a constructor
565 -- The strictness signature is of the form U(AAAVAAAA) -> T
566 -- where the V depends on which item we are selecting
567 -- It's worth giving one, so that absence info etc is generated
568 -- even if the selector isn't inlined
569 strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes)
570 arg_dmd | isNewTyCon tycon = Eval
571 | otherwise = Seq Drop [ if the_arg_id == id then Eval else Abs
574 tyvars = classTyVars clas
576 tycon = classTyCon clas
577 [data_con] = tyConDataCons tycon
578 tyvar_tys = mkTyVarTys tyvars
579 arg_tys = dataConArgTys data_con tyvar_tys
580 the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
582 pred = mkClassPred clas tyvar_tys
583 (dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys)
585 rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
586 mkNewTypeBody tycon (head arg_tys) dict_id
587 | otherwise = mkLams tyvars $ Lam dict_id $
588 Case (Var dict_id) dict_id
589 [(DataAlt data_con, arg_ids, Var the_arg_id)]
591 mkNewTypeBody tycon result_ty result_id
592 | isRecursiveTyCon tycon -- Recursive case; use a coerce
593 = Note (Coerce result_ty (idType result_id)) (Var result_id)
594 | otherwise -- Normal case
599 %************************************************************************
601 \subsection{Primitive operations
603 %************************************************************************
606 mkPrimOpId :: PrimOp -> Id
610 (tyvars,arg_tys,res_ty, arity, strict_info) = primOpSig prim_op
611 ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
612 name = mkPrimOpIdName prim_op
613 id = mkGlobalId (PrimOpId prim_op) name ty info
615 info = noCafNoTyGenIdInfo
619 `setNewStrictnessInfo` Just (mkNewStrictnessInfo id arity strict_info NoCPRInfo)
620 -- Until we modify the primop generation code
622 rules = maybe emptyCoreRules (addRule emptyCoreRules id)
626 -- For each ccall we manufacture a separate CCallOpId, giving it
627 -- a fresh unique, a type that is correct for this particular ccall,
628 -- and a CCall structure that gives the correct details about calling
631 -- The *name* of this Id is a local name whose OccName gives the full
632 -- details of the ccall, type and all. This means that the interface
633 -- file reader can reconstruct a suitable Id
635 mkFCallId :: Unique -> ForeignCall -> Type -> Id
636 mkFCallId uniq fcall ty
637 = ASSERT( isEmptyVarSet (tyVarsOfType ty) )
638 -- A CCallOpId should have no free type variables;
639 -- when doing substitutions won't substitute over it
640 mkGlobalId (FCallId fcall) name ty info
642 occ_str = showSDocIface (braces (ppr fcall <+> ppr ty))
643 -- The "occurrence name" of a ccall is the full info about the
644 -- ccall; it is encoded, but may have embedded spaces etc!
646 name = mkFCallName uniq occ_str
648 info = noCafNoTyGenIdInfo
651 `setNewStrictnessInfo` Just strict_sig
653 (_, tau) = tcSplitForAllTys ty
654 (arg_tys, _) = tcSplitFunTys tau
655 arity = length arg_tys
656 strict_sig = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
660 %************************************************************************
662 \subsection{DictFuns and default methods}
664 %************************************************************************
666 Important notes about dict funs and default methods
667 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
668 Dict funs and default methods are *not* ImplicitIds. Their definition
669 involves user-written code, so we can't figure out their strictness etc
670 based on fixed info, as we can for constructors and record selectors (say).
672 We build them as GlobalIds, but when in the module where they are
673 bound, we turn the Id at the *binding site* into an exported LocalId.
674 This ensures that they are taken to account by free-variable finding
675 and dependency analysis (e.g. CoreFVs.exprFreeVars). The simplifier
676 will propagate the LocalId to all occurrence sites.
678 Why shouldn't they be bound as GlobalIds? Because, in particular, if
679 they are globals, the specialiser floats dict uses above their defns,
680 which prevents good simplifications happening. Also the strictness
681 analyser treats a occurrence of a GlobalId as imported and assumes it
682 contains strictness in its IdInfo, which isn't true if the thing is
683 bound in the same module as the occurrence.
685 It's OK for dfuns to be LocalIds, because we form the instance-env to
686 pass on to the next module (md_insts) in CoreTidy, afer tidying
687 and globalising the top-level Ids.
689 BUT make sure they are *exported* LocalIds (setIdLocalExported) so
690 that they aren't discarded by the occurrence analyser.
693 mkDefaultMethodId dm_name ty = mkVanillaGlobal dm_name ty noCafNoTyGenIdInfo
695 mkDictFunId :: Name -- Name to use for the dict fun;
702 mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta
703 = mkVanillaGlobal dfun_name dfun_ty noCafNoTyGenIdInfo
705 dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
707 {- 1 dec 99: disable the Mark Jones optimisation for the sake
708 of compatibility with Hugs.
709 See `types/InstEnv' for a discussion related to this.
711 (class_tyvars, sc_theta, _, _) = classBigSig clas
712 not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
713 sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
714 dfun_theta = case inst_decl_theta of
715 [] -> [] -- If inst_decl_theta is empty, then we don't
716 -- want to have any dict arguments, so that we can
717 -- expose the constant methods.
719 other -> nub (inst_decl_theta ++ filter not_const sc_theta')
720 -- Otherwise we pass the superclass dictionaries to
721 -- the dictionary function; the Mark Jones optimisation.
723 -- NOTE the "nub". I got caught by this one:
724 -- class Monad m => MonadT t m where ...
725 -- instance Monad m => MonadT (EnvT env) m where ...
726 -- Here, the inst_decl_theta has (Monad m); but so
727 -- does the sc_theta'!
729 -- NOTE the "not_const". I got caught by this one too:
730 -- class Foo a => Baz a b where ...
731 -- instance Wob b => Baz T b where..
732 -- Now sc_theta' has Foo T
737 %************************************************************************
739 \subsection{Un-definable}
741 %************************************************************************
743 These two can't be defined in Haskell.
745 unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
746 just gets expanded into a type coercion wherever it occurs. Hence we
747 add it as a built-in Id with an unfolding here.
749 The type variables we use here are "open" type variables: this means
750 they can unify with both unlifted and lifted types. Hence we provide
751 another gun with which to shoot yourself in the foot.
755 = pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info
757 info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
760 ty = mkForAllTys [openAlphaTyVar,openBetaTyVar]
761 (mkFunTy openAlphaTy openBetaTy)
762 [x] = mkTemplateLocals [openAlphaTy]
763 rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
764 Note (Coerce openBetaTy openAlphaTy) (Var x)
768 @getTag#@ is another function which can't be defined in Haskell. It needs to
769 evaluate its argument and call the dataToTag# primitive.
773 = pcMiscPrelId getTagIdKey pREL_GHC SLIT("getTag#") ty info
775 info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
776 -- We don't provide a defn for this; you must inline it
778 ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy intPrimTy)
779 [x,y] = mkTemplateLocals [alphaTy,alphaTy]
780 rhs = mkLams [alphaTyVar,x] $
781 Case (Var x) y [ (DEFAULT, [], mkApps (Var dataToTagId) [Type alphaTy, Var y]) ]
783 dataToTagId = mkPrimOpId DataToTagOp
786 @realWorld#@ used to be a magic literal, \tr{void#}. If things get
787 nasty as-is, change it back to a literal (@Literal@).
790 realWorldPrimId -- :: State# RealWorld
791 = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#")
793 (noCafNoTyGenIdInfo `setUnfoldingInfo` mkOtherCon [])
794 -- The mkOtherCon makes it look that realWorld# is evaluated
795 -- which in turn makes Simplify.interestingArg return True,
796 -- which in turn makes INLINE things applied to realWorld# likely
801 %************************************************************************
803 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
805 %************************************************************************
807 GHC randomly injects these into the code.
809 @patError@ is just a version of @error@ for pattern-matching
810 failures. It knows various ``codes'' which expand to longer
811 strings---this saves space!
813 @absentErr@ is a thing we put in for ``absent'' arguments. They jolly
814 well shouldn't be yanked on, but if one is, then you will get a
815 friendly message from @absentErr@ (rather than a totally random
818 @parError@ is a special version of @error@ which the compiler does
819 not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
820 templates, but we don't ever expect to generate code for it.
824 = pc_bottoming_Id errorIdKey pREL_ERR SLIT("error") errorTy
826 = pc_bottoming_Id errorCStringIdKey pREL_ERR SLIT("errorCString")
827 (mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy))
829 = generic_ERROR_ID patErrorIdKey SLIT("patError")
831 = generic_ERROR_ID recSelErrIdKey SLIT("recSelError")
833 = generic_ERROR_ID recConErrorIdKey SLIT("recConError")
835 = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError")
837 = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
838 nON_EXHAUSTIVE_GUARDS_ERROR_ID
839 = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError")
840 nO_METHOD_BINDING_ERROR_ID
841 = generic_ERROR_ID noMethodBindingErrorIdKey SLIT("noMethodBindingError")
844 = pc_bottoming_Id absentErrorIdKey pREL_ERR SLIT("absentErr")
845 (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
848 = pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError")
849 (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafNoTyGenIdInfo
853 %************************************************************************
855 \subsection{Utilities}
857 %************************************************************************
860 pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
861 pcMiscPrelId key mod str ty info
863 name = mkWiredInName mod (mkVarOcc str) key
864 imp = mkVanillaGlobal name ty info -- the usual case...
867 -- We lie and say the thing is imported; otherwise, we get into
868 -- a mess with dependency analysis; e.g., core2stg may heave in
869 -- random calls to GHCbase.unpackPS__. If GHCbase is the module
870 -- being compiled, then it's just a matter of luck if the definition
871 -- will be in "the right place" to be in scope.
873 pc_bottoming_Id key mod name ty
874 = pcMiscPrelId key mod name ty bottoming_info
878 strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
879 bottoming_info = noCafNoTyGenIdInfo `setNewStrictnessInfo` Just strict_sig
880 -- these "bottom" out, no matter what their arguments
882 generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy
884 (openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars
885 openAlphaTy = mkTyVarTy openAlphaTyVar
886 openBetaTy = mkTyVarTy openBetaTyVar
889 errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy]
891 -- Notice the openAlphaTyVar. It says that "error" can be applied
892 -- to unboxed as well as boxed types. This is OK because it never
893 -- returns, so the return type is irrelevant.