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, voidArgId, nullAddrId,
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, betaTyVar, betaTy,
36 intPrimTy, realWorldStatePrimTy, addrPrimTy
38 import TysWiredIn ( charTy, mkListTy )
39 import PrelRules ( primOpRules )
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 ( exprType )
49 import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
50 import Literal ( Literal(..), nullAddrLit )
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, setCafInfo,
75 newStrictnessFromOld, setAllStrictnessInfo,
76 GlobalIdDetails(..), CafInfo(..), CprInfo(..)
78 import NewDemand ( mkStrictSig, strictSigResInfo, DmdResult(..),
79 mkTopDmdType, topDmd, evalDmd, lazyDmd,
80 Demand(..), Demands(..) )
81 import FieldLabel ( mkFieldLabel, fieldLabelName,
82 firstFieldLabelTag, allFieldLabelTags, fieldLabelType
84 import DmdAnal ( dmdAnalTopRhs )
86 import Unique ( mkBuiltinUnique )
89 import Maybe ( isJust )
90 import Util ( dropList, isSingleton )
92 import ListSetOps ( assoc, assocMaybe )
93 import UnicodeUtil ( stringToUtf8 )
97 %************************************************************************
99 \subsection{Wired in Ids}
101 %************************************************************************
105 = [ -- These error-y things are wired in because we don't yet have
106 -- a way to express in an interface file that the result type variable
107 -- is 'open'; that is can be unified with an unboxed type
109 -- [The interface file format now carry such information, but there's
110 -- no way yet of expressing at the definition site for these
111 -- error-reporting functions that they have an 'open'
112 -- result type. -- sof 1/99]
117 , iRREFUT_PAT_ERROR_ID
118 , nON_EXHAUSTIVE_GUARDS_ERROR_ID
119 , nO_METHOD_BINDING_ERROR_ID
125 -- These can't be defined in Haskell, but they have
126 -- perfectly reasonable unfoldings in Core
135 %************************************************************************
137 \subsection{Data constructors}
139 %************************************************************************
142 mkDataConId :: Name -> DataCon -> Id
143 -- Makes the *worker* for the data constructor; that is, the function
144 -- that takes the reprsentation arguments and builds the constructor.
145 mkDataConId work_name data_con
146 = mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info
148 info = noCafNoTyGenIdInfo
150 `setAllStrictnessInfo` Just strict_sig
152 arity = dataConRepArity data_con
154 strict_sig = mkStrictSig (mkTopDmdType (replicate arity topDmd) cpr_info)
155 -- Notice that we do *not* say the worker is strict
156 -- even if the data constructor is declared strict
157 -- e.g. data T = MkT !(Int,Int)
158 -- Why? Because the *wrapper* is strict (and its unfolding has case
159 -- expresssions that do the evals) but the *worker* itself is not.
160 -- If we pretend it is strict then when we see
161 -- case x of y -> $wMkT y
162 -- the simplifier thinks that y is "sure to be evaluated" (because
163 -- $wMkT is strict) and drops the case. No, $wMkT is not strict.
165 -- When the simplifer sees a pattern
166 -- case e of MkT x -> ...
167 -- it uses the dataConRepStrictness of MkT to mark x as evaluated;
168 -- but that's fine... dataConRepStrictness comes from the data con
169 -- not from the worker Id.
171 tycon = dataConTyCon data_con
172 cpr_info | isProductTyCon tycon &&
175 arity <= mAX_CPR_SIZE = RetCPR
177 -- RetCPR is only true for products that are real data types;
178 -- that is, not unboxed tuples or [non-recursive] newtypes
180 mAX_CPR_SIZE :: Arity
182 -- We do not treat very big tuples as CPR-ish:
183 -- a) for a start we get into trouble because there aren't
184 -- "enough" unboxed tuple types (a tiresome restriction,
186 -- b) more importantly, big unboxed tuples get returned mainly
187 -- on the stack, and are often then allocated in the heap
188 -- by the caller. So doing CPR for them may in fact make
192 The wrapper for a constructor is an ordinary top-level binding that evaluates
193 any strict args, unboxes any args that are going to be flattened, and calls
196 We're going to build a constructor that looks like:
198 data (Data a, C b) => T a b = T1 !a !Int b
201 \d1::Data a, d2::C b ->
202 \p q r -> case p of { p ->
204 Con T1 [a,b] [p,q,r]}}
208 * d2 is thrown away --- a context in a data decl is used to make sure
209 one *could* construct dictionaries at the site the constructor
210 is used, but the dictionary isn't actually used.
212 * We have to check that we can construct Data dictionaries for
213 the types a and Int. Once we've done that we can throw d1 away too.
215 * We use (case p of q -> ...) to evaluate p, rather than "seq" because
216 all that matters is that the arguments are evaluated. "seq" is
217 very careful to preserve evaluation order, which we don't need
220 You might think that we could simply give constructors some strictness
221 info, like PrimOps, and let CoreToStg do the let-to-case transformation.
222 But we don't do that because in the case of primops and functions strictness
223 is a *property* not a *requirement*. In the case of constructors we need to
224 do something active to evaluate the argument.
226 Making an explicit case expression allows the simplifier to eliminate
227 it in the (common) case where the constructor arg is already evaluated.
230 mkDataConWrapId data_con
231 = mkGlobalId (DataConWrapId data_con) (dataConName data_con) wrap_ty info
233 work_id = dataConId data_con
235 info = noCafNoTyGenIdInfo
236 `setUnfoldingInfo` wrap_unf
237 -- The NoCaf-ness is set by noCafNoTyGenIdInfo
239 -- It's important to specify the arity, so that partial
240 -- applications are treated as values
241 `setAllStrictnessInfo` Just wrap_sig
243 wrap_ty = mkForAllTys all_tyvars (mkFunTys all_arg_tys result_ty)
245 wrap_sig = mkStrictSig (mkTopDmdType arg_dmds res_info)
246 res_info = strictSigResInfo (idNewStrictness work_id)
247 arg_dmds = [Abs | d <- dict_args] ++ map mk_dmd strict_marks
248 mk_dmd str | isMarkedStrict str = evalDmd
249 | otherwise = lazyDmd
250 -- The Cpr info can be important inside INLINE rhss, where the
251 -- wrapper constructor isn't inlined.
252 -- And the argument strictness can be important too; we
253 -- may not inline a contructor when it is partially applied.
255 -- data W = C !Int !Int !Int
256 -- ...(let w = C x in ...(w p q)...)...
257 -- we want to see that w is strict in its two arguments
259 wrap_unf | isNewTyCon tycon
260 = ASSERT( null ex_tyvars && null ex_dict_args && isSingleton orig_arg_tys )
261 -- No existentials on a newtype, but it can have a context
262 -- e.g. newtype Eq a => T a = MkT (...)
263 mkTopUnfolding $ Note InlineMe $
264 mkLams tyvars $ mkLams dict_args $ Lam id_arg1 $
265 mkNewTypeBody tycon result_ty (Var id_arg1)
267 | null dict_args && not (any isMarkedStrict strict_marks)
268 = mkCompulsoryUnfolding (Var work_id)
269 -- The common case. Not only is this efficient,
270 -- but it also ensures that the wrapper is replaced
271 -- by the worker even when there are no args.
275 -- This is really important in rule matching,
276 -- (We could match on the wrappers,
277 -- but that makes it less likely that rules will match
278 -- when we bring bits of unfoldings together.)
280 -- NB: because of this special case, (map (:) ys) turns into
281 -- (map $w: ys). The top-level defn for (:) is never used.
282 -- This is somewhat of a bore, but I'm currently leaving it
283 -- as is, so that there still is a top level curried (:) for
284 -- the interpreter to call.
287 = mkTopUnfolding $ Note InlineMe $
288 mkLams all_tyvars $ mkLams dict_args $
289 mkLams ex_dict_args $ mkLams id_args $
290 foldr mk_case con_app
291 (zip (ex_dict_args++id_args) strict_marks) i3 []
293 con_app i rep_ids = mkApps (Var work_id)
294 (map varToCoreExpr (all_tyvars ++ reverse rep_ids))
296 (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con
297 all_tyvars = tyvars ++ ex_tyvars
299 dict_tys = mkPredTys theta
300 ex_dict_tys = mkPredTys ex_theta
301 all_arg_tys = dict_tys ++ ex_dict_tys ++ orig_arg_tys
302 result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
304 mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
308 (dict_args, i1) = mkLocals 1 dict_tys
309 (ex_dict_args,i2) = mkLocals i1 ex_dict_tys
310 (id_args,i3) = mkLocals i2 orig_arg_tys
312 (id_arg1:_) = id_args -- Used for newtype only
314 strict_marks = dataConStrictMarks data_con
317 :: (Id, StrictnessMark) -- Arg, strictness
318 -> (Int -> [Id] -> CoreExpr) -- Body
319 -> Int -- Next rep arg id
320 -> [Id] -- Rep args so far, reversed
322 mk_case (arg,strict) body i rep_args
324 NotMarkedStrict -> body i (arg:rep_args)
326 | isUnLiftedType (idType arg) -> body i (arg:rep_args)
328 Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))]
331 -> case splitProductType "do_unbox" (idType arg) of
332 (tycon, tycon_args, con, tys) ->
333 Case (Var arg) arg [(DataAlt con, con_args,
334 body i' (reverse con_args ++ rep_args))]
336 (con_args, i') = mkLocals i tys
340 %************************************************************************
342 \subsection{Record selectors}
344 %************************************************************************
346 We're going to build a record selector unfolding that looks like this:
348 data T a b c = T1 { ..., op :: a, ...}
349 | T2 { ..., op :: a, ...}
352 sel = /\ a b c -> \ d -> case d of
357 Similarly for newtypes
359 newtype N a = MkN { unN :: a->a }
362 unN n = coerce (a->a) n
364 We need to take a little care if the field has a polymorphic type:
366 data R = R { f :: forall a. a->a }
370 f :: forall a. R -> a -> a
371 f = /\ a \ r = case r of
374 (not f :: R -> forall a. a->a, which gives the type inference mechanism
375 problems at call sites)
377 Similarly for newtypes
379 newtype N = MkN { unN :: forall a. a->a }
381 unN :: forall a. N -> a -> a
382 unN = /\a -> \n:N -> coerce (a->a) n
385 mkRecordSelId tycon field_label unpack_id unpackUtf8_id
386 -- Assumes that all fields with the same field label have the same type
388 -- Annoyingly, we have to pass in the unpackCString# Id, because
389 -- we can't conjure it up out of thin air
392 sel_id = mkGlobalId (RecordSelId field_label) (fieldLabelName field_label) selector_ty info
393 field_ty = fieldLabelType field_label
394 data_cons = tyConDataCons tycon
395 tyvars = tyConTyVars tycon -- These scope over the types in
396 -- the FieldLabels of constructors of this type
397 data_ty = mkTyConApp tycon tyvar_tys
398 tyvar_tys = mkTyVarTys tyvars
400 tycon_theta = tyConTheta tycon -- The context on the data decl
401 -- eg data (Eq a, Ord b) => T a b = ...
402 dict_tys = [mkPredTy pred | pred <- tycon_theta,
404 needed_dict pred = or [ tcEqPred pred p
405 | (DataAlt dc, _, _) <- the_alts, p <- dataConTheta dc]
406 n_dict_tys = length dict_tys
408 (field_tyvars,field_theta,field_tau) = tcSplitSigmaTy field_ty
409 field_dict_tys = map mkPredTy field_theta
410 n_field_dict_tys = length field_dict_tys
411 -- If the field has a universally quantified type we have to
412 -- be a bit careful. Suppose we have
413 -- data R = R { op :: forall a. Foo a => a -> a }
414 -- Then we can't give op the type
415 -- op :: R -> forall a. Foo a => a -> a
416 -- because the typechecker doesn't understand foralls to the
417 -- right of an arrow. The "right" type to give it is
418 -- op :: forall a. Foo a => R -> a -> a
419 -- But then we must generate the right unfolding too:
420 -- op = /\a -> \dfoo -> \ r ->
423 -- Note that this is exactly the type we'd infer from a user defn
426 -- Very tiresomely, the selectors are (unnecessarily!) overloaded over
427 -- just the dictionaries in the types of the constructors that contain
428 -- the relevant field. Urgh.
429 -- NB: this code relies on the fact that DataCons are quantified over
430 -- the identical type variables as their parent TyCon
433 selector_ty = mkForAllTys tyvars $ mkForAllTys field_tyvars $
434 mkFunTys dict_tys $ mkFunTys field_dict_tys $
435 mkFunTy data_ty field_tau
437 arity = 1 + n_dict_tys + n_field_dict_tys
439 (strict_sig, rhs_w_str) = dmdAnalTopRhs sel_rhs
440 -- Use the demand analyser to work out strictness.
441 -- With all this unpackery it's not easy!
443 info = noCafNoTyGenIdInfo
444 `setCafInfo` caf_info
446 `setUnfoldingInfo` mkTopUnfolding rhs_w_str
447 `setAllStrictnessInfo` Just strict_sig
449 -- Allocate Ids. We do it a funny way round because field_dict_tys is
450 -- almost always empty. Also note that we use length_tycon_theta
451 -- rather than n_dict_tys, because the latter gives an infinite loop:
452 -- n_dict tys depends on the_alts, which depens on arg_ids, which depends
453 -- on arity, which depends on n_dict tys. Sigh! Mega sigh!
454 field_dict_base = length tycon_theta + 1
455 dict_id_base = field_dict_base + n_field_dict_tys
456 field_base = dict_id_base + 1
457 dict_ids = mkTemplateLocalsNum 1 dict_tys
458 field_dict_ids = mkTemplateLocalsNum field_dict_base field_dict_tys
459 data_id = mkTemplateLocal dict_id_base data_ty
461 alts = map mk_maybe_alt data_cons
462 the_alts = catMaybes alts
464 no_default = all isJust alts -- No default needed
465 default_alt | no_default = []
466 | otherwise = [(DEFAULT, [], error_expr)]
468 -- the default branch may have CAF refs, because it calls recSelError etc.
469 caf_info | no_default = NoCafRefs
470 | otherwise = MayHaveCafRefs
472 sel_rhs = mkLams tyvars $ mkLams field_tyvars $
473 mkLams dict_ids $ mkLams field_dict_ids $
474 Lam data_id $ sel_body
476 sel_body | isNewTyCon tycon = mkNewTypeBody tycon field_tau (mk_result data_id)
477 | otherwise = Case (Var data_id) data_id (default_alt ++ the_alts)
479 mk_result result_id = mkVarApps (mkVarApps (Var result_id) field_tyvars) field_dict_ids
480 -- We pull the field lambdas to the top, so we need to
481 -- apply them in the body. For example:
482 -- data T = MkT { foo :: forall a. a->a }
484 -- foo :: forall a. T -> a -> a
485 -- foo = /\a. \t:T. case t of { MkT f -> f a }
487 mk_maybe_alt data_con
488 = case maybe_the_arg_id of
490 Just the_arg_id -> Just (DataAlt data_con, real_args, mkLets binds body)
492 body = mk_result the_arg_id
493 strict_marks = dataConStrictMarks data_con
494 (binds, real_args) = rebuildConArgs arg_ids strict_marks
495 (map mkBuiltinUnique [unpack_base..])
497 arg_ids = mkTemplateLocalsNum field_base (dataConInstOrigArgTys data_con tyvar_tys)
499 unpack_base = field_base + length arg_ids
501 -- arity+1 avoids all shadowing
502 maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
503 field_lbls = dataConFieldLabels data_con
505 error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type field_tau, err_string]
507 | all safeChar full_msg
508 = App (Var unpack_id) (Lit (MachStr (_PK_ full_msg)))
510 = App (Var unpackUtf8_id) (Lit (MachStr (_PK_ (stringToUtf8 (map ord full_msg)))))
512 safeChar c = c >= '\1' && c <= '\xFF'
513 -- TODO: Putting this Unicode stuff here is ugly. Find a better
514 -- generic place to make string literals. This logic is repeated
516 full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
519 -- This rather ugly function converts the unpacked data con
520 -- arguments back into their packed form.
523 :: [Id] -- Source-level args
524 -> [StrictnessMark] -- Strictness annotations (per-arg)
525 -> [Unique] -- Uniques for the new Ids
526 -> ([CoreBind], [Id]) -- A binding for each source-level arg, plus
527 -- a list of the representation-level arguments
528 -- e.g. data T = MkT Int !Int
530 -- rebuild [x::Int, y::Int] [Not, Unbox]
531 -- = ([ y = I# t ], [x,t])
533 rebuildConArgs [] stricts us = ([], [])
535 -- Type variable case
536 rebuildConArgs (arg:args) stricts us
538 = let (binds, args') = rebuildConArgs args stricts us
539 in (binds, arg:args')
541 -- Term variable case
542 rebuildConArgs (arg:args) (str:stricts) us
543 | isMarkedUnboxed str
547 (_, tycon_args, pack_con, con_arg_tys)
548 = splitProductType "rebuildConArgs" arg_ty
550 unpacked_args = zipWith (mkSysLocal SLIT("rb")) us con_arg_tys
551 (binds, args') = rebuildConArgs args stricts (dropList con_arg_tys us)
552 con_app = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
554 (NonRec arg con_app : binds, unpacked_args ++ args')
557 = let (binds, args') = rebuildConArgs args stricts us
558 in (binds, arg:args')
562 %************************************************************************
564 \subsection{Dictionary selectors}
566 %************************************************************************
568 Selecting a field for a dictionary. If there is just one field, then
569 there's nothing to do.
571 ToDo: unify with mkRecordSelId.
574 mkDictSelId :: Name -> Class -> Id
575 mkDictSelId name clas
576 = mkGlobalId (RecordSelId field_lbl) name sel_ty info
578 sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id))
579 -- We can't just say (exprType rhs), because that would give a type
581 -- for a single-op class (after all, the selector is the identity)
582 -- But it's type must expose the representation of the dictionary
583 -- to gat (say) C a -> (a -> a)
585 field_lbl = mkFieldLabel name tycon sel_ty tag
586 tag = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name
588 info = noCafNoTyGenIdInfo
590 `setUnfoldingInfo` mkTopUnfolding rhs
591 `setAllStrictnessInfo` Just strict_sig
593 -- We no longer use 'must-inline' on record selectors. They'll
594 -- inline like crazy if they scrutinise a constructor
596 -- The strictness signature is of the form U(AAAVAAAA) -> T
597 -- where the V depends on which item we are selecting
598 -- It's worth giving one, so that absence info etc is generated
599 -- even if the selector isn't inlined
600 strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes)
601 arg_dmd | isNewTyCon tycon = evalDmd
602 | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
605 tyvars = classTyVars clas
607 tycon = classTyCon clas
608 [data_con] = tyConDataCons tycon
609 tyvar_tys = mkTyVarTys tyvars
610 arg_tys = dataConArgTys data_con tyvar_tys
611 the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
613 pred = mkClassPred clas tyvar_tys
614 (dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys)
616 rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
617 mkNewTypeBody tycon (head arg_tys) (Var dict_id)
618 | otherwise = mkLams tyvars $ Lam dict_id $
619 Case (Var dict_id) dict_id
620 [(DataAlt data_con, arg_ids, Var the_arg_id)]
622 mkNewTypeBody tycon result_ty result_expr
623 -- Adds a coerce where necessary
624 -- Used for both wrapping and unwrapping
625 | isRecursiveTyCon tycon -- Recursive case; use a coerce
626 = Note (Coerce result_ty (exprType result_expr)) result_expr
627 | otherwise -- Normal case
632 %************************************************************************
634 \subsection{Primitive operations
636 %************************************************************************
639 mkPrimOpId :: PrimOp -> Id
643 (tyvars,arg_tys,res_ty, arity, strict_info) = primOpSig prim_op
644 ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
645 name = mkPrimOpIdName prim_op
646 id = mkGlobalId (PrimOpId prim_op) name ty info
648 info = noCafNoTyGenIdInfo
651 `setAllStrictnessInfo` Just (newStrictnessFromOld name arity strict_info NoCPRInfo)
652 -- Until we modify the primop generation code
654 rules = foldl (addRule id) emptyCoreRules (primOpRules prim_op)
657 -- For each ccall we manufacture a separate CCallOpId, giving it
658 -- a fresh unique, a type that is correct for this particular ccall,
659 -- and a CCall structure that gives the correct details about calling
662 -- The *name* of this Id is a local name whose OccName gives the full
663 -- details of the ccall, type and all. This means that the interface
664 -- file reader can reconstruct a suitable Id
666 mkFCallId :: Unique -> ForeignCall -> Type -> Id
667 mkFCallId uniq fcall ty
668 = ASSERT( isEmptyVarSet (tyVarsOfType ty) )
669 -- A CCallOpId should have no free type variables;
670 -- when doing substitutions won't substitute over it
671 mkGlobalId (FCallId fcall) name ty info
673 occ_str = showSDocIface (braces (ppr fcall <+> ppr ty))
674 -- The "occurrence name" of a ccall is the full info about the
675 -- ccall; it is encoded, but may have embedded spaces etc!
677 name = mkFCallName uniq occ_str
679 info = noCafNoTyGenIdInfo
681 `setAllStrictnessInfo` Just strict_sig
683 (_, tau) = tcSplitForAllTys ty
684 (arg_tys, _) = tcSplitFunTys tau
685 arity = length arg_tys
686 strict_sig = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
690 %************************************************************************
692 \subsection{DictFuns and default methods}
694 %************************************************************************
696 Important notes about dict funs and default methods
697 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
698 Dict funs and default methods are *not* ImplicitIds. Their definition
699 involves user-written code, so we can't figure out their strictness etc
700 based on fixed info, as we can for constructors and record selectors (say).
702 We build them as GlobalIds, but when in the module where they are
703 bound, we turn the Id at the *binding site* into an exported LocalId.
704 This ensures that they are taken to account by free-variable finding
705 and dependency analysis (e.g. CoreFVs.exprFreeVars). The simplifier
706 will propagate the LocalId to all occurrence sites.
708 Why shouldn't they be bound as GlobalIds? Because, in particular, if
709 they are globals, the specialiser floats dict uses above their defns,
710 which prevents good simplifications happening. Also the strictness
711 analyser treats a occurrence of a GlobalId as imported and assumes it
712 contains strictness in its IdInfo, which isn't true if the thing is
713 bound in the same module as the occurrence.
715 It's OK for dfuns to be LocalIds, because we form the instance-env to
716 pass on to the next module (md_insts) in CoreTidy, afer tidying
717 and globalising the top-level Ids.
719 BUT make sure they are *exported* LocalIds (setIdLocalExported) so
720 that they aren't discarded by the occurrence analyser.
723 mkDefaultMethodId dm_name ty = mkVanillaGlobal dm_name ty noCafNoTyGenIdInfo
725 mkDictFunId :: Name -- Name to use for the dict fun;
732 mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta
733 = mkVanillaGlobal dfun_name dfun_ty noCafNoTyGenIdInfo
735 dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
737 {- 1 dec 99: disable the Mark Jones optimisation for the sake
738 of compatibility with Hugs.
739 See `types/InstEnv' for a discussion related to this.
741 (class_tyvars, sc_theta, _, _) = classBigSig clas
742 not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
743 sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
744 dfun_theta = case inst_decl_theta of
745 [] -> [] -- If inst_decl_theta is empty, then we don't
746 -- want to have any dict arguments, so that we can
747 -- expose the constant methods.
749 other -> nub (inst_decl_theta ++ filter not_const sc_theta')
750 -- Otherwise we pass the superclass dictionaries to
751 -- the dictionary function; the Mark Jones optimisation.
753 -- NOTE the "nub". I got caught by this one:
754 -- class Monad m => MonadT t m where ...
755 -- instance Monad m => MonadT (EnvT env) m where ...
756 -- Here, the inst_decl_theta has (Monad m); but so
757 -- does the sc_theta'!
759 -- NOTE the "not_const". I got caught by this one too:
760 -- class Foo a => Baz a b where ...
761 -- instance Wob b => Baz T b where..
762 -- Now sc_theta' has Foo T
767 %************************************************************************
769 \subsection{Un-definable}
771 %************************************************************************
773 These Ids can't be defined in Haskell. They could be defined in
774 unfoldings in PrelGHC.hi-boot, but we'd have to ensure that they
775 were definitely, definitely inlined, because there is no curried
776 identifier for them. That's what mkCompulsoryUnfolding does.
777 If we had a way to get a compulsory unfolding from an interface file,
778 we could do that, but we don't right now.
780 unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
781 just gets expanded into a type coercion wherever it occurs. Hence we
782 add it as a built-in Id with an unfolding here.
784 The type variables we use here are "open" type variables: this means
785 they can unify with both unlifted and lifted types. Hence we provide
786 another gun with which to shoot yourself in the foot.
789 -- unsafeCoerce# :: forall a b. a -> b
791 = pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info
793 info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
796 ty = mkForAllTys [openAlphaTyVar,openBetaTyVar]
797 (mkFunTy openAlphaTy openBetaTy)
798 [x] = mkTemplateLocals [openAlphaTy]
799 rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
800 Note (Coerce openBetaTy openAlphaTy) (Var x)
802 -- nullAddr# :: Addr#
803 -- The reason is is here is because we don't provide
804 -- a way to write this literal in Haskell.
806 = pcMiscPrelId nullAddrIdKey pREL_GHC SLIT("nullAddr#") addrPrimTy info
808 info = noCafNoTyGenIdInfo `setUnfoldingInfo`
809 mkCompulsoryUnfolding (Lit nullAddrLit)
812 = pcMiscPrelId seqIdKey pREL_GHC SLIT("seq") ty info
814 info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
817 ty = mkForAllTys [alphaTyVar,betaTyVar]
818 (mkFunTy alphaTy (mkFunTy betaTy betaTy))
819 [x,y] = mkTemplateLocals [alphaTy, betaTy]
820 rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x [(DEFAULT, [], Var y)])
823 @getTag#@ is another function which can't be defined in Haskell. It needs to
824 evaluate its argument and call the dataToTag# primitive.
828 = pcMiscPrelId getTagIdKey pREL_GHC SLIT("getTag#") ty info
830 info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
831 -- We don't provide a defn for this; you must inline it
833 ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy intPrimTy)
834 [x,y] = mkTemplateLocals [alphaTy,alphaTy]
835 rhs = mkLams [alphaTyVar,x] $
836 Case (Var x) y [ (DEFAULT, [], mkApps (Var dataToTagId) [Type alphaTy, Var y]) ]
838 dataToTagId = mkPrimOpId DataToTagOp
841 @realWorld#@ used to be a magic literal, \tr{void#}. If things get
842 nasty as-is, change it back to a literal (@Literal@).
844 voidArgId is a Local Id used simply as an argument in functions
845 where we just want an arg to avoid having a thunk of unlifted type.
847 x = \ void :: State# RealWorld -> (# p, q #)
849 This comes up in strictness analysis
852 realWorldPrimId -- :: State# RealWorld
853 = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#")
855 (noCafNoTyGenIdInfo `setUnfoldingInfo` mkOtherCon [])
856 -- The mkOtherCon makes it look that realWorld# is evaluated
857 -- which in turn makes Simplify.interestingArg return True,
858 -- which in turn makes INLINE things applied to realWorld# likely
861 voidArgId -- :: State# RealWorld
862 = mkSysLocal SLIT("void") voidArgIdKey realWorldStatePrimTy
866 %************************************************************************
868 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
870 %************************************************************************
872 GHC randomly injects these into the code.
874 @patError@ is just a version of @error@ for pattern-matching
875 failures. It knows various ``codes'' which expand to longer
876 strings---this saves space!
878 @absentErr@ is a thing we put in for ``absent'' arguments. They jolly
879 well shouldn't be yanked on, but if one is, then you will get a
880 friendly message from @absentErr@ (rather than a totally random
883 @parError@ is a special version of @error@ which the compiler does
884 not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
885 templates, but we don't ever expect to generate code for it.
889 = pc_bottoming_Id errorIdKey pREL_ERR SLIT("error") errorTy
891 = pc_bottoming_Id errorCStringIdKey pREL_ERR SLIT("errorCString")
892 (mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy))
894 = generic_ERROR_ID patErrorIdKey SLIT("patError")
896 = generic_ERROR_ID recSelErrIdKey SLIT("recSelError")
898 = generic_ERROR_ID recConErrorIdKey SLIT("recConError")
900 = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError")
902 = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
903 nON_EXHAUSTIVE_GUARDS_ERROR_ID
904 = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError")
905 nO_METHOD_BINDING_ERROR_ID
906 = generic_ERROR_ID noMethodBindingErrorIdKey SLIT("noMethodBindingError")
909 = pc_bottoming_Id absentErrorIdKey pREL_ERR SLIT("absentErr")
910 (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
913 = pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError")
914 (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafNoTyGenIdInfo
918 %************************************************************************
920 \subsection{Utilities}
922 %************************************************************************
925 pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
926 pcMiscPrelId key mod str ty info
928 name = mkWiredInName mod (mkVarOcc str) key
929 imp = mkVanillaGlobal name ty info -- the usual case...
932 -- We lie and say the thing is imported; otherwise, we get into
933 -- a mess with dependency analysis; e.g., core2stg may heave in
934 -- random calls to GHCbase.unpackPS__. If GHCbase is the module
935 -- being compiled, then it's just a matter of luck if the definition
936 -- will be in "the right place" to be in scope.
938 pc_bottoming_Id key mod name ty
939 = pcMiscPrelId key mod name ty bottoming_info
941 strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
942 bottoming_info = noCafNoTyGenIdInfo `setAllStrictnessInfo` Just strict_sig
943 -- these "bottom" out, no matter what their arguments
945 generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy
947 (openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars
948 openAlphaTy = mkTyVarTy openAlphaTyVar
949 openBetaTy = mkTyVarTy openBetaTyVar
952 errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy]
954 -- Notice the openAlphaTyVar. It says that "error" can be applied
955 -- to unboxed as well as boxed types. This is OK because it never
956 -- returns, so the return type is irrelevant.