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