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