Update Trac ticket URLs to point to GitLab
[ghc.git] / compiler / basicTypes / MkId.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The AQUA Project, Glasgow University, 1998
4
5
6 This module contains definitions for the IdInfo for things that
7 have a standard form, namely:
8
9 - data constructors
10 - record selectors
11 - method and superclass selectors
12 - primitive operations
13 -}
14
15 {-# LANGUAGE CPP #-}
16
17 module MkId (
18 mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs,
19
20 mkPrimOpId, mkFCallId,
21
22 unwrapNewTypeBody, wrapFamInstBody,
23 DataConBoxer(..), mkDataConRep, mkDataConWorkId,
24
25 -- And some particular Ids; see below for why they are wired in
26 wiredInIds, ghcPrimIds,
27 unsafeCoerceName, unsafeCoerceId, realWorldPrimId,
28 voidPrimId, voidArgId,
29 nullAddrId, seqId, lazyId, lazyIdKey,
30 coercionTokenId, magicDictId, coerceId,
31 proxyHashId, noinlineId, noinlineIdName,
32
33 -- Re-export error Ids
34 module PrelRules
35 ) where
36
37 #include "HsVersions.h"
38
39 import GhcPrelude
40
41 import Rules
42 import TysPrim
43 import TysWiredIn
44 import PrelRules
45 import Type
46 import FamInstEnv
47 import Coercion
48 import TcType
49 import MkCore
50 import CoreUtils ( exprType, mkCast )
51 import CoreUnfold
52 import Literal
53 import TyCon
54 import Class
55 import NameSet
56 import Name
57 import PrimOp
58 import ForeignCall
59 import DataCon
60 import Id
61 import IdInfo
62 import Demand
63 import CoreSyn
64 import Unique
65 import UniqSupply
66 import PrelNames
67 import BasicTypes hiding ( SuccessFlag(..) )
68 import Util
69 import Pair
70 import DynFlags
71 import Outputable
72 import FastString
73 import ListSetOps
74 import qualified GHC.LanguageExtensions as LangExt
75
76 import Data.Maybe ( maybeToList )
77
78 {-
79 ************************************************************************
80 * *
81 \subsection{Wired in Ids}
82 * *
83 ************************************************************************
84
85 Note [Wired-in Ids]
86 ~~~~~~~~~~~~~~~~~~~
87 A "wired-in" Id can be referred to directly in GHC (e.g. 'voidPrimId')
88 rather than by looking it up its name in some environment or fetching
89 it from an interface file.
90
91 There are several reasons why an Id might appear in the wiredInIds:
92
93 * ghcPrimIds: see Note [ghcPrimIds (aka pseudoops)]
94
95 * magicIds: see Note [magicIds]
96
97 * errorIds, defined in coreSyn/MkCore.hs.
98 These error functions (e.g. rUNTIME_ERROR_ID) are wired in
99 because the desugarer generates code that mentions them directly
100
101 In all cases except ghcPrimIds, there is a definition site in a
102 library module, which may be called (e.g. in higher order situations);
103 but the wired-in version means that the details are never read from
104 that module's interface file; instead, the full definition is right
105 here.
106
107 Note [ghcPrimIds (aka pseudoops)]
108 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
109 The ghcPrimIds
110
111 * Are exported from GHC.Prim
112
113 * Can't be defined in Haskell, and hence no Haskell binding site,
114 but have perfectly reasonable unfoldings in Core
115
116 * Either have a CompulsoryUnfolding (hence always inlined), or
117 of an EvaldUnfolding and void representation (e.g. void#)
118
119 * Are (or should be) defined in primops.txt.pp as 'pseudoop'
120 Reason: that's how we generate documentation for them
121
122 Note [magicIds]
123 ~~~~~~~~~~~~~~~
124 The magicIds
125
126 * Are exported from GHC.Magic
127
128 * Can be defined in Haskell (and are, in ghc-prim:GHC/Magic.hs).
129 This definition at least generates Haddock documentation for them.
130
131 * May or may not have a CompulsoryUnfolding.
132
133 * But have some special behaviour that can't be done via an
134 unfolding from an interface file
135 -}
136
137 wiredInIds :: [Id]
138 wiredInIds
139 = magicIds
140 ++ ghcPrimIds
141 ++ errorIds -- Defined in MkCore
142
143 magicIds :: [Id] -- See Note [magicIds]
144 magicIds = [lazyId, oneShotId, noinlineId]
145
146 ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)]
147 ghcPrimIds
148 = [ realWorldPrimId
149 , voidPrimId
150 , unsafeCoerceId
151 , nullAddrId
152 , seqId
153 , magicDictId
154 , coerceId
155 , proxyHashId
156 ]
157
158 {-
159 ************************************************************************
160 * *
161 \subsection{Data constructors}
162 * *
163 ************************************************************************
164
165 The wrapper for a constructor is an ordinary top-level binding that evaluates
166 any strict args, unboxes any args that are going to be flattened, and calls
167 the worker.
168
169 We're going to build a constructor that looks like:
170
171 data (Data a, C b) => T a b = T1 !a !Int b
172
173 T1 = /\ a b ->
174 \d1::Data a, d2::C b ->
175 \p q r -> case p of { p ->
176 case q of { q ->
177 Con T1 [a,b] [p,q,r]}}
178
179 Notice that
180
181 * d2 is thrown away --- a context in a data decl is used to make sure
182 one *could* construct dictionaries at the site the constructor
183 is used, but the dictionary isn't actually used.
184
185 * We have to check that we can construct Data dictionaries for
186 the types a and Int. Once we've done that we can throw d1 away too.
187
188 * We use (case p of q -> ...) to evaluate p, rather than "seq" because
189 all that matters is that the arguments are evaluated. "seq" is
190 very careful to preserve evaluation order, which we don't need
191 to be here.
192
193 You might think that we could simply give constructors some strictness
194 info, like PrimOps, and let CoreToStg do the let-to-case transformation.
195 But we don't do that because in the case of primops and functions strictness
196 is a *property* not a *requirement*. In the case of constructors we need to
197 do something active to evaluate the argument.
198
199 Making an explicit case expression allows the simplifier to eliminate
200 it in the (common) case where the constructor arg is already evaluated.
201
202 Note [Wrappers for data instance tycons]
203 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
204 In the case of data instances, the wrapper also applies the coercion turning
205 the representation type into the family instance type to cast the result of
206 the wrapper. For example, consider the declarations
207
208 data family Map k :: * -> *
209 data instance Map (a, b) v = MapPair (Map a (Pair b v))
210
211 The tycon to which the datacon MapPair belongs gets a unique internal
212 name of the form :R123Map, and we call it the representation tycon.
213 In contrast, Map is the family tycon (accessible via
214 tyConFamInst_maybe). A coercion allows you to move between
215 representation and family type. It is accessible from :R123Map via
216 tyConFamilyCoercion_maybe and has kind
217
218 Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v}
219
220 The wrapper and worker of MapPair get the types
221
222 -- Wrapper
223 $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v
224 $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v)
225
226 -- Worker
227 MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v
228
229 This coercion is conditionally applied by wrapFamInstBody.
230
231 It's a bit more complicated if the data instance is a GADT as well!
232
233 data instance T [a] where
234 T1 :: forall b. b -> T [Maybe b]
235
236 Hence we translate to
237
238 -- Wrapper
239 $WT1 :: forall b. b -> T [Maybe b]
240 $WT1 b v = T1 (Maybe b) b (Maybe b) v
241 `cast` sym (Co7T (Maybe b))
242
243 -- Worker
244 T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c
245
246 -- Coercion from family type to representation type
247 Co7T a :: T [a] ~ :R7T a
248
249 Newtype instances through an additional wrinkle into the mix. Consider the
250 following example (adapted from #15318, comment:2):
251
252 data family T a
253 newtype instance T [a] = MkT [a]
254
255 Within the newtype instance, there are three distinct types at play:
256
257 1. The newtype's underlying type, [a].
258 2. The instance's representation type, TList a (where TList is the
259 representation tycon).
260 3. The family type, T [a].
261
262 We need two coercions in order to cast from (1) to (3):
263
264 (a) A newtype coercion axiom:
265
266 axiom coTList a :: TList a ~ [a]
267
268 (Where TList is the representation tycon of the newtype instance.)
269
270 (b) A data family instance coercion axiom:
271
272 axiom coT a :: T [a] ~ TList a
273
274 When we translate the newtype instance to Core, we obtain:
275
276 -- Wrapper
277 $WMkT :: forall a. [a] -> T [a]
278 $WMkT a x = MkT a x |> Sym (coT a)
279
280 -- Worker
281 MkT :: forall a. [a] -> TList [a]
282 MkT a x = x |> Sym (coTList a)
283
284 Unlike for data instances, the worker for a newtype instance is actually an
285 executable function which expands to a cast, but otherwise, the general
286 strategy is essentially the same as for data instances. Also note that we have
287 a wrapper, which is unusual for a newtype, but we make GHC produce one anyway
288 for symmetry with the way data instances are handled.
289
290 Note [Newtype datacons]
291 ~~~~~~~~~~~~~~~~~~~~~~~
292 The "data constructor" for a newtype should always be vanilla. At one
293 point this wasn't true, because the newtype arising from
294 class C a => D a
295 looked like
296 newtype T:D a = D:D (C a)
297 so the data constructor for T:C had a single argument, namely the
298 predicate (C a). But now we treat that as an ordinary argument, not
299 part of the theta-type, so all is well.
300
301 Note [Compulsory newtype unfolding]
302 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
303 Newtype wrappers, just like workers, have compulsory unfoldings.
304 This is needed so that two optimizations involving newtypes have the same
305 effect whether a wrapper is present or not:
306
307 (1) Case-of-known constructor.
308 See Note [beta-reduction in exprIsConApp_maybe].
309
310 (2) Matching against the map/coerce RULE. Suppose we have the RULE
311
312 {-# RULE "map/coerce" map coerce = ... #-}
313
314 As described in Note [Getting the map/coerce RULE to work],
315 the occurrence of 'coerce' is transformed into:
316
317 {-# RULE "map/coerce" forall (c :: T1 ~R# T2).
318 map ((\v -> v) `cast` c) = ... #-}
319
320 We'd like 'map Age' to match the LHS. For this to happen, Age
321 must be unfolded, otherwise we'll be stuck. This is tested in T16208.
322
323 ************************************************************************
324 * *
325 \subsection{Dictionary selectors}
326 * *
327 ************************************************************************
328
329 Selecting a field for a dictionary. If there is just one field, then
330 there's nothing to do.
331
332 Dictionary selectors may get nested forall-types. Thus:
333
334 class Foo a where
335 op :: forall b. Ord b => a -> b -> b
336
337 Then the top-level type for op is
338
339 op :: forall a. Foo a =>
340 forall b. Ord b =>
341 a -> b -> b
342
343 -}
344
345 mkDictSelId :: Name -- Name of one of the *value* selectors
346 -- (dictionary superclass or method)
347 -> Class -> Id
348 mkDictSelId name clas
349 = mkGlobalId (ClassOpId clas) name sel_ty info
350 where
351 tycon = classTyCon clas
352 sel_names = map idName (classAllSelIds clas)
353 new_tycon = isNewTyCon tycon
354 [data_con] = tyConDataCons tycon
355 tyvars = dataConUserTyVarBinders data_con
356 n_ty_args = length tyvars
357 arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses
358 val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name
359
360 sel_ty = mkForAllTys tyvars $
361 mkInvisFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $
362 getNth arg_tys val_index
363
364 base_info = noCafIdInfo
365 `setArityInfo` 1
366 `setStrictnessInfo` strict_sig
367 `setLevityInfoWithType` sel_ty
368
369 info | new_tycon
370 = base_info `setInlinePragInfo` alwaysInlinePragma
371 `setUnfoldingInfo` mkInlineUnfoldingWithArity 1
372 (mkDictSelRhs clas val_index)
373 -- See Note [Single-method classes] in TcInstDcls
374 -- for why alwaysInlinePragma
375
376 | otherwise
377 = base_info `setRuleInfo` mkRuleInfo [rule]
378 -- Add a magic BuiltinRule, but no unfolding
379 -- so that the rule is always available to fire.
380 -- See Note [ClassOp/DFun selection] in TcInstDcls
381
382 -- This is the built-in rule that goes
383 -- op (dfT d1 d2) ---> opT d1 d2
384 rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS`
385 occNameFS (getOccName name)
386 , ru_fn = name
387 , ru_nargs = n_ty_args + 1
388 , ru_try = dictSelRule val_index n_ty_args }
389
390 -- The strictness signature is of the form U(AAAVAAAA) -> T
391 -- where the V depends on which item we are selecting
392 -- It's worth giving one, so that absence info etc is generated
393 -- even if the selector isn't inlined
394
395 strict_sig = mkClosedStrictSig [arg_dmd] topRes
396 arg_dmd | new_tycon = evalDmd
397 | otherwise = mkManyUsedDmd $
398 mkProdDmd [ if name == sel_name then evalDmd else absDmd
399 | sel_name <- sel_names ]
400
401 mkDictSelRhs :: Class
402 -> Int -- 0-indexed selector among (superclasses ++ methods)
403 -> CoreExpr
404 mkDictSelRhs clas val_index
405 = mkLams tyvars (Lam dict_id rhs_body)
406 where
407 tycon = classTyCon clas
408 new_tycon = isNewTyCon tycon
409 [data_con] = tyConDataCons tycon
410 tyvars = dataConUnivTyVars data_con
411 arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses
412
413 the_arg_id = getNth arg_ids val_index
414 pred = mkClassPred clas (mkTyVarTys tyvars)
415 dict_id = mkTemplateLocal 1 pred
416 arg_ids = mkTemplateLocalsNum 2 arg_tys
417
418 rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars)
419 (Var dict_id)
420 | otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
421 [(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)]
422 -- varToCoreExpr needed for equality superclass selectors
423 -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }
424
425 dictSelRule :: Int -> Arity -> RuleFun
426 -- Tries to persuade the argument to look like a constructor
427 -- application, using exprIsConApp_maybe, and then selects
428 -- from it
429 -- sel_i t1..tk (D t1..tk op1 ... opm) = opi
430 --
431 dictSelRule val_index n_ty_args _ id_unf _ args
432 | (dict_arg : _) <- drop n_ty_args args
433 , Just (_, floats, _, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
434 = Just (wrapFloats floats $ getNth con_args val_index)
435 | otherwise
436 = Nothing
437
438 {-
439 ************************************************************************
440 * *
441 Data constructors
442 * *
443 ************************************************************************
444 -}
445
446 mkDataConWorkId :: Name -> DataCon -> Id
447 mkDataConWorkId wkr_name data_con
448 | isNewTyCon tycon
449 = mkGlobalId (DataConWrapId data_con) wkr_name wkr_ty nt_work_info
450 | otherwise
451 = mkGlobalId (DataConWorkId data_con) wkr_name wkr_ty alg_wkr_info
452
453 where
454 tycon = dataConTyCon data_con -- The representation TyCon
455 wkr_ty = dataConRepType data_con
456
457 ----------- Workers for data types --------------
458 alg_wkr_info = noCafIdInfo
459 `setArityInfo` wkr_arity
460 `setStrictnessInfo` wkr_sig
461 `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
462 -- even if arity = 0
463 `setLevityInfoWithType` wkr_ty
464 -- NB: unboxed tuples have workers, so we can't use
465 -- setNeverLevPoly
466
467 wkr_arity = dataConRepArity data_con
468 wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con)
469 -- Note [Data-con worker strictness]
470 -- Notice that we do *not* say the worker Id is strict
471 -- even if the data constructor is declared strict
472 -- e.g. data T = MkT !(Int,Int)
473 -- Why? Because the *wrapper* $WMkT is strict (and its unfolding has
474 -- case expressions that do the evals) but the *worker* MkT itself is
475 -- not. If we pretend it is strict then when we see
476 -- case x of y -> MkT y
477 -- the simplifier thinks that y is "sure to be evaluated" (because
478 -- the worker MkT is strict) and drops the case. No, the workerId
479 -- MkT is not strict.
480 --
481 -- However, the worker does have StrictnessMarks. When the simplifier
482 -- sees a pattern
483 -- case e of MkT x -> ...
484 -- it uses the dataConRepStrictness of MkT to mark x as evaluated;
485 -- but that's fine... dataConRepStrictness comes from the data con
486 -- not from the worker Id.
487
488 ----------- Workers for newtypes --------------
489 univ_tvs = dataConUnivTyVars data_con
490 arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys
491 nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
492 `setArityInfo` 1 -- Arity 1
493 `setInlinePragInfo` alwaysInlinePragma
494 `setUnfoldingInfo` newtype_unf
495 `setLevityInfoWithType` wkr_ty
496 id_arg1 = mkTemplateLocal 1 (head arg_tys)
497 res_ty_args = mkTyCoVarTys univ_tvs
498 newtype_unf = ASSERT2( isVanillaDataCon data_con &&
499 isSingleton arg_tys
500 , ppr data_con )
501 -- Note [Newtype datacons]
502 mkCompulsoryUnfolding $
503 mkLams univ_tvs $ Lam id_arg1 $
504 wrapNewTypeBody tycon res_ty_args (Var id_arg1)
505
506 dataConCPR :: DataCon -> DmdResult
507 dataConCPR con
508 | isDataTyCon tycon -- Real data types only; that is,
509 -- not unboxed tuples or newtypes
510 , null (dataConExTyCoVars con) -- No existentials
511 , wkr_arity > 0
512 , wkr_arity <= mAX_CPR_SIZE
513 = if is_prod then vanillaCprProdRes (dataConRepArity con)
514 else cprSumRes (dataConTag con)
515 | otherwise
516 = topRes
517 where
518 is_prod = isProductTyCon tycon
519 tycon = dataConTyCon con
520 wkr_arity = dataConRepArity con
521
522 mAX_CPR_SIZE :: Arity
523 mAX_CPR_SIZE = 10
524 -- We do not treat very big tuples as CPR-ish:
525 -- a) for a start we get into trouble because there aren't
526 -- "enough" unboxed tuple types (a tiresome restriction,
527 -- but hard to fix),
528 -- b) more importantly, big unboxed tuples get returned mainly
529 -- on the stack, and are often then allocated in the heap
530 -- by the caller. So doing CPR for them may in fact make
531 -- things worse.
532
533 {-
534 -------------------------------------------------
535 -- Data constructor representation
536 --
537 -- This is where we decide how to wrap/unwrap the
538 -- constructor fields
539 --
540 --------------------------------------------------
541 -}
542
543 type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr)
544 -- Unbox: bind rep vars by decomposing src var
545
546 data Boxer = UnitBox | Boxer (TCvSubst -> UniqSM ([Var], CoreExpr))
547 -- Box: build src arg using these rep vars
548
549 -- | Data Constructor Boxer
550 newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))
551 -- Bind these src-level vars, returning the
552 -- rep-level vars to bind in the pattern
553
554 {-
555 Note [Inline partially-applied constructor wrappers]
556 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
557
558 We allow the wrapper to inline when partially applied to avoid
559 boxing values unnecessarily. For example, consider
560
561 data Foo a = Foo !Int a
562
563 instance Traversable Foo where
564 traverse f (Foo i a) = Foo i <$> f a
565
566 This desugars to
567
568 traverse f foo = case foo of
569 Foo i# a -> let i = I# i#
570 in map ($WFoo i) (f a)
571
572 If the wrapper `$WFoo` is not inlined, we get a fruitless reboxing of `i`.
573 But if we inline the wrapper, we get
574
575 map (\a. case i of I# i# a -> Foo i# a) (f a)
576
577 and now case-of-known-constructor eliminates the redundant allocation.
578 -}
579
580 mkDataConRep :: DynFlags
581 -> FamInstEnvs
582 -> Name
583 -> Maybe [HsImplBang]
584 -- See Note [Bangs on imported data constructors]
585 -> DataCon
586 -> UniqSM DataConRep
587 mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
588 | not wrapper_reqd
589 = return NoDataConRep
590
591 | otherwise
592 = do { wrap_args <- mapM newLocal wrap_arg_tys
593 ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers)
594 initial_wrap_app
595
596 ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info
597 wrap_info = noCafIdInfo
598 `setArityInfo` wrap_arity
599 -- It's important to specify the arity, so that partial
600 -- applications are treated as values
601 `setInlinePragInfo` wrap_prag
602 `setUnfoldingInfo` wrap_unf
603 `setStrictnessInfo` wrap_sig
604 -- We need to get the CAF info right here because TidyPgm
605 -- does not tidy the IdInfo of implicit bindings (like the wrapper)
606 -- so it not make sure that the CAF info is sane
607 `setNeverLevPoly` wrap_ty
608
609 wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
610
611 wrap_arg_dmds =
612 replicate (length theta) topDmd ++ map mk_dmd arg_ibangs
613 -- Don't forget the dictionary arguments when building
614 -- the strictness signature (#14290).
615
616 mk_dmd str | isBanged str = evalDmd
617 | otherwise = topDmd
618
619 wrap_prag = alwaysInlinePragma `setInlinePragmaActivation`
620 activeDuringFinal
621 -- See Note [Activation for data constructor wrappers]
622
623 -- The wrapper will usually be inlined (see wrap_unf), so its
624 -- strictness and CPR info is usually irrelevant. But this is
625 -- not always the case; GHC may choose not to inline it. In
626 -- particular, the wrapper constructor is not inlined inside
627 -- an INLINE rhs or when it is not applied to any arguments.
628 -- See Note [Inline partially-applied constructor wrappers]
629 -- Passing Nothing here allows the wrapper to inline when
630 -- unsaturated.
631 wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding wrap_rhs
632 -- See Note [Compulsory newtype unfolding]
633 | otherwise = mkInlineUnfolding wrap_rhs
634 wrap_rhs = mkLams wrap_tvs $
635 mkLams wrap_args $
636 wrapFamInstBody tycon res_ty_args $
637 wrap_body
638
639 ; return (DCR { dcr_wrap_id = wrap_id
640 , dcr_boxer = mk_boxer boxers
641 , dcr_arg_tys = rep_tys
642 , dcr_stricts = rep_strs
643 -- For newtypes, dcr_bangs is always [HsLazy].
644 -- See Note [HsImplBangs for newtypes].
645 , dcr_bangs = arg_ibangs }) }
646
647 where
648 (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty)
649 = dataConFullSig data_con
650 wrap_tvs = dataConUserTyVars data_con
651 res_ty_args = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs
652
653 tycon = dataConTyCon data_con -- The representation TyCon (not family)
654 wrap_ty = dataConUserType data_con
655 ev_tys = eqSpecPreds eq_spec ++ theta
656 all_arg_tys = ev_tys ++ orig_arg_tys
657 ev_ibangs = map (const HsLazy) ev_tys
658 orig_bangs = dataConSrcBangs data_con
659
660 wrap_arg_tys = theta ++ orig_arg_tys
661 wrap_arity = count isCoVar ex_tvs + length wrap_arg_tys
662 -- The wrap_args are the arguments *other than* the eq_spec
663 -- Because we are going to apply the eq_spec args manually in the
664 -- wrapper
665
666 new_tycon = isNewTyCon tycon
667 arg_ibangs
668 | new_tycon
669 = ASSERT( isSingleton orig_arg_tys )
670 [HsLazy] -- See Note [HsImplBangs for newtypes]
671 | otherwise
672 = case mb_bangs of
673 Nothing -> zipWith (dataConSrcToImplBang dflags fam_envs)
674 orig_arg_tys orig_bangs
675 Just bangs -> bangs
676
677 (rep_tys_w_strs, wrappers)
678 = unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs))
679
680 (unboxers, boxers) = unzip wrappers
681 (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)
682
683 wrapper_reqd =
684 (not new_tycon
685 -- (Most) newtypes have only a worker, with the exception
686 -- of some newtypes written with GADT syntax. See below.
687 && (any isBanged (ev_ibangs ++ arg_ibangs)
688 -- Some forcing/unboxing (includes eq_spec)
689 || (not $ null eq_spec))) -- GADT
690 || isFamInstTyCon tycon -- Cast result
691 || dataConUserTyVarsArePermuted data_con
692 -- If the data type was written with GADT syntax and
693 -- orders the type variables differently from what the
694 -- worker expects, it needs a data con wrapper to reorder
695 -- the type variables.
696 -- See Note [Data con wrappers and GADT syntax].
697
698 initial_wrap_app = Var (dataConWorkId data_con)
699 `mkTyApps` res_ty_args
700 `mkVarApps` ex_tvs
701 `mkCoApps` map (mkReflCo Nominal . eqSpecType) eq_spec
702
703 mk_boxer :: [Boxer] -> DataConBoxer
704 mk_boxer boxers = DCB (\ ty_args src_vars ->
705 do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars
706 subst1 = zipTvSubst univ_tvs ty_args
707 subst2 = extendTCvSubstList subst1 ex_tvs
708 (mkTyCoVarTys ex_vars)
709 ; (rep_ids, binds) <- go subst2 boxers term_vars
710 ; return (ex_vars ++ rep_ids, binds) } )
711
712 go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], [])
713 go subst (UnitBox : boxers) (src_var : src_vars)
714 = do { (rep_ids2, binds) <- go subst boxers src_vars
715 ; return (src_var : rep_ids2, binds) }
716 go subst (Boxer boxer : boxers) (src_var : src_vars)
717 = do { (rep_ids1, arg) <- boxer subst
718 ; (rep_ids2, binds) <- go subst boxers src_vars
719 ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) }
720 go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con)
721
722 mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr
723 mk_rep_app [] con_app
724 = return con_app
725 mk_rep_app ((wrap_arg, unboxer) : prs) con_app
726 = do { (rep_ids, unbox_fn) <- unboxer wrap_arg
727 ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids)
728 ; return (unbox_fn expr) }
729
730 {- Note [Activation for data constructor wrappers]
731 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
732 The Activation on a data constructor wrapper allows it to inline only in Phase
733 0. This way rules have a chance to fire if they mention a data constructor on
734 the left
735 RULE "foo" f (K a b) = ...
736 Since the LHS of rules are simplified with InitialPhase, we won't
737 inline the wrapper on the LHS either.
738
739 On the other hand, this means that exprIsConApp_maybe must be able to deal
740 with wrappers so that case-of-constructor is not delayed; see
741 Note [exprIsConApp_maybe on data constructors with wrappers] for details.
742
743 It used to activate in phases 2 (afterInitial) and later, but it makes it
744 awkward to write a RULE[1] with a constructor on the left: it would work if a
745 constructor has no wrapper, but whether a constructor has a wrapper depends, for
746 instance, on the order of type argument of that constructors. Therefore changing
747 the order of type argument could make previously working RULEs fail.
748
749 See also https://gitlab.haskell.org/ghc/ghc/issues/15840 .
750
751
752 Note [Bangs on imported data constructors]
753 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
754
755 We pass Maybe [HsImplBang] to mkDataConRep to make use of HsImplBangs
756 from imported modules.
757
758 - Nothing <=> use HsSrcBangs
759 - Just bangs <=> use HsImplBangs
760
761 For imported types we can't work it all out from the HsSrcBangs,
762 because we want to be very sure to follow what the original module
763 (where the data type was declared) decided, and that depends on what
764 flags were enabled when it was compiled. So we record the decisions in
765 the interface file.
766
767 The HsImplBangs passed are in 1-1 correspondence with the
768 dataConOrigArgTys of the DataCon.
769
770 Note [Data con wrappers and unlifted types]
771 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
772 Consider
773 data T = MkT !Int#
774
775 We certainly do not want to make a wrapper
776 $WMkT x = case x of y { DEFAULT -> MkT y }
777
778 For a start, it's still to generate a no-op. But worse, since wrappers
779 are currently injected at TidyCore, we don't even optimise it away!
780 So the stupid case expression stays there. This actually happened for
781 the Integer data type (see #1600 comment:66)!
782
783 Note [Data con wrappers and GADT syntax]
784 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
785 Consider these two very similar data types:
786
787 data T1 a b = MkT1 b
788
789 data T2 a b where
790 MkT2 :: forall b a. b -> T2 a b
791
792 Despite their similar appearance, T2 will have a data con wrapper but T1 will
793 not. What sets them apart? The types of their constructors, which are:
794
795 MkT1 :: forall a b. b -> T1 a b
796 MkT2 :: forall b a. b -> T2 a b
797
798 MkT2's use of GADT syntax allows it to permute the order in which `a` and `b`
799 would normally appear. See Note [DataCon user type variable binders] in DataCon
800 for further discussion on this topic.
801
802 The worker data cons for T1 and T2, however, both have types such that `a` is
803 expected to come before `b` as arguments. Because MkT2 permutes this order, it
804 needs a data con wrapper to swizzle around the type variables to be in the
805 order the worker expects.
806
807 A somewhat surprising consequence of this is that *newtypes* can have data con
808 wrappers! After all, a newtype can also be written with GADT syntax:
809
810 newtype T3 a b where
811 MkT3 :: forall b a. b -> T3 a b
812
813 Again, this needs a wrapper data con to reorder the type variables. It does
814 mean that this newtype constructor requires another level of indirection when
815 being called, but the inliner should make swift work of that.
816
817 Note [HsImplBangs for newtypes]
818 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
819 Most of the time, we use the dataConSrctoImplBang function to decide what
820 strictness/unpackedness to use for the fields of a data type constructor. But
821 there is an exception to this rule: newtype constructors. You might not think
822 that newtypes would pose a challenge, since newtypes are seemingly forbidden
823 from having strictness annotations in the first place. But consider this
824 (from #16141):
825
826 {-# LANGUAGE StrictData #-}
827 {-# OPTIONS_GHC -O #-}
828 newtype T a b where
829 MkT :: forall b a. Int -> T a b
830
831 Because StrictData (plus optimization) is enabled, invoking
832 dataConSrcToImplBang would sneak in and unpack the field of type Int to Int#!
833 This would be disastrous, since the wrapper for `MkT` uses a coercion involving
834 Int, not Int#.
835
836 Bottom line: dataConSrcToImplBang should never be invoked for newtypes. In the
837 case of a newtype constructor, we simply hardcode its dcr_bangs field to
838 [HsLazy].
839 -}
840
841 -------------------------
842 newLocal :: Type -> UniqSM Var
843 newLocal ty = do { uniq <- getUniqueM
844 ; return (mkSysLocalOrCoVar (fsLit "dt") uniq ty) }
845
846 -- | Unpack/Strictness decisions from source module.
847 --
848 -- This function should only ever be invoked for data constructor fields, and
849 -- never on the field of a newtype constructor.
850 -- See @Note [HsImplBangs for newtypes]@.
851 dataConSrcToImplBang
852 :: DynFlags
853 -> FamInstEnvs
854 -> Type
855 -> HsSrcBang
856 -> HsImplBang
857
858 dataConSrcToImplBang dflags fam_envs arg_ty
859 (HsSrcBang ann unpk NoSrcStrict)
860 | xopt LangExt.StrictData dflags -- StrictData => strict field
861 = dataConSrcToImplBang dflags fam_envs arg_ty
862 (HsSrcBang ann unpk SrcStrict)
863 | otherwise -- no StrictData => lazy field
864 = HsLazy
865
866 dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy)
867 = HsLazy
868
869 dataConSrcToImplBang dflags fam_envs arg_ty
870 (HsSrcBang _ unpk_prag SrcStrict)
871 | isUnliftedType arg_ty
872 = HsLazy -- For !Int#, say, use HsLazy
873 -- See Note [Data con wrappers and unlifted types]
874
875 | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
876 -- Don't unpack if we aren't optimising; rather arbitrarily,
877 -- we use -fomit-iface-pragmas as the indication
878 , let mb_co = topNormaliseType_maybe fam_envs arg_ty
879 -- Unwrap type families and newtypes
880 arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }
881 , isUnpackableType dflags fam_envs arg_ty'
882 , (rep_tys, _) <- dataConArgUnpack arg_ty'
883 , case unpk_prag of
884 NoSrcUnpack ->
885 gopt Opt_UnboxStrictFields dflags
886 || (gopt Opt_UnboxSmallStrictFields dflags
887 && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields]
888 srcUnpack -> isSrcUnpacked srcUnpack
889 = case mb_co of
890 Nothing -> HsUnpack Nothing
891 Just (co,_) -> HsUnpack (Just co)
892
893 | otherwise -- Record the strict-but-no-unpack decision
894 = HsStrict
895
896
897 -- | Wrappers/Workers and representation following Unpack/Strictness
898 -- decisions
899 dataConArgRep
900 :: Type
901 -> HsImplBang
902 -> ([(Type,StrictnessMark)] -- Rep types
903 ,(Unboxer,Boxer))
904
905 dataConArgRep arg_ty HsLazy
906 = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
907
908 dataConArgRep arg_ty HsStrict
909 = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))
910
911 dataConArgRep arg_ty (HsUnpack Nothing)
912 | (rep_tys, wrappers) <- dataConArgUnpack arg_ty
913 = (rep_tys, wrappers)
914
915 dataConArgRep _ (HsUnpack (Just co))
916 | let co_rep_ty = pSnd (coercionKind co)
917 , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty
918 = (rep_tys, wrapCo co co_rep_ty wrappers)
919
920
921 -------------------------
922 wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer)
923 wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty
924 = (unboxer, boxer)
925 where
926 unboxer arg_id = do { rep_id <- newLocal rep_ty
927 ; (rep_ids, rep_fn) <- unbox_rep rep_id
928 ; let co_bind = NonRec rep_id (Var arg_id `Cast` co)
929 ; return (rep_ids, Let co_bind . rep_fn) }
930 boxer = Boxer $ \ subst ->
931 do { (rep_ids, rep_expr)
932 <- case box_rep of
933 UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty)
934 ; return ([rep_id], Var rep_id) }
935 Boxer boxer -> boxer subst
936 ; let sco = substCoUnchecked subst co
937 ; return (rep_ids, rep_expr `Cast` mkSymCo sco) }
938
939 ------------------------
940 seqUnboxer :: Unboxer
941 seqUnboxer v = return ([v], \e -> Case (Var v) v (exprType e) [(DEFAULT, [], e)])
942
943 unitUnboxer :: Unboxer
944 unitUnboxer v = return ([v], \e -> e)
945
946 unitBoxer :: Boxer
947 unitBoxer = UnitBox
948
949 -------------------------
950 dataConArgUnpack
951 :: Type
952 -> ( [(Type, StrictnessMark)] -- Rep types
953 , (Unboxer, Boxer) )
954
955 dataConArgUnpack arg_ty
956 | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty
957 , Just con <- tyConSingleAlgDataCon_maybe tc
958 -- NB: check for an *algebraic* data type
959 -- A recursive newtype might mean that
960 -- 'arg_ty' is a newtype
961 , let rep_tys = dataConInstArgTys con tc_args
962 = ASSERT( null (dataConExTyCoVars con) )
963 -- Note [Unpacking GADTs and existentials]
964 ( rep_tys `zip` dataConRepStrictness con
965 ,( \ arg_id ->
966 do { rep_ids <- mapM newLocal rep_tys
967 ; let unbox_fn body
968 = Case (Var arg_id) arg_id (exprType body)
969 [(DataAlt con, rep_ids, body)]
970 ; return (rep_ids, unbox_fn) }
971 , Boxer $ \ subst ->
972 do { rep_ids <- mapM (newLocal . TcType.substTyUnchecked subst) rep_tys
973 ; return (rep_ids, Var (dataConWorkId con)
974 `mkTyApps` (substTysUnchecked subst tc_args)
975 `mkVarApps` rep_ids ) } ) )
976 | otherwise
977 = pprPanic "dataConArgUnpack" (ppr arg_ty)
978 -- An interface file specified Unpacked, but we couldn't unpack it
979
980 isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool
981 -- True if we can unpack the UNPACK the argument type
982 -- See Note [Recursive unboxing]
983 -- We look "deeply" inside rather than relying on the DataCons
984 -- we encounter on the way, because otherwise we might well
985 -- end up relying on ourselves!
986 isUnpackableType dflags fam_envs ty
987 | Just data_con <- unpackable_type ty
988 = ok_con_args emptyNameSet data_con
989 | otherwise
990 = False
991 where
992 ok_con_args dcs con
993 | dc_name `elemNameSet` dcs
994 = False
995 | otherwise
996 = all (ok_arg dcs')
997 (dataConOrigArgTys con `zip` dataConSrcBangs con)
998 -- NB: dataConSrcBangs gives the *user* request;
999 -- We'd get a black hole if we used dataConImplBangs
1000 where
1001 dc_name = getName con
1002 dcs' = dcs `extendNameSet` dc_name
1003
1004 ok_arg dcs (ty, bang)
1005 = not (attempt_unpack bang) || ok_ty dcs norm_ty
1006 where
1007 norm_ty = topNormaliseType fam_envs ty
1008
1009 ok_ty dcs ty
1010 | Just data_con <- unpackable_type ty
1011 = ok_con_args dcs data_con
1012 | otherwise
1013 = True -- NB True here, in contrast to False at top level
1014
1015 attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict)
1016 = xopt LangExt.StrictData dflags
1017 attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict)
1018 = True
1019 attempt_unpack (HsSrcBang _ NoSrcUnpack SrcStrict)
1020 = True -- Be conservative
1021 attempt_unpack (HsSrcBang _ NoSrcUnpack NoSrcStrict)
1022 = xopt LangExt.StrictData dflags -- Be conservative
1023 attempt_unpack _ = False
1024
1025 unpackable_type :: Type -> Maybe DataCon
1026 -- Works just on a single level
1027 unpackable_type ty
1028 | Just (tc, _) <- splitTyConApp_maybe ty
1029 , Just data_con <- tyConSingleAlgDataCon_maybe tc
1030 , null (dataConExTyCoVars data_con)
1031 -- See Note [Unpacking GADTs and existentials]
1032 = Just data_con
1033 | otherwise
1034 = Nothing
1035
1036 {-
1037 Note [Unpacking GADTs and existentials]
1038 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1039 There is nothing stopping us unpacking a data type with equality
1040 components, like
1041 data Equal a b where
1042 Equal :: Equal a a
1043
1044 And it'd be fine to unpack a product type with existential components
1045 too, but that would require a bit more plumbing, so currently we don't.
1046
1047 So for now we require: null (dataConExTyCoVars data_con)
1048 See #14978
1049
1050 Note [Unpack one-wide fields]
1051 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1052 The flag UnboxSmallStrictFields ensures that any field that can
1053 (safely) be unboxed to a word-sized unboxed field, should be so unboxed.
1054 For example:
1055
1056 data A = A Int#
1057 newtype B = B A
1058 data C = C !B
1059 data D = D !C
1060 data E = E !()
1061 data F = F !D
1062 data G = G !F !F
1063
1064 All of these should have an Int# as their representation, except
1065 G which should have two Int#s.
1066
1067 However
1068
1069 data T = T !(S Int)
1070 data S = S !a
1071
1072 Here we can represent T with an Int#.
1073
1074 Note [Recursive unboxing]
1075 ~~~~~~~~~~~~~~~~~~~~~~~~~
1076 Consider
1077 data R = MkR {-# UNPACK #-} !S Int
1078 data S = MkS {-# UNPACK #-} !Int
1079 The representation arguments of MkR are the *representation* arguments
1080 of S (plus Int); the rep args of MkS are Int#. This is all fine.
1081
1082 But be careful not to try to unbox this!
1083 data T = MkT {-# UNPACK #-} !T Int
1084 Because then we'd get an infinite number of arguments.
1085
1086 Here is a more complicated case:
1087 data S = MkS {-# UNPACK #-} !T Int
1088 data T = MkT {-# UNPACK #-} !S Int
1089 Each of S and T must decide independently whether to unpack
1090 and they had better not both say yes. So they must both say no.
1091
1092 Also behave conservatively when there is no UNPACK pragma
1093 data T = MkS !T Int
1094 with -funbox-strict-fields or -funbox-small-strict-fields
1095 we need to behave as if there was an UNPACK pragma there.
1096
1097 But it's the *argument* type that matters. This is fine:
1098 data S = MkS S !Int
1099 because Int is non-recursive.
1100
1101 ************************************************************************
1102 * *
1103 Wrapping and unwrapping newtypes and type families
1104 * *
1105 ************************************************************************
1106 -}
1107
1108 wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
1109 -- The wrapper for the data constructor for a newtype looks like this:
1110 -- newtype T a = MkT (a,Int)
1111 -- MkT :: forall a. (a,Int) -> T a
1112 -- MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a)
1113 -- where CoT is the coercion TyCon associated with the newtype
1114 --
1115 -- The call (wrapNewTypeBody T [a] e) returns the
1116 -- body of the wrapper, namely
1117 -- e `cast` (CoT [a])
1118 --
1119 -- If a coercion constructor is provided in the newtype, then we use
1120 -- it, otherwise the wrap/unwrap are both no-ops
1121
1122 wrapNewTypeBody tycon args result_expr
1123 = ASSERT( isNewTyCon tycon )
1124 mkCast result_expr (mkSymCo co)
1125 where
1126 co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []
1127
1128 -- When unwrapping, we do *not* apply any family coercion, because this will
1129 -- be done via a CoPat by the type checker. We have to do it this way as
1130 -- computing the right type arguments for the coercion requires more than just
1131 -- a spliting operation (cf, TcPat.tcConPat).
1132
1133 unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
1134 unwrapNewTypeBody tycon args result_expr
1135 = ASSERT( isNewTyCon tycon )
1136 mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args [])
1137
1138 -- If the type constructor is a representation type of a data instance, wrap
1139 -- the expression into a cast adjusting the expression type, which is an
1140 -- instance of the representation type, to the corresponding instance of the
1141 -- family instance type.
1142 -- See Note [Wrappers for data instance tycons]
1143 wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
1144 wrapFamInstBody tycon args body
1145 | Just co_con <- tyConFamilyCoercion_maybe tycon
1146 = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args []))
1147 | otherwise
1148 = body
1149
1150 {-
1151 ************************************************************************
1152 * *
1153 \subsection{Primitive operations}
1154 * *
1155 ************************************************************************
1156 -}
1157
1158 mkPrimOpId :: PrimOp -> Id
1159 mkPrimOpId prim_op
1160 = id
1161 where
1162 (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op
1163 ty = mkSpecForAllTys tyvars (mkVisFunTys arg_tys res_ty)
1164 name = mkWiredInName gHC_PRIM (primOpOcc prim_op)
1165 (mkPrimOpIdUnique (primOpTag prim_op))
1166 (AnId id) UserSyntax
1167 id = mkGlobalId (PrimOpId prim_op) name ty info
1168
1169 info = noCafIdInfo
1170 `setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op)
1171 `setArityInfo` arity
1172 `setStrictnessInfo` strict_sig
1173 `setInlinePragInfo` neverInlinePragma
1174 `setLevityInfoWithType` res_ty
1175 -- We give PrimOps a NOINLINE pragma so that we don't
1176 -- get silly warnings from Desugar.dsRule (the inline_shadows_rule
1177 -- test) about a RULE conflicting with a possible inlining
1178 -- cf #7287
1179
1180 -- For each ccall we manufacture a separate CCallOpId, giving it
1181 -- a fresh unique, a type that is correct for this particular ccall,
1182 -- and a CCall structure that gives the correct details about calling
1183 -- convention etc.
1184 --
1185 -- The *name* of this Id is a local name whose OccName gives the full
1186 -- details of the ccall, type and all. This means that the interface
1187 -- file reader can reconstruct a suitable Id
1188
1189 mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id
1190 mkFCallId dflags uniq fcall ty
1191 = ASSERT( noFreeVarsOfType ty )
1192 -- A CCallOpId should have no free type variables;
1193 -- when doing substitutions won't substitute over it
1194 mkGlobalId (FCallId fcall) name ty info
1195 where
1196 occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty))
1197 -- The "occurrence name" of a ccall is the full info about the
1198 -- ccall; it is encoded, but may have embedded spaces etc!
1199
1200 name = mkFCallName uniq occ_str
1201
1202 info = noCafIdInfo
1203 `setArityInfo` arity
1204 `setStrictnessInfo` strict_sig
1205 `setLevityInfoWithType` ty
1206
1207 (bndrs, _) = tcSplitPiTys ty
1208 arity = count isAnonTyCoBinder bndrs
1209 strict_sig = mkClosedStrictSig (replicate arity topDmd) topRes
1210 -- the call does not claim to be strict in its arguments, since they
1211 -- may be lifted (foreign import prim) and the called code doesn't
1212 -- necessarily force them. See #11076.
1213 {-
1214 ************************************************************************
1215 * *
1216 \subsection{DictFuns and default methods}
1217 * *
1218 ************************************************************************
1219
1220 Note [Dict funs and default methods]
1221 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1222 Dict funs and default methods are *not* ImplicitIds. Their definition
1223 involves user-written code, so we can't figure out their strictness etc
1224 based on fixed info, as we can for constructors and record selectors (say).
1225
1226 NB: See also Note [Exported LocalIds] in Id
1227 -}
1228
1229 mkDictFunId :: Name -- Name to use for the dict fun;
1230 -> [TyVar]
1231 -> ThetaType
1232 -> Class
1233 -> [Type]
1234 -> Id
1235 -- Implements the DFun Superclass Invariant (see TcInstDcls)
1236 -- See Note [Dict funs and default methods]
1237
1238 mkDictFunId dfun_name tvs theta clas tys
1239 = mkExportedLocalId (DFunId is_nt)
1240 dfun_name
1241 dfun_ty
1242 where
1243 is_nt = isNewTyCon (classTyCon clas)
1244 dfun_ty = mkDictFunTy tvs theta clas tys
1245
1246 mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type
1247 mkDictFunTy tvs theta clas tys
1248 = mkSpecSigmaTy tvs theta (mkClassPred clas tys)
1249
1250 {-
1251 ************************************************************************
1252 * *
1253 \subsection{Un-definable}
1254 * *
1255 ************************************************************************
1256
1257 These Ids can't be defined in Haskell. They could be defined in
1258 unfoldings in the wired-in GHC.Prim interface file, but we'd have to
1259 ensure that they were definitely, definitely inlined, because there is
1260 no curried identifier for them. That's what mkCompulsoryUnfolding
1261 does. If we had a way to get a compulsory unfolding from an interface
1262 file, we could do that, but we don't right now.
1263
1264 unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
1265 just gets expanded into a type coercion wherever it occurs. Hence we
1266 add it as a built-in Id with an unfolding here.
1267
1268 The type variables we use here are "open" type variables: this means
1269 they can unify with both unlifted and lifted types. Hence we provide
1270 another gun with which to shoot yourself in the foot.
1271 -}
1272
1273 unsafeCoerceName, nullAddrName, seqName,
1274 realWorldName, voidPrimIdName, coercionTokenName,
1275 magicDictName, coerceName, proxyName :: Name
1276 unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId
1277 nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId
1278 seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId
1279 realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId
1280 voidPrimIdName = mkWiredInIdName gHC_PRIM (fsLit "void#") voidPrimIdKey voidPrimId
1281 coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId
1282 magicDictName = mkWiredInIdName gHC_PRIM (fsLit "magicDict") magicDictKey magicDictId
1283 coerceName = mkWiredInIdName gHC_PRIM (fsLit "coerce") coerceKey coerceId
1284 proxyName = mkWiredInIdName gHC_PRIM (fsLit "proxy#") proxyHashKey proxyHashId
1285
1286 lazyIdName, oneShotName, noinlineIdName :: Name
1287 lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId
1288 oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId
1289 noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") noinlineIdKey noinlineId
1290
1291 ------------------------------------------------
1292 proxyHashId :: Id
1293 proxyHashId
1294 = pcMiscPrelId proxyName ty
1295 (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings]
1296 `setNeverLevPoly` ty )
1297 where
1298 -- proxy# :: forall {k} (a:k). Proxy# k a
1299 --
1300 -- The visibility of the `k` binder is Inferred to match the type of the
1301 -- Proxy data constructor (#16293).
1302 [kv,tv] = mkTemplateKiTyVars [liftedTypeKind] id
1303 kv_ty = mkTyVarTy kv
1304 tv_ty = mkTyVarTy tv
1305 ty = mkInvForAllTy kv $ mkSpecForAllTy tv $ mkProxyPrimTy kv_ty tv_ty
1306
1307 ------------------------------------------------
1308 unsafeCoerceId :: Id
1309 unsafeCoerceId
1310 = pcMiscPrelId unsafeCoerceName ty info
1311 where
1312 info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
1313 `setUnfoldingInfo` mkCompulsoryUnfolding rhs
1314
1315 -- unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
1316 -- (a :: TYPE r1) (b :: TYPE r2).
1317 -- a -> b
1318 bndrs = mkTemplateKiTyVars [runtimeRepTy, runtimeRepTy]
1319 (\ks -> map tYPE ks)
1320
1321 [_, _, a, b] = mkTyVarTys bndrs
1322
1323 ty = mkSpecForAllTys bndrs (mkVisFunTy a b)
1324
1325 [x] = mkTemplateLocals [a]
1326 rhs = mkLams (bndrs ++ [x]) $
1327 Cast (Var x) (mkUnsafeCo Representational a b)
1328
1329 ------------------------------------------------
1330 nullAddrId :: Id
1331 -- nullAddr# :: Addr#
1332 -- The reason it is here is because we don't provide
1333 -- a way to write this literal in Haskell.
1334 nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info
1335 where
1336 info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
1337 `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit)
1338 `setNeverLevPoly` addrPrimTy
1339
1340 ------------------------------------------------
1341 seqId :: Id -- See Note [seqId magic]
1342 seqId = pcMiscPrelId seqName ty info
1343 where
1344 info = noCafIdInfo `setInlinePragInfo` inline_prag
1345 `setUnfoldingInfo` mkCompulsoryUnfolding rhs
1346 `setNeverLevPoly` ty
1347
1348 inline_prag
1349 = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter
1350 NoSourceText 0
1351 -- Make 'seq' not inline-always, so that simpleOptExpr
1352 -- (see CoreSubst.simple_app) won't inline 'seq' on the
1353 -- LHS of rules. That way we can have rules for 'seq';
1354 -- see Note [seqId magic]
1355
1356 ty = mkSpecForAllTys [alphaTyVar,betaTyVar]
1357 (mkVisFunTy alphaTy (mkVisFunTy betaTy betaTy))
1358
1359 [x,y] = mkTemplateLocals [alphaTy, betaTy]
1360 rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x betaTy [(DEFAULT, [], Var y)])
1361
1362 ------------------------------------------------
1363 lazyId :: Id -- See Note [lazyId magic]
1364 lazyId = pcMiscPrelId lazyIdName ty info
1365 where
1366 info = noCafIdInfo `setNeverLevPoly` ty
1367 ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy)
1368
1369 noinlineId :: Id -- See Note [noinlineId magic]
1370 noinlineId = pcMiscPrelId noinlineIdName ty info
1371 where
1372 info = noCafIdInfo `setNeverLevPoly` ty
1373 ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy)
1374
1375 oneShotId :: Id -- See Note [The oneShot function]
1376 oneShotId = pcMiscPrelId oneShotName ty info
1377 where
1378 info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
1379 `setUnfoldingInfo` mkCompulsoryUnfolding rhs
1380 ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar
1381 , openAlphaTyVar, openBetaTyVar ]
1382 (mkVisFunTy fun_ty fun_ty)
1383 fun_ty = mkVisFunTy openAlphaTy openBetaTy
1384 [body, x] = mkTemplateLocals [fun_ty, openAlphaTy]
1385 x' = setOneShotLambda x -- Here is the magic bit!
1386 rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar
1387 , openAlphaTyVar, openBetaTyVar
1388 , body, x'] $
1389 Var body `App` Var x
1390
1391 --------------------------------------------------------------------------------
1392 magicDictId :: Id -- See Note [magicDictId magic]
1393 magicDictId = pcMiscPrelId magicDictName ty info
1394 where
1395 info = noCafIdInfo `setInlinePragInfo` neverInlinePragma
1396 `setNeverLevPoly` ty
1397 ty = mkSpecForAllTys [alphaTyVar] alphaTy
1398
1399 --------------------------------------------------------------------------------
1400
1401 coerceId :: Id
1402 coerceId = pcMiscPrelId coerceName ty info
1403 where
1404 info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
1405 `setUnfoldingInfo` mkCompulsoryUnfolding rhs
1406 `setNeverLevPoly` ty
1407 eqRTy = mkTyConApp coercibleTyCon [ liftedTypeKind
1408 , alphaTy, betaTy ]
1409 eqRPrimTy = mkTyConApp eqReprPrimTyCon [ liftedTypeKind
1410 , liftedTypeKind
1411 , alphaTy, betaTy ]
1412 ty = mkSpecForAllTys [alphaTyVar, betaTyVar] $
1413 mkInvisFunTy eqRTy $
1414 mkVisFunTy alphaTy betaTy
1415
1416 [eqR,x,eq] = mkTemplateLocals [eqRTy, alphaTy, eqRPrimTy]
1417 rhs = mkLams [alphaTyVar, betaTyVar, eqR, x] $
1418 mkWildCase (Var eqR) eqRTy betaTy $
1419 [(DataAlt coercibleDataCon, [eq], Cast (Var x) (mkCoVarCo eq))]
1420
1421 {-
1422 Note [Unsafe coerce magic]
1423 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1424 We define a *primitive*
1425 GHC.Prim.unsafeCoerce#
1426 and then in the base library we define the ordinary function
1427 Unsafe.Coerce.unsafeCoerce :: forall (a:*) (b:*). a -> b
1428 unsafeCoerce x = unsafeCoerce# x
1429
1430 Notice that unsafeCoerce has a civilized (albeit still dangerous)
1431 polymorphic type, whose type args have kind *. So you can't use it on
1432 unboxed values (unsafeCoerce 3#).
1433
1434 In contrast unsafeCoerce# is even more dangerous because you *can* use
1435 it on unboxed things, (unsafeCoerce# 3#) :: Int. Its type is
1436 forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a: TYPE r1) (b: TYPE r2). a -> b
1437
1438 Note [seqId magic]
1439 ~~~~~~~~~~~~~~~~~~
1440 'GHC.Prim.seq' is special in several ways.
1441
1442 a) In source Haskell its second arg can have an unboxed type
1443 x `seq` (v +# w)
1444 But see Note [Typing rule for seq] in TcExpr, which
1445 explains why we give seq itself an ordinary type
1446 seq :: forall a b. a -> b -> b
1447 and treat it as a language construct from a typing point of view.
1448
1449 b) Its fixity is set in LoadIface.ghcPrimIface
1450
1451 c) It has quite a bit of desugaring magic.
1452 See DsUtils.hs Note [Desugaring seq (1)] and (2) and (3)
1453
1454 d) There is some special rule handing: Note [User-defined RULES for seq]
1455
1456 Note [User-defined RULES for seq]
1457 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1458 Roman found situations where he had
1459 case (f n) of _ -> e
1460 where he knew that f (which was strict in n) would terminate if n did.
1461 Notice that the result of (f n) is discarded. So it makes sense to
1462 transform to
1463 case n of _ -> e
1464
1465 Rather than attempt some general analysis to support this, I've added
1466 enough support that you can do this using a rewrite rule:
1467
1468 RULE "f/seq" forall n. seq (f n) = seq n
1469
1470 You write that rule. When GHC sees a case expression that discards
1471 its result, it mentally transforms it to a call to 'seq' and looks for
1472 a RULE. (This is done in Simplify.trySeqRules.) As usual, the
1473 correctness of the rule is up to you.
1474
1475 VERY IMPORTANT: to make this work, we give the RULE an arity of 1, not 2.
1476 If we wrote
1477 RULE "f/seq" forall n e. seq (f n) e = seq n e
1478 with rule arity 2, then two bad things would happen:
1479
1480 - The magical desugaring done in Note [seqId magic] item (c)
1481 for saturated application of 'seq' would turn the LHS into
1482 a case expression!
1483
1484 - The code in Simplify.rebuildCase would need to actually supply
1485 the value argument, which turns out to be awkward.
1486
1487 Note [lazyId magic]
1488 ~~~~~~~~~~~~~~~~~~~
1489 lazy :: forall a?. a? -> a? (i.e. works for unboxed types too)
1490
1491 'lazy' is used to make sure that a sub-expression, and its free variables,
1492 are truly used call-by-need, with no code motion. Key examples:
1493
1494 * pseq: pseq a b = a `seq` lazy b
1495 We want to make sure that the free vars of 'b' are not evaluated
1496 before 'a', even though the expression is plainly strict in 'b'.
1497
1498 * catch: catch a b = catch# (lazy a) b
1499 Again, it's clear that 'a' will be evaluated strictly (and indeed
1500 applied to a state token) but we want to make sure that any exceptions
1501 arising from the evaluation of 'a' are caught by the catch (see
1502 #11555).
1503
1504 Implementing 'lazy' is a bit tricky:
1505
1506 * It must not have a strictness signature: by being a built-in Id,
1507 all the info about lazyId comes from here, not from GHC.Base.hi.
1508 This is important, because the strictness analyser will spot it as
1509 strict!
1510
1511 * It must not have an unfolding: it gets "inlined" by a HACK in
1512 CorePrep. It's very important to do this inlining *after* unfoldings
1513 are exposed in the interface file. Otherwise, the unfolding for
1514 (say) pseq in the interface file will not mention 'lazy', so if we
1515 inline 'pseq' we'll totally miss the very thing that 'lazy' was
1516 there for in the first place. See #3259 for a real world
1517 example.
1518
1519 * Suppose CorePrep sees (catch# (lazy e) b). At all costs we must
1520 avoid using call by value here:
1521 case e of r -> catch# r b
1522 Avoiding that is the whole point of 'lazy'. So in CorePrep (which
1523 generate the 'case' expression for a call-by-value call) we must
1524 spot the 'lazy' on the arg (in CorePrep.cpeApp), and build a 'let'
1525 instead.
1526
1527 * lazyId is defined in GHC.Base, so we don't *have* to inline it. If it
1528 appears un-applied, we'll end up just calling it.
1529
1530 Note [noinlineId magic]
1531 ~~~~~~~~~~~~~~~~~~~~~~~
1532 noinline :: forall a. a -> a
1533
1534 'noinline' is used to make sure that a function f is never inlined,
1535 e.g., as in 'noinline f x'. Ordinarily, the identity function with NOINLINE
1536 could be used to achieve this effect; however, this has the unfortunate
1537 result of leaving a (useless) call to noinline at runtime. So we have
1538 a little bit of magic to optimize away 'noinline' after we are done
1539 running the simplifier.
1540
1541 'noinline' needs to be wired-in because it gets inserted automatically
1542 when we serialize an expression to the interface format. See
1543 Note [Inlining and hs-boot files] in ToIface
1544
1545 Note [The oneShot function]
1546 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1547 In the context of making left-folds fuse somewhat okish (see ticket #7994
1548 and Note [Left folds via right fold]) it was determined that it would be useful
1549 if library authors could explicitly tell the compiler that a certain lambda is
1550 called at most once. The oneShot function allows that.
1551
1552 'oneShot' is levity-polymorphic, i.e. the type variables can refer to unlifted
1553 types as well (#10744); e.g.
1554 oneShot (\x:Int# -> x +# 1#)
1555
1556 Like most magic functions it has a compulsory unfolding, so there is no need
1557 for a real definition somewhere. We have one in GHC.Magic for the convenience
1558 of putting the documentation there.
1559
1560 It uses `setOneShotLambda` on the lambda's binder. That is the whole magic:
1561
1562 A typical call looks like
1563 oneShot (\y. e)
1564 after unfolding the definition `oneShot = \f \x[oneshot]. f x` we get
1565 (\f \x[oneshot]. f x) (\y. e)
1566 --> \x[oneshot]. ((\y.e) x)
1567 --> \x[oneshot] e[x/y]
1568 which is what we want.
1569
1570 It is only effective if the one-shot info survives as long as possible; in
1571 particular it must make it into the interface in unfoldings. See Note [Preserve
1572 OneShotInfo] in CoreTidy.
1573
1574 Also see https://ghc.haskell.org/trac/ghc/wiki/OneShot.
1575
1576
1577 Note [magicDictId magic]
1578 ~~~~~~~~~~~~~~~~~~~~~~~~~
1579 The identifier `magicDict` is just a place-holder, which is used to
1580 implement a primitive that we cannot define in Haskell but we can write
1581 in Core. It is declared with a place-holder type:
1582
1583 magicDict :: forall a. a
1584
1585 The intention is that the identifier will be used in a very specific way,
1586 to create dictionaries for classes with a single method. Consider a class
1587 like this:
1588
1589 class C a where
1590 f :: T a
1591
1592 We are going to use `magicDict`, in conjunction with a built-in Prelude
1593 rule, to cast values of type `T a` into dictionaries for `C a`. To do
1594 this, we define a function like this in the library:
1595
1596 data WrapC a b = WrapC (C a => Proxy a -> b)
1597
1598 withT :: (C a => Proxy a -> b)
1599 -> T a -> Proxy a -> b
1600 withT f x y = magicDict (WrapC f) x y
1601
1602 The purpose of `WrapC` is to avoid having `f` instantiated.
1603 Also, it avoids impredicativity, because `magicDict`'s type
1604 cannot be instantiated with a forall. The field of `WrapC` contains
1605 a `Proxy` parameter which is used to link the type of the constraint,
1606 `C a`, with the type of the `Wrap` value being made.
1607
1608 Next, we add a built-in Prelude rule (see prelude/PrelRules.hs),
1609 which will replace the RHS of this definition with the appropriate
1610 definition in Core. The rewrite rule works as follows:
1611
1612 magicDict @t (wrap @a @b f) x y
1613 ---->
1614 f (x `cast` co a) y
1615
1616 The `co` coercion is the newtype-coercion extracted from the type-class.
1617 The type class is obtain by looking at the type of wrap.
1618
1619
1620 -------------------------------------------------------------
1621 @realWorld#@ used to be a magic literal, \tr{void#}. If things get
1622 nasty as-is, change it back to a literal (@Literal@).
1623
1624 voidArgId is a Local Id used simply as an argument in functions
1625 where we just want an arg to avoid having a thunk of unlifted type.
1626 E.g.
1627 x = \ void :: Void# -> (# p, q #)
1628
1629 This comes up in strictness analysis
1630
1631 Note [evaldUnfoldings]
1632 ~~~~~~~~~~~~~~~~~~~~~~
1633 The evaldUnfolding makes it look that some primitive value is
1634 evaluated, which in turn makes Simplify.interestingArg return True,
1635 which in turn makes INLINE things applied to said value likely to be
1636 inlined.
1637 -}
1638
1639 realWorldPrimId :: Id -- :: State# RealWorld
1640 realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy
1641 (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings]
1642 `setOneShotInfo` stateHackOneShot
1643 `setNeverLevPoly` realWorldStatePrimTy)
1644
1645 voidPrimId :: Id -- Global constant :: Void#
1646 voidPrimId = pcMiscPrelId voidPrimIdName voidPrimTy
1647 (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings]
1648 `setNeverLevPoly` voidPrimTy)
1649
1650 voidArgId :: Id -- Local lambda-bound :: Void#
1651 voidArgId = mkSysLocal (fsLit "void") voidArgIdKey voidPrimTy
1652
1653 coercionTokenId :: Id -- :: () ~ ()
1654 coercionTokenId -- Used to replace Coercion terms when we go to STG
1655 = pcMiscPrelId coercionTokenName
1656 (mkTyConApp eqPrimTyCon [liftedTypeKind, liftedTypeKind, unitTy, unitTy])
1657 noCafIdInfo
1658
1659 pcMiscPrelId :: Name -> Type -> IdInfo -> Id
1660 pcMiscPrelId name ty info
1661 = mkVanillaGlobalWithInfo name ty info
1662 -- We lie and say the thing is imported; otherwise, we get into
1663 -- a mess with dependency analysis; e.g., core2stg may heave in
1664 -- random calls to GHCbase.unpackPS__. If GHCbase is the module
1665 -- being compiled, then it's just a matter of luck if the definition
1666 -- will be in "the right place" to be in scope.