Merge commit 'c859d17f9b0ae8559dac4f7e5cb8521e7ab5f0fb'
[ghc.git] / compiler / basicTypes / MkId.lhs
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 \begin{code}
15 {-# OPTIONS -fno-warn-tabs #-}
16 -- The above warning supression flag is a temporary kludge.
17 -- While working on this module you are encouraged to remove it and
18 -- detab the module (please do the detabbing in a separate patch). See
19 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
20 -- for details
21
22 module MkId (
23         mkDictFunId, mkDictFunTy, mkDictSelId,
24
25         mkDataConIds, mkPrimOpId, mkFCallId,
26
27         mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
28         wrapFamInstBody, unwrapFamInstScrut,
29         wrapTypeFamInstBody, unwrapTypeFamInstScrut,
30         mkUnpackCase, mkProductBox,
31
32         -- And some particular Ids; see below for why they are wired in
33         wiredInIds, ghcPrimIds,
34         unsafeCoerceName, unsafeCoerceId, realWorldPrimId, 
35         voidArgId, nullAddrId, seqId, lazyId, lazyIdKey,
36         coercionTokenId,
37
38         -- Re-export error Ids
39         module PrelRules
40     ) where
41
42 #include "HsVersions.h"
43
44 import Rules
45 import TysPrim
46 import TysWiredIn
47 import PrelRules
48 import Type
49 import Coercion
50 import TcType
51 import MkCore
52 import CoreUtils        ( exprType, mkCast )
53 import CoreUnfold
54 import Literal
55 import TyCon
56 import Class
57 import VarSet
58 import Name
59 import PrimOp
60 import ForeignCall
61 import DataCon
62 import Id
63 import Var              ( mkExportedLocalVar )
64 import IdInfo
65 import Demand
66 import CoreSyn
67 import Unique
68 import PrelNames
69 import BasicTypes       hiding ( SuccessFlag(..) )
70 import Util
71 import Pair
72 import DynFlags
73 import Outputable
74 import FastString
75 import ListSetOps
76 \end{code}
77
78 %************************************************************************
79 %*                                                                      *
80 \subsection{Wired in Ids}
81 %*                                                                      *
82 %************************************************************************
83
84 Note [Wired-in Ids]
85 ~~~~~~~~~~~~~~~~~~~
86 There are several reasons why an Id might appear in the wiredInIds:
87
88 (1) The ghcPrimIds are wired in because they can't be defined in
89     Haskell at all, although the can be defined in Core.  They have
90     compulsory unfoldings, so they are always inlined and they  have
91     no definition site.  Their home module is GHC.Prim, so they
92     also have a description in primops.txt.pp, where they are called
93     'pseudoops'.
94
95 (2) The 'error' function, eRROR_ID, is wired in because we don't yet have
96     a way to express in an interface file that the result type variable
97     is 'open'; that is can be unified with an unboxed type
98
99     [The interface file format now carry such information, but there's
100     no way yet of expressing at the definition site for these 
101     error-reporting functions that they have an 'open' 
102     result type. -- sof 1/99]
103
104 (3) Other error functions (rUNTIME_ERROR_ID) are wired in (a) because
105     the desugarer generates code that mentiones them directly, and
106     (b) for the same reason as eRROR_ID
107
108 (4) lazyId is wired in because the wired-in version overrides the
109     strictness of the version defined in GHC.Base
110
111 In cases (2-4), the function has a definition in a library module, and
112 can be called; but the wired-in version means that the details are 
113 never read from that module's interface file; instead, the full definition
114 is right here.
115
116 \begin{code}
117 wiredInIds :: [Id]
118 wiredInIds
119   =  [lazyId]
120   ++ errorIds           -- Defined in MkCore
121   ++ ghcPrimIds
122
123 -- These Ids are exported from GHC.Prim
124 ghcPrimIds :: [Id]
125 ghcPrimIds
126   = [   -- These can't be defined in Haskell, but they have
127         -- perfectly reasonable unfoldings in Core
128     realWorldPrimId,
129     unsafeCoerceId,
130     nullAddrId,
131     seqId
132     ]
133 \end{code}
134
135 %************************************************************************
136 %*                                                                      *
137 \subsection{Data constructors}
138 %*                                                                      *
139 %************************************************************************
140
141 The wrapper for a constructor is an ordinary top-level binding that evaluates
142 any strict args, unboxes any args that are going to be flattened, and calls
143 the worker.
144
145 We're going to build a constructor that looks like:
146
147         data (Data a, C b) =>  T a b = T1 !a !Int b
148
149         T1 = /\ a b -> 
150              \d1::Data a, d2::C b ->
151              \p q r -> case p of { p ->
152                        case q of { q ->
153                        Con T1 [a,b] [p,q,r]}}
154
155 Notice that
156
157 * d2 is thrown away --- a context in a data decl is used to make sure
158   one *could* construct dictionaries at the site the constructor
159   is used, but the dictionary isn't actually used.
160
161 * We have to check that we can construct Data dictionaries for
162   the types a and Int.  Once we've done that we can throw d1 away too.
163
164 * We use (case p of q -> ...) to evaluate p, rather than "seq" because
165   all that matters is that the arguments are evaluated.  "seq" is 
166   very careful to preserve evaluation order, which we don't need
167   to be here.
168
169   You might think that we could simply give constructors some strictness
170   info, like PrimOps, and let CoreToStg do the let-to-case transformation.
171   But we don't do that because in the case of primops and functions strictness
172   is a *property* not a *requirement*.  In the case of constructors we need to
173   do something active to evaluate the argument.
174
175   Making an explicit case expression allows the simplifier to eliminate
176   it in the (common) case where the constructor arg is already evaluated.
177
178 Note [Wrappers for data instance tycons]
179 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
180 In the case of data instances, the wrapper also applies the coercion turning
181 the representation type into the family instance type to cast the result of
182 the wrapper.  For example, consider the declarations
183
184   data family Map k :: * -> *
185   data instance Map (a, b) v = MapPair (Map a (Pair b v))
186
187 The tycon to which the datacon MapPair belongs gets a unique internal
188 name of the form :R123Map, and we call it the representation tycon.
189 In contrast, Map is the family tycon (accessible via
190 tyConFamInst_maybe). A coercion allows you to move between
191 representation and family type.  It is accessible from :R123Map via
192 tyConFamilyCoercion_maybe and has kind
193
194   Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v}
195
196 The wrapper and worker of MapPair get the types
197
198         -- Wrapper
199   $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v
200   $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v)
201
202         -- Worker
203   MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v
204
205 This coercion is conditionally applied by wrapFamInstBody.
206
207 It's a bit more complicated if the data instance is a GADT as well!
208
209    data instance T [a] where
210         T1 :: forall b. b -> T [Maybe b]
211
212 Hence we translate to
213
214         -- Wrapper
215   $WT1 :: forall b. b -> T [Maybe b]
216   $WT1 b v = T1 (Maybe b) b (Maybe b) v
217                         `cast` sym (Co7T (Maybe b))
218
219         -- Worker
220   T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c
221
222         -- Coercion from family type to representation type
223   Co7T a :: T [a] ~ :R7T a
224
225 \begin{code}
226 mkDataConIds :: Name -> Name -> DataCon -> DataConIds
227 mkDataConIds wrap_name wkr_name data_con
228   | isNewTyCon tycon                    -- Newtype, only has a worker
229   = DCIds Nothing nt_work_id                 
230
231   | any isBanged all_strict_marks      -- Algebraic, needs wrapper
232     || not (null eq_spec)              -- NB: LoadIface.ifaceDeclImplicitBndrs
233     || isFamInstTyCon tycon            --     depends on this test
234   = DCIds (Just alg_wrap_id) wrk_id
235
236   | otherwise                                -- Algebraic, no wrapper
237   = DCIds Nothing wrk_id
238   where
239     (univ_tvs, ex_tvs, eq_spec, 
240      other_theta, orig_arg_tys, res_ty) = dataConFullSig data_con
241     tycon = dataConTyCon data_con       -- The representation TyCon (not family)
242
243         ----------- Worker (algebraic data types only) --------------
244         -- The *worker* for the data constructor is the function that
245         -- takes the representation arguments and builds the constructor.
246     wrk_id = mkGlobalId (DataConWorkId data_con) wkr_name
247                         (dataConRepType data_con) wkr_info
248
249     wkr_arity = dataConRepArity data_con
250     wkr_info  = noCafIdInfo
251                 `setArityInfo`       wkr_arity
252                 `setStrictnessInfo`  Just wkr_sig
253                 `setUnfoldingInfo`   evaldUnfolding  -- Record that it's evaluated,
254                                                         -- even if arity = 0
255
256     wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
257         --      Note [Data-con worker strictness]
258         -- Notice that we do *not* say the worker is strict
259         -- even if the data constructor is declared strict
260         --      e.g.    data T = MkT !(Int,Int)
261         -- Why?  Because the *wrapper* is strict (and its unfolding has case
262         -- expresssions that do the evals) but the *worker* itself is not.
263         -- If we pretend it is strict then when we see
264         --      case x of y -> $wMkT y
265         -- the simplifier thinks that y is "sure to be evaluated" (because
266         --  $wMkT is strict) and drops the case.  No, $wMkT is not strict.
267         --
268         -- When the simplifer sees a pattern 
269         --      case e of MkT x -> ...
270         -- it uses the dataConRepStrictness of MkT to mark x as evaluated;
271         -- but that's fine... dataConRepStrictness comes from the data con
272         -- not from the worker Id.
273
274     cpr_info | isProductTyCon tycon && 
275                isDataTyCon tycon    &&
276                wkr_arity > 0        &&
277                wkr_arity <= mAX_CPR_SIZE        = retCPR
278              | otherwise                        = TopRes
279         -- RetCPR is only true for products that are real data types;
280         -- that is, not unboxed tuples or [non-recursive] newtypes
281
282         ----------- Workers for newtypes --------------
283     nt_work_id   = mkGlobalId (DataConWrapId data_con) wkr_name wrap_ty nt_work_info
284     nt_work_info = noCafIdInfo          -- The NoCaf-ness is set by noCafIdInfo
285                   `setArityInfo` 1      -- Arity 1
286                   `setInlinePragInfo`    alwaysInlinePragma
287                   `setUnfoldingInfo`     newtype_unf
288     id_arg1      = mkTemplateLocal 1 (head orig_arg_tys)
289     newtype_unf  = ASSERT2( isVanillaDataCon data_con &&
290                             isSingleton orig_arg_tys, ppr data_con  )
291                               -- Note [Newtype datacons]
292                    mkCompulsoryUnfolding $ 
293                    mkLams wrap_tvs $ Lam id_arg1 $ 
294                    wrapNewTypeBody tycon res_ty_args (Var id_arg1)
295
296
297         ----------- Wrapper --------------
298         -- We used to include the stupid theta in the wrapper's args
299         -- but now we don't.  Instead the type checker just injects these
300         -- extra constraints where necessary.
301     wrap_tvs    = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
302     res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs
303     ev_tys      = other_theta
304     wrap_ty     = mkForAllTys wrap_tvs $ 
305                   mkFunTys ev_tys $
306                   mkFunTys orig_arg_tys $ res_ty
307
308         ----------- Wrappers for algebraic data types -------------- 
309     alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info
310     alg_wrap_info = noCafIdInfo
311                     `setArityInfo`         wrap_arity
312                         -- It's important to specify the arity, so that partial
313                         -- applications are treated as values
314                     `setInlinePragInfo`    alwaysInlinePragma
315                     `setUnfoldingInfo`     wrap_unf
316                     `setStrictnessInfo` Just wrap_sig
317                         -- We need to get the CAF info right here because TidyPgm
318                         -- does not tidy the IdInfo of implicit bindings (like the wrapper)
319                         -- so it not make sure that the CAF info is sane
320
321     all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con
322     wrap_sig = mkStrictSig (mkTopDmdType wrap_arg_dmds cpr_info)
323     wrap_stricts = dropList eq_spec all_strict_marks
324     wrap_arg_dmds = map mk_dmd wrap_stricts
325     mk_dmd str | isBanged str = evalDmd
326                | otherwise    = lazyDmd
327         -- The Cpr info can be important inside INLINE rhss, where the
328         -- wrapper constructor isn't inlined.
329         -- And the argument strictness can be important too; we
330         -- may not inline a contructor when it is partially applied.
331         -- For example:
332         --      data W = C !Int !Int !Int
333         --      ...(let w = C x in ...(w p q)...)...
334         -- we want to see that w is strict in its two arguments
335
336     wrap_unf = mkInlineUnfolding (Just (length ev_args + length id_args)) wrap_rhs
337     wrap_rhs = mkLams wrap_tvs $ 
338                mkLams ev_args $
339                mkLams id_args $
340                foldr mk_case con_app 
341                      (zip (ev_args ++ id_args) wrap_stricts)
342                      i3 []
343              -- The ev_args is the evidence arguments *other than* the eq_spec
344              -- Because we are going to apply the eq_spec args manually in the
345              -- wrapper
346
347     con_app _ rep_ids = wrapFamInstBody tycon res_ty_args $
348                           Var wrk_id `mkTyApps`  res_ty_args
349                                      `mkVarApps` ex_tvs                 
350                                      `mkCoApps`  map (mkReflCo . snd) eq_spec
351                                      `mkVarApps` reverse rep_ids
352                             -- Dont box the eq_spec coercions since they are
353                             -- marked as HsUnpack by mk_dict_strict_mark
354
355     (ev_args,i2) = mkLocals 1  ev_tys
356     (id_args,i3) = mkLocals i2 orig_arg_tys
357     wrap_arity   = i3-1
358
359     mk_case 
360            :: (Id, HsBang)      -- Arg, strictness
361            -> (Int -> [Id] -> CoreExpr) -- Body
362            -> Int                       -- Next rep arg id
363            -> [Id]                      -- Rep args so far, reversed
364            -> CoreExpr
365     mk_case (arg,strict) body i rep_args
366           = case strict of
367                 HsNoBang -> body i (arg:rep_args)
368                 HsUnpack -> unboxProduct i (Var arg) (idType arg) the_body 
369                       where
370                         the_body i con_args = body i (reverse con_args ++ rep_args)
371                 _other  -- HsUnpackFailed and HsStrict
372                    | isUnLiftedType (idType arg) -> body i (arg:rep_args)
373                    | otherwise -> Case (Var arg) arg res_ty 
374                                        [(DEFAULT,[], body i (arg:rep_args))]
375
376 mAX_CPR_SIZE :: Arity
377 mAX_CPR_SIZE = 10
378 -- We do not treat very big tuples as CPR-ish:
379 --      a) for a start we get into trouble because there aren't 
380 --         "enough" unboxed tuple types (a tiresome restriction, 
381 --         but hard to fix), 
382 --      b) more importantly, big unboxed tuples get returned mainly
383 --         on the stack, and are often then allocated in the heap
384 --         by the caller.  So doing CPR for them may in fact make
385 --         things worse.
386
387 mkLocals :: Int -> [Type] -> ([Id], Int)
388 mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
389                where
390                  n = length tys
391 \end{code}
392
393 Note [Newtype datacons]
394 ~~~~~~~~~~~~~~~~~~~~~~~
395 The "data constructor" for a newtype should always be vanilla.  At one
396 point this wasn't true, because the newtype arising from
397      class C a => D a
398 looked like
399        newtype T:D a = D:D (C a)
400 so the data constructor for T:C had a single argument, namely the
401 predicate (C a).  But now we treat that as an ordinary argument, not
402 part of the theta-type, so all is well.
403
404
405 %************************************************************************
406 %*                                                                      *
407 \subsection{Dictionary selectors}
408 %*                                                                      *
409 %************************************************************************
410
411 Selecting a field for a dictionary.  If there is just one field, then
412 there's nothing to do.  
413
414 Dictionary selectors may get nested forall-types.  Thus:
415
416         class Foo a where
417           op :: forall b. Ord b => a -> b -> b
418
419 Then the top-level type for op is
420
421         op :: forall a. Foo a => 
422               forall b. Ord b => 
423               a -> b -> b
424
425 This is unlike ordinary record selectors, which have all the for-alls
426 at the outside.  When dealing with classes it's very convenient to
427 recover the original type signature from the class op selector.
428
429 \begin{code}
430 mkDictSelId :: Bool          -- True <=> don't include the unfolding
431                              -- Little point on imports without -O, because the
432                              -- dictionary itself won't be visible
433             -> Name          -- Name of one of the *value* selectors 
434                              -- (dictionary superclass or method)
435             -> Class -> Id
436 mkDictSelId no_unf name clas
437   = mkGlobalId (ClassOpId clas) name sel_ty info
438   where
439     sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id))
440         -- We can't just say (exprType rhs), because that would give a type
441         --      C a -> C a
442         -- for a single-op class (after all, the selector is the identity)
443         -- But it's type must expose the representation of the dictionary
444         -- to get (say)         C a -> (a -> a)
445
446     base_info = noCafIdInfo
447                 `setArityInfo`      1
448                 `setStrictnessInfo` Just strict_sig
449                 `setUnfoldingInfo`  (if no_unf then noUnfolding
450                                      else mkImplicitUnfolding rhs)
451                    -- In module where class op is defined, we must add
452                    -- the unfolding, even though it'll never be inlined
453                    -- becuase we use that to generate a top-level binding
454                    -- for the ClassOp
455
456     info | new_tycon = base_info `setInlinePragInfo` alwaysInlinePragma
457                    -- See Note [Single-method classes] in TcInstDcls
458                    -- for why alwaysInlinePragma
459          | otherwise = base_info  `setSpecInfo`       mkSpecInfo [rule]
460                                   `setInlinePragInfo` neverInlinePragma
461                    -- Add a magic BuiltinRule, and never inline it
462                    -- so that the rule is always available to fire.
463                    -- See Note [ClassOp/DFun selection] in TcInstDcls
464
465     n_ty_args = length tyvars
466
467     -- This is the built-in rule that goes
468     --      op (dfT d1 d2) --->  opT d1 d2
469     rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` 
470                                      occNameFS (getOccName name)
471                        , ru_fn    = name
472                        , ru_nargs = n_ty_args + 1
473                        , ru_try   = dictSelRule val_index n_ty_args }
474
475         -- The strictness signature is of the form U(AAAVAAAA) -> T
476         -- where the V depends on which item we are selecting
477         -- It's worth giving one, so that absence info etc is generated
478         -- even if the selector isn't inlined
479     strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes)
480     arg_dmd | new_tycon = evalDmd
481             | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
482                                      | id <- arg_ids ])
483
484     tycon          = classTyCon clas
485     new_tycon      = isNewTyCon tycon
486     [data_con]     = tyConDataCons tycon
487     tyvars         = dataConUnivTyVars data_con
488     arg_tys        = dataConRepArgTys data_con  -- Includes the dictionary superclasses
489
490     -- 'index' is a 0-index into the *value* arguments of the dictionary
491     val_index      = assoc "MkId.mkDictSelId" sel_index_prs name
492     sel_index_prs  = map idName (classAllSelIds clas) `zip` [0..]
493
494     the_arg_id     = arg_ids !! val_index
495     pred           = mkClassPred clas (mkTyVarTys tyvars)
496     dict_id        = mkTemplateLocal 1 pred
497     arg_ids        = mkTemplateLocalsNum 2 arg_tys
498
499     rhs = mkLams tyvars  (Lam dict_id   rhs_body)
500     rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
501              | otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
502                                 [(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)]
503                                 -- varToCoreExpr needed for equality superclass selectors
504                                 --   sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }
505
506 dictSelRule :: Int -> Arity 
507             -> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
508 -- Tries to persuade the argument to look like a constructor
509 -- application, using exprIsConApp_maybe, and then selects
510 -- from it
511 --       sel_i t1..tk (D t1..tk op1 ... opm) = opi
512 --
513 dictSelRule val_index n_ty_args _ id_unf args
514   | (dict_arg : _) <- drop n_ty_args args
515   , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
516   = Just (con_args !! val_index)
517   | otherwise
518   = Nothing
519 \end{code}
520
521
522 %************************************************************************
523 %*                                                                      *
524         Boxing and unboxing
525 %*                                                                      *
526 %************************************************************************
527
528 \begin{code}
529 -- unbox a product type...
530 -- we will recurse into newtypes, casting along the way, and unbox at the
531 -- first product data constructor we find. e.g.
532 --  
533 --   data PairInt = PairInt Int Int
534 --   newtype S = MkS PairInt
535 --   newtype T = MkT S
536 --
537 -- If we have e = MkT (MkS (PairInt 0 1)) and some body expecting a list of
538 -- ids, we get (modulo int passing)
539 --
540 --   case (e `cast` CoT) `cast` CoS of
541 --     PairInt a b -> body [a,b]
542 --
543 -- The Ints passed around are just for creating fresh locals
544 unboxProduct :: Int -> CoreExpr -> Type -> (Int -> [Id] -> CoreExpr) -> CoreExpr
545 unboxProduct i arg arg_ty body
546   = result
547   where 
548     result = mkUnpackCase the_id arg con_args boxing_con rhs
549     (_tycon, _tycon_args, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty
550     ([the_id], i') = mkLocals i [arg_ty]
551     (con_args, i'') = mkLocals i' tys
552     rhs = body i'' con_args
553
554 mkUnpackCase ::  Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr
555 -- (mkUnpackCase x e args Con body)
556 --      returns
557 -- case (e `cast` ...) of bndr { Con args -> body }
558 -- 
559 -- the type of the bndr passed in is irrelevent
560 mkUnpackCase bndr arg unpk_args boxing_con body
561   = Case cast_arg (setIdType bndr bndr_ty) (exprType body) [(DataAlt boxing_con, unpk_args, body)]
562   where
563   (cast_arg, bndr_ty) = go (idType bndr) arg
564   go ty arg 
565     | (tycon, tycon_args, _, _)  <- splitProductType "mkUnpackCase" ty
566     , isNewTyCon tycon && not (isRecursiveTyCon tycon)
567     = go (newTyConInstRhs tycon tycon_args) 
568          (unwrapNewTypeBody tycon tycon_args arg)
569     | otherwise = (arg, ty)
570
571 -- ...and the dual
572 reboxProduct :: [Unique]     -- uniques to create new local binders
573              -> Type         -- type of product to box
574              -> ([Unique],   -- remaining uniques
575                  CoreExpr,   -- boxed product
576                  [Id])       -- Ids being boxed into product
577 reboxProduct us ty
578   = let 
579         (_tycon, _tycon_args, _pack_con, con_arg_tys) = deepSplitProductType "reboxProduct" ty
580  
581         us' = dropList con_arg_tys us
582
583         arg_ids  = zipWith (mkSysLocal (fsLit "rb")) us con_arg_tys
584
585         bind_rhs = mkProductBox arg_ids ty
586
587     in
588       (us', bind_rhs, arg_ids)
589
590 mkProductBox :: [Id] -> Type -> CoreExpr
591 mkProductBox arg_ids ty 
592   = result_expr
593   where 
594     (tycon, tycon_args, pack_con, _con_arg_tys) = splitProductType "mkProductBox" ty
595
596     result_expr
597       | isNewTyCon tycon && not (isRecursiveTyCon tycon) 
598       = wrap (mkProductBox arg_ids (newTyConInstRhs tycon tycon_args))
599       | otherwise = mkConApp pack_con (map Type tycon_args ++ varsToCoreExprs arg_ids)
600
601     wrap expr = wrapNewTypeBody tycon tycon_args expr
602
603
604 -- (mkReboxingAlt us con xs rhs) basically constructs the case
605 -- alternative (con, xs, rhs)
606 -- but it does the reboxing necessary to construct the *source* 
607 -- arguments, xs, from the representation arguments ys.
608 -- For example:
609 --      data T = MkT !(Int,Int) Bool
610 --
611 -- mkReboxingAlt MkT [x,b] r 
612 --      = (DataAlt MkT, [y::Int,z::Int,b], let x = (y,z) in r)
613 --
614 -- mkDataAlt should really be in DataCon, but it can't because
615 -- it manipulates CoreSyn.
616
617 mkReboxingAlt
618   :: [Unique] -- Uniques for the new Ids
619   -> DataCon
620   -> [Var]    -- Source-level args, *including* all evidence vars 
621   -> CoreExpr -- RHS
622   -> CoreAlt
623
624 mkReboxingAlt us con args rhs
625   | not (any isMarkedUnboxed stricts)
626   = (DataAlt con, args, rhs)
627
628   | otherwise
629   = let
630         (binds, args') = go args stricts us
631     in
632     (DataAlt con, args', mkLets binds rhs)
633
634   where
635     stricts = dataConExStricts con ++ dataConStrictMarks con
636
637     go [] _stricts _us = ([], [])
638
639     -- Type variable case
640     go (arg:args) stricts us 
641       | isTyVar arg
642       = let (binds, args') = go args stricts us
643         in  (binds, arg:args')
644
645         -- Term variable case
646     go (arg:args) (str:stricts) us
647       | isMarkedUnboxed str
648       = let (binds, unpacked_args')        = go args stricts us'
649             (us', bind_rhs, unpacked_args) = reboxProduct us (idType arg)
650         in
651             (NonRec arg bind_rhs : binds, unpacked_args ++ unpacked_args')
652       | otherwise
653       = let (binds, args') = go args stricts us
654         in  (binds, arg:args')
655     go (_ : _) [] _ = panic "mkReboxingAlt"
656 \end{code}
657
658
659 %************************************************************************
660 %*                                                                      *
661         Wrapping and unwrapping newtypes and type families
662 %*                                                                      *
663 %************************************************************************
664
665 \begin{code}
666 wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
667 -- The wrapper for the data constructor for a newtype looks like this:
668 --      newtype T a = MkT (a,Int)
669 --      MkT :: forall a. (a,Int) -> T a
670 --      MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a)
671 -- where CoT is the coercion TyCon assoicated with the newtype
672 --
673 -- The call (wrapNewTypeBody T [a] e) returns the
674 -- body of the wrapper, namely
675 --      e `cast` (CoT [a])
676 --
677 -- If a coercion constructor is provided in the newtype, then we use
678 -- it, otherwise the wrap/unwrap are both no-ops 
679 --
680 -- If the we are dealing with a newtype *instance*, we have a second coercion
681 -- identifying the family instance with the constructor of the newtype
682 -- instance.  This coercion is applied in any case (ie, composed with the
683 -- coercion constructor of the newtype or applied by itself).
684
685 wrapNewTypeBody tycon args result_expr
686   = ASSERT( isNewTyCon tycon )
687     wrapFamInstBody tycon args $
688     mkCast result_expr (mkSymCo co)
689   where
690     co = mkAxInstCo (newTyConCo tycon) args
691
692 -- When unwrapping, we do *not* apply any family coercion, because this will
693 -- be done via a CoPat by the type checker.  We have to do it this way as
694 -- computing the right type arguments for the coercion requires more than just
695 -- a spliting operation (cf, TcPat.tcConPat).
696
697 unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
698 unwrapNewTypeBody tycon args result_expr
699   = ASSERT( isNewTyCon tycon )
700     mkCast result_expr (mkAxInstCo (newTyConCo tycon) args)
701
702 -- If the type constructor is a representation type of a data instance, wrap
703 -- the expression into a cast adjusting the expression type, which is an
704 -- instance of the representation type, to the corresponding instance of the
705 -- family instance type.
706 -- See Note [Wrappers for data instance tycons]
707 wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
708 wrapFamInstBody tycon args body
709   | Just co_con <- tyConFamilyCoercion_maybe tycon
710   = mkCast body (mkSymCo (mkAxInstCo co_con args))
711   | otherwise
712   = body
713
714 -- Same as `wrapFamInstBody`, but for type family instances, which are
715 -- represented by a `CoAxiom`, and not a `TyCon`
716 wrapTypeFamInstBody :: CoAxiom -> [Type] -> CoreExpr -> CoreExpr
717 wrapTypeFamInstBody axiom args body
718   = mkCast body (mkSymCo (mkAxInstCo axiom args))
719
720 unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
721 unwrapFamInstScrut tycon args scrut
722   | Just co_con <- tyConFamilyCoercion_maybe tycon
723   = mkCast scrut (mkAxInstCo co_con args)
724   | otherwise
725   = scrut
726
727 unwrapTypeFamInstScrut :: CoAxiom -> [Type] -> CoreExpr -> CoreExpr
728 unwrapTypeFamInstScrut axiom args scrut
729   = mkCast scrut (mkAxInstCo axiom args)
730 \end{code}
731
732
733 %************************************************************************
734 %*                                                                      *
735 \subsection{Primitive operations}
736 %*                                                                      *
737 %************************************************************************
738
739 \begin{code}
740 mkPrimOpId :: PrimOp -> Id
741 mkPrimOpId prim_op 
742   = id
743   where
744     (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op
745     ty   = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
746     name = mkWiredInName gHC_PRIM (primOpOcc prim_op) 
747                          (mkPrimOpIdUnique (primOpTag prim_op))
748                          (AnId id) UserSyntax
749     id   = mkGlobalId (PrimOpId prim_op) name ty info
750                 
751     info = noCafIdInfo
752            `setSpecInfo`          mkSpecInfo (primOpRules prim_op name)
753            `setArityInfo`         arity
754            `setStrictnessInfo` Just strict_sig
755
756 -- For each ccall we manufacture a separate CCallOpId, giving it
757 -- a fresh unique, a type that is correct for this particular ccall,
758 -- and a CCall structure that gives the correct details about calling
759 -- convention etc.  
760 --
761 -- The *name* of this Id is a local name whose OccName gives the full
762 -- details of the ccall, type and all.  This means that the interface 
763 -- file reader can reconstruct a suitable Id
764
765 mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id
766 mkFCallId dflags uniq fcall ty
767   = ASSERT( isEmptyVarSet (tyVarsOfType ty) )
768     -- A CCallOpId should have no free type variables; 
769     -- when doing substitutions won't substitute over it
770     mkGlobalId (FCallId fcall) name ty info
771   where
772     occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty))
773     -- The "occurrence name" of a ccall is the full info about the
774     -- ccall; it is encoded, but may have embedded spaces etc!
775
776     name = mkFCallName uniq occ_str
777
778     info = noCafIdInfo
779            `setArityInfo`         arity
780            `setStrictnessInfo` Just strict_sig
781
782     (_, tau)     = tcSplitForAllTys ty
783     (arg_tys, _) = tcSplitFunTys tau
784     arity        = length arg_tys
785     strict_sig   = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
786 \end{code}
787
788
789 %************************************************************************
790 %*                                                                      *
791 \subsection{DictFuns and default methods}
792 %*                                                                      *
793 %************************************************************************
794
795 Important notes about dict funs and default methods
796 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
797 Dict funs and default methods are *not* ImplicitIds.  Their definition
798 involves user-written code, so we can't figure out their strictness etc
799 based on fixed info, as we can for constructors and record selectors (say).
800
801 We build them as LocalIds, but with External Names.  This ensures that
802 they are taken to account by free-variable finding and dependency
803 analysis (e.g. CoreFVs.exprFreeVars).
804
805 Why shouldn't they be bound as GlobalIds?  Because, in particular, if
806 they are globals, the specialiser floats dict uses above their defns,
807 which prevents good simplifications happening.  Also the strictness
808 analyser treats a occurrence of a GlobalId as imported and assumes it
809 contains strictness in its IdInfo, which isn't true if the thing is
810 bound in the same module as the occurrence.
811
812 It's OK for dfuns to be LocalIds, because we form the instance-env to
813 pass on to the next module (md_insts) in CoreTidy, afer tidying
814 and globalising the top-level Ids.
815
816 BUT make sure they are *exported* LocalIds (mkExportedLocalId) so 
817 that they aren't discarded by the occurrence analyser.
818
819 \begin{code}
820 mkDictFunId :: Name      -- Name to use for the dict fun;
821             -> [TyVar]
822             -> ThetaType
823             -> Class 
824             -> [Type]
825             -> Id
826 -- Implements the DFun Superclass Invariant (see TcInstDcls)
827
828 mkDictFunId dfun_name tvs theta clas tys
829   = mkExportedLocalVar (DFunId n_silent is_nt)
830                        dfun_name
831                        dfun_ty
832                        vanillaIdInfo
833   where
834     is_nt = isNewTyCon (classTyCon clas)
835     (n_silent, dfun_ty) = mkDictFunTy tvs theta clas tys
836
837 mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> (Int, Type)
838 mkDictFunTy tvs theta clas tys
839   = (length silent_theta, dfun_ty)
840   where
841     dfun_ty = mkSigmaTy tvs (silent_theta ++ theta) (mkClassPred clas tys)
842     silent_theta 
843       | null tvs, null theta 
844       = []
845       | otherwise
846       = filterOut discard $
847         substTheta (zipTopTvSubst (classTyVars clas) tys)
848                    (classSCTheta clas)
849                    -- See Note [Silent Superclass Arguments]
850     discard pred = any (`eqPred` pred) theta
851                  -- See the DFun Superclass Invariant in TcInstDcls
852 \end{code}
853
854
855 %************************************************************************
856 %*                                                                      *
857 \subsection{Un-definable}
858 %*                                                                      *
859 %************************************************************************
860
861 These Ids can't be defined in Haskell.  They could be defined in
862 unfoldings in the wired-in GHC.Prim interface file, but we'd have to
863 ensure that they were definitely, definitely inlined, because there is
864 no curried identifier for them.  That's what mkCompulsoryUnfolding
865 does.  If we had a way to get a compulsory unfolding from an interface
866 file, we could do that, but we don't right now.
867
868 unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
869 just gets expanded into a type coercion wherever it occurs.  Hence we
870 add it as a built-in Id with an unfolding here.
871
872 The type variables we use here are "open" type variables: this means
873 they can unify with both unlifted and lifted types.  Hence we provide
874 another gun with which to shoot yourself in the foot.
875
876 \begin{code}
877 lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName, coercionTokenName :: Name
878 unsafeCoerceName  = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey  unsafeCoerceId
879 nullAddrName      = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#")     nullAddrIdKey      nullAddrId
880 seqName           = mkWiredInIdName gHC_PRIM (fsLit "seq")           seqIdKey           seqId
881 realWorldName     = mkWiredInIdName gHC_PRIM (fsLit "realWorld#")    realWorldPrimIdKey realWorldPrimId
882 lazyIdName        = mkWiredInIdName gHC_BASE (fsLit "lazy")         lazyIdKey           lazyId
883 coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId
884 \end{code}
885
886 \begin{code}
887 ------------------------------------------------
888 -- unsafeCoerce# :: forall a b. a -> b
889 unsafeCoerceId :: Id
890 unsafeCoerceId
891   = pcMiscPrelId unsafeCoerceName ty info
892   where
893     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
894                        `setUnfoldingInfo`  mkCompulsoryUnfolding rhs
895            
896
897     ty  = mkForAllTys [openAlphaTyVar,openBetaTyVar]
898                       (mkFunTy openAlphaTy openBetaTy)
899     [x] = mkTemplateLocals [openAlphaTy]
900     rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
901           Cast (Var x) (mkUnsafeCo openAlphaTy openBetaTy)
902
903 ------------------------------------------------
904 nullAddrId :: Id
905 -- nullAddr# :: Addr#
906 -- The reason is is here is because we don't provide 
907 -- a way to write this literal in Haskell.
908 nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info
909   where
910     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
911                        `setUnfoldingInfo`  mkCompulsoryUnfolding (Lit nullAddrLit)
912
913 ------------------------------------------------
914 seqId :: Id     -- See Note [seqId magic]
915 seqId = pcMiscPrelId seqName ty info
916   where
917     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
918                        `setUnfoldingInfo`  mkCompulsoryUnfolding rhs
919                        `setSpecInfo`       mkSpecInfo [seq_cast_rule]
920            
921
922     ty  = mkForAllTys [alphaTyVar,betaTyVar]
923                       (mkFunTy alphaTy (mkFunTy betaTy betaTy))
924               -- NB argBetaTyVar; see Note [seqId magic]
925
926     [x,y] = mkTemplateLocals [alphaTy, betaTy]
927     rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x betaTy [(DEFAULT, [], Var y)])
928
929     -- See Note [Built-in RULES for seq]
930     seq_cast_rule = BuiltinRule { ru_name  = fsLit "seq of cast"
931                                 , ru_fn    = seqName
932                                 , ru_nargs = 4
933                                 , ru_try   = match_seq_of_cast
934                                 }
935
936 match_seq_of_cast :: Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
937     -- See Note [Built-in RULES for seq]
938 match_seq_of_cast _ _ [Type _, Type res_ty, Cast scrut co, expr]
939   = Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty,
940                               scrut, expr])
941 match_seq_of_cast _ _ _ = Nothing
942
943 ------------------------------------------------
944 lazyId :: Id    -- See Note [lazyId magic]
945 lazyId = pcMiscPrelId lazyIdName ty info
946   where
947     info = noCafIdInfo
948     ty  = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
949 \end{code}
950
951 Note [Unsafe coerce magic]
952 ~~~~~~~~~~~~~~~~~~~~~~~~~~
953 We define a *primitive*
954    GHC.Prim.unsafeCoerce#
955 and then in the base library we define the ordinary function
956    Unsafe.Coerce.unsafeCoerce :: forall (a:*) (b:*). a -> b
957    unsafeCoerce x = unsafeCoerce# x
958
959 Notice that unsafeCoerce has a civilized (albeit still dangerous)
960 polymorphic type, whose type args have kind *.  So you can't use it on
961 unboxed values (unsafeCoerce 3#).
962
963 In contrast unsafeCoerce# is even more dangerous because you *can* use
964 it on unboxed things, (unsafeCoerce# 3#) :: Int. Its type is
965    forall (a:OpenKind) (b:OpenKind). a -> b
966
967 Note [seqId magic]
968 ~~~~~~~~~~~~~~~~~~
969 'GHC.Prim.seq' is special in several ways. 
970
971 a) Its second arg can have an unboxed type
972       x `seq` (v +# w)
973    Hence its second type variable has ArgKind
974
975 b) Its fixity is set in LoadIface.ghcPrimIface
976
977 c) It has quite a bit of desugaring magic. 
978    See DsUtils.lhs Note [Desugaring seq (1)] and (2) and (3)
979
980 d) There is some special rule handing: Note [User-defined RULES for seq]
981
982 e) See Note [Typing rule for seq] in TcExpr.
983
984 Note [User-defined RULES for seq]
985 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
986 Roman found situations where he had
987       case (f n) of _ -> e
988 where he knew that f (which was strict in n) would terminate if n did.
989 Notice that the result of (f n) is discarded. So it makes sense to
990 transform to
991       case n of _ -> e
992
993 Rather than attempt some general analysis to support this, I've added
994 enough support that you can do this using a rewrite rule:
995
996   RULE "f/seq" forall n.  seq (f n) e = seq n e
997
998 You write that rule.  When GHC sees a case expression that discards
999 its result, it mentally transforms it to a call to 'seq' and looks for
1000 a RULE.  (This is done in Simplify.rebuildCase.)  As usual, the
1001 correctness of the rule is up to you.
1002
1003 To make this work, we need to be careful that the magical desugaring
1004 done in Note [seqId magic] item (c) is *not* done on the LHS of a rule.
1005 Or rather, we arrange to un-do it, in DsBinds.decomposeRuleLhs.
1006
1007 Note [Built-in RULES for seq]
1008 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1009 We also have the following built-in rule for seq
1010
1011   seq (x `cast` co) y = seq x y
1012
1013 This eliminates unnecessary casts and also allows other seq rules to
1014 match more often.  Notably,     
1015
1016    seq (f x `cast` co) y  -->  seq (f x) y
1017   
1018 and now a user-defined rule for seq (see Note [User-defined RULES for seq])
1019 may fire.
1020
1021
1022 Note [lazyId magic]
1023 ~~~~~~~~~~~~~~~~~~~
1024     lazy :: forall a?. a? -> a?   (i.e. works for unboxed types too)
1025
1026 Used to lazify pseq:   pseq a b = a `seq` lazy b
1027
1028 Also, no strictness: by being a built-in Id, all the info about lazyId comes from here,
1029 not from GHC.Base.hi.   This is important, because the strictness
1030 analyser will spot it as strict!
1031
1032 Also no unfolding in lazyId: it gets "inlined" by a HACK in CorePrep.
1033 It's very important to do this inlining *after* unfoldings are exposed 
1034 in the interface file.  Otherwise, the unfolding for (say) pseq in the
1035 interface file will not mention 'lazy', so if we inline 'pseq' we'll totally
1036 miss the very thing that 'lazy' was there for in the first place.
1037 See Trac #3259 for a real world example.
1038
1039 lazyId is defined in GHC.Base, so we don't *have* to inline it.  If it
1040 appears un-applied, we'll end up just calling it.
1041
1042 -------------------------------------------------------------
1043 @realWorld#@ used to be a magic literal, \tr{void#}.  If things get
1044 nasty as-is, change it back to a literal (@Literal@).
1045
1046 voidArgId is a Local Id used simply as an argument in functions
1047 where we just want an arg to avoid having a thunk of unlifted type.
1048 E.g.
1049         x = \ void :: State# RealWorld -> (# p, q #)
1050
1051 This comes up in strictness analysis
1052
1053 \begin{code}
1054 realWorldPrimId :: Id
1055 realWorldPrimId -- :: State# RealWorld
1056   = pcMiscPrelId realWorldName realWorldStatePrimTy
1057                  (noCafIdInfo `setUnfoldingInfo` evaldUnfolding)
1058         -- The evaldUnfolding makes it look that realWorld# is evaluated
1059         -- which in turn makes Simplify.interestingArg return True,
1060         -- which in turn makes INLINE things applied to realWorld# likely
1061         -- to be inlined
1062
1063 voidArgId :: Id
1064 voidArgId       -- :: State# RealWorld
1065   = mkSysLocal (fsLit "void") voidArgIdKey realWorldStatePrimTy
1066
1067 coercionTokenId :: Id         -- :: () ~ ()
1068 coercionTokenId -- Used to replace Coercion terms when we go to STG
1069   = pcMiscPrelId coercionTokenName 
1070                  (mkTyConApp eqPrimTyCon [liftedTypeKind, unitTy, unitTy])
1071                  noCafIdInfo
1072 \end{code}
1073
1074
1075 \begin{code}
1076 pcMiscPrelId :: Name -> Type -> IdInfo -> Id
1077 pcMiscPrelId name ty info
1078   = mkVanillaGlobalWithInfo name ty info
1079     -- We lie and say the thing is imported; otherwise, we get into
1080     -- a mess with dependency analysis; e.g., core2stg may heave in
1081     -- random calls to GHCbase.unpackPS__.  If GHCbase is the module
1082     -- being compiled, then it's just a matter of luck if the definition
1083     -- will be in "the right place" to be in scope.
1084 \end{code}