MkId.hs 62 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
2
3
4
{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1998

5
6
7
8

This module contains definitions for the IdInfo for things that
have a standard form, namely:

Thomas Schilling's avatar
Thomas Schilling committed
9
10
11
12
- data constructors
- record selectors
- method and superclass selectors
- primitive operations
Austin Seipp's avatar
Austin Seipp committed
13
-}
14

15
{-# LANGUAGE CPP #-}
Ian Lynagh's avatar
Ian Lynagh committed
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

Ian Lynagh's avatar
Ian Lynagh committed
28
29
        -- And some particular Ids; see below for why they are wired in
        wiredInIds, ghcPrimIds,
30
31
        unsafeCoerceName, unsafeCoerceId, realWorldPrimId,
        voidPrimId, voidArgId,
32
        nullAddrId, seqId, lazyId, lazyIdKey, runRWId,
33
        coercionTokenId, magicDictId, coerceId,
Ben Gamari's avatar
Ben Gamari committed
34
        proxyHashId, noinlineId, noinlineIdName,
35

36
37
        -- Re-export error Ids
        module PrelRules
38
39
40
41
    ) where

#include "HsVersions.h"

42
43
import GhcPrelude

Simon Marlow's avatar
Simon Marlow committed
44
45
import Rules
import TysPrim
46
import TysWiredIn
Simon Marlow's avatar
Simon Marlow committed
47
48
import PrelRules
import Type
49
50
import FamInstEnv
import Coercion
Simon Marlow's avatar
Simon Marlow committed
51
import TcType
52
import MkCore
53
import CoreUtils        ( exprType, mkCast )
Simon Marlow's avatar
Simon Marlow committed
54
55
56
import CoreUnfold
import Literal
import TyCon
57
import CoAxiom
Simon Marlow's avatar
Simon Marlow committed
58
import Class
59
import NameSet
Simon Marlow's avatar
Simon Marlow committed
60
61
62
63
64
65
import Name
import PrimOp
import ForeignCall
import DataCon
import Id
import IdInfo
66
import Demand
67
import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
68
import Unique
69
import UniqSupply
70
import PrelNames
Simon Marlow's avatar
Simon Marlow committed
71
72
import BasicTypes       hiding ( SuccessFlag(..) )
import Util
73
import Pair
Ian Lynagh's avatar
Ian Lynagh committed
74
import DynFlags
75
import Outputable
76
import FastString
Simon Marlow's avatar
Simon Marlow committed
77
import ListSetOps
78
import qualified GHC.LanguageExtensions as LangExt
79
80

import Data.Maybe       ( maybeToList )
81

Austin Seipp's avatar
Austin Seipp committed
82
83
84
{-
************************************************************************
*                                                                      *
85
\subsection{Wired in Ids}
Austin Seipp's avatar
Austin Seipp committed
86
87
*                                                                      *
************************************************************************
88

89
90
Note [Wired-in Ids]
~~~~~~~~~~~~~~~~~~~
Simon Peyton Jones's avatar
Simon Peyton Jones committed
91
92
93
94
A "wired-in" Id can be referred to directly in GHC (e.g. 'voidPrimId')
rather than by looking it up its name in some environment or fetching
it from an interface file.

95
96
There are several reasons why an Id might appear in the wiredInIds:

Simon Peyton Jones's avatar
Simon Peyton Jones committed
97
98
99
100
101
102
* ghcPrimIds: see Note [ghcPrimIds (aka pseudoops)]

* magicIds: see Note [magicIds]

* errorIds, defined in coreSyn/MkCore.hs.
  These error functions (e.g. rUNTIME_ERROR_ID) are wired in
Gabor Greif's avatar
Gabor Greif committed
103
  because the desugarer generates code that mentions them directly
Simon Peyton Jones's avatar
Simon Peyton Jones committed
104
105
106
107
108
109
110
111
112
113

In all cases except ghcPrimIds, there is a definition site in a
library module, which may be called (e.g. in higher order situations);
but the wired-in version means that the details are never read from
that module's interface file; instead, the full definition is right
here.

Note [ghcPrimIds (aka pseudoops)]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The ghcPrimIds
114

Simon Peyton Jones's avatar
Simon Peyton Jones committed
115
  * Are exported from GHC.Prim
116

Simon Peyton Jones's avatar
Simon Peyton Jones committed
117
118
  * Can't be defined in Haskell, and hence no Haskell binding site,
    but have perfectly reasonable unfoldings in Core
119

Simon Peyton Jones's avatar
Simon Peyton Jones committed
120
121
  * Either have a CompulsoryUnfolding (hence always inlined), or
        of an EvaldUnfolding and void representation (e.g. void#)
122

Simon Peyton Jones's avatar
Simon Peyton Jones committed
123
124
  * Are (or should be) defined in primops.txt.pp as 'pseudoop'
    Reason: that's how we generate documentation for them
125

Simon Peyton Jones's avatar
Simon Peyton Jones committed
126
127
128
Note [magicIds]
~~~~~~~~~~~~~~~
The magicIds
129

Simon Peyton Jones's avatar
Simon Peyton Jones committed
130
131
132
133
134
135
136
137
138
  * Are expotted from GHC.Maic

  * Can be defined in Haskell (and are, in ghc-prim:GHC/Magic.hs).
    This definition at least generates Haddock documentation for them.

  * May or may not have a CompulsoryUnfolding.

  * But have some special behaviour that can't be done via an
    unfolding from an interface file
Austin Seipp's avatar
Austin Seipp committed
139
-}
140

141
wiredInIds :: [Id]
142
wiredInIds
Simon Peyton Jones's avatar
Simon Peyton Jones committed
143
  =  magicIds
144
  ++ ghcPrimIds
Simon Peyton Jones's avatar
Simon Peyton Jones committed
145
146
147
148
  ++ errorIds           -- Defined in MkCore

magicIds :: [Id]    -- See Note [magicIds]
magicIds = [lazyId, oneShotId, runRWId, noinlineId]
149

Simon Peyton Jones's avatar
Simon Peyton Jones committed
150
ghcPrimIds :: [Id]  -- See Note [ghcPrimIds (aka pseudoops)]
151
ghcPrimIds
Simon Peyton Jones's avatar
Simon Peyton Jones committed
152
153
154
155
156
157
158
159
  = [ realWorldPrimId
    , voidPrimId
    , unsafeCoerceId
    , nullAddrId
    , seqId
    , magicDictId
    , coerceId
    , proxyHashId
160
161
    ]

Austin Seipp's avatar
Austin Seipp committed
162
163
164
{-
************************************************************************
*                                                                      *
165
\subsection{Data constructors}
Austin Seipp's avatar
Austin Seipp committed
166
167
*                                                                      *
************************************************************************
168

169
170
171
172
The wrapper for a constructor is an ordinary top-level binding that evaluates
any strict args, unboxes any args that are going to be flattened, and calls
the worker.

173
174
We're going to build a constructor that looks like:

Ian Lynagh's avatar
Ian Lynagh committed
175
        data (Data a, C b) =>  T a b = T1 !a !Int b
176

177
        T1 = /\ a b ->
Ian Lynagh's avatar
Ian Lynagh committed
178
179
180
181
             \d1::Data a, d2::C b ->
             \p q r -> case p of { p ->
                       case q of { q ->
                       Con T1 [a,b] [p,q,r]}}
182
183
184
185
186
187
188
189
190
191

Notice that

* d2 is thrown away --- a context in a data decl is used to make sure
  one *could* construct dictionaries at the site the constructor
  is used, but the dictionary isn't actually used.

* We have to check that we can construct Data dictionaries for
  the types a and Int.  Once we've done that we can throw d1 away too.

192
* We use (case p of q -> ...) to evaluate p, rather than "seq" because
193
  all that matters is that the arguments are evaluated.  "seq" is
194
195
196
  very careful to preserve evaluation order, which we don't need
  to be here.

197
198
199
200
201
202
203
204
205
  You might think that we could simply give constructors some strictness
  info, like PrimOps, and let CoreToStg do the let-to-case transformation.
  But we don't do that because in the case of primops and functions strictness
  is a *property* not a *requirement*.  In the case of constructors we need to
  do something active to evaluate the argument.

  Making an explicit case expression allows the simplifier to eliminate
  it in the (common) case where the constructor arg is already evaluated.

206
207
Note [Wrappers for data instance tycons]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
208
209
In the case of data instances, the wrapper also applies the coercion turning
the representation type into the family instance type to cast the result of
210
211
212
213
214
the wrapper.  For example, consider the declarations

  data family Map k :: * -> *
  data instance Map (a, b) v = MapPair (Map a (Pair b v))

215
216
217
218
219
220
221
The tycon to which the datacon MapPair belongs gets a unique internal
name of the form :R123Map, and we call it the representation tycon.
In contrast, Map is the family tycon (accessible via
tyConFamInst_maybe). A coercion allows you to move between
representation and family type.  It is accessible from :R123Map via
tyConFamilyCoercion_maybe and has kind

222
  Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v}
223
224

The wrapper and worker of MapPair get the types
225

Ian Lynagh's avatar
Ian Lynagh committed
226
        -- Wrapper
227
  $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v
228
  $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v)
229

Ian Lynagh's avatar
Ian Lynagh committed
230
        -- Worker
231
  MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v
232

233
This coercion is conditionally applied by wrapFamInstBody.
234

235
It's a bit more complicated if the data instance is a GADT as well!
236

237
   data instance T [a] where
Ian Lynagh's avatar
Ian Lynagh committed
238
        T1 :: forall b. b -> T [Maybe b]
239

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
240
Hence we translate to
241

Ian Lynagh's avatar
Ian Lynagh committed
242
        -- Wrapper
243
  $WT1 :: forall b. b -> T [Maybe b]
244
  $WT1 b v = T1 (Maybe b) b (Maybe b) v
Ian Lynagh's avatar
Ian Lynagh committed
245
                        `cast` sym (Co7T (Maybe b))
246

Ian Lynagh's avatar
Ian Lynagh committed
247
        -- Worker
248
  T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c
249

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
250
251
252
        -- Coercion from family type to representation type
  Co7T a :: T [a] ~ :R7T a

253
254
255
256
257
258
259
260
261
262
263
Note [Newtype datacons]
~~~~~~~~~~~~~~~~~~~~~~~
The "data constructor" for a newtype should always be vanilla.  At one
point this wasn't true, because the newtype arising from
     class C a => D a
looked like
       newtype T:D a = D:D (C a)
so the data constructor for T:C had a single argument, namely the
predicate (C a).  But now we treat that as an ordinary argument, not
part of the theta-type, so all is well.

264

Austin Seipp's avatar
Austin Seipp committed
265
266
************************************************************************
*                                                                      *
267
\subsection{Dictionary selectors}
Austin Seipp's avatar
Austin Seipp committed
268
269
*                                                                      *
************************************************************************
270

271
Selecting a field for a dictionary.  If there is just one field, then
272
there's nothing to do.
273

274
Dictionary selectors may get nested forall-types.  Thus:
275

276
277
        class Foo a where
          op :: forall b. Ord b => a -> b -> b
278

279
Then the top-level type for op is
280

281
282
        op :: forall a. Foo a =>
              forall b. Ord b =>
283
              a -> b -> b
284

Austin Seipp's avatar
Austin Seipp committed
285
-}
286

287
288
mkDictSelId :: Name          -- Name of one of the *value* selectors
                             -- (dictionary superclass or method)
289
            -> Class -> Id
290
mkDictSelId name clas
291
292
  = mkGlobalId (ClassOpId clas) name sel_ty info
  where
293
    tycon          = classTyCon clas
294
    sel_names      = map idName (classAllSelIds clas)
295
296
    new_tycon      = isNewTyCon tycon
    [data_con]     = tyConDataCons tycon
297
    tyvars         = dataConUserTyVarBinders data_con
Simon Peyton Jones's avatar
Simon Peyton Jones committed
298
    n_ty_args      = length tyvars
299
    arg_tys        = dataConRepArgTys data_con  -- Includes the dictionary superclasses
300
301
    val_index      = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name

Simon Peyton Jones's avatar
Simon Peyton Jones committed
302
    sel_ty = mkForAllTys tyvars $
303
             mkFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $
304
305
             getNth arg_tys val_index

306
    base_info = noCafIdInfo
Richard Eisenberg's avatar
Richard Eisenberg committed
307
308
309
                `setArityInfo`          1
                `setStrictnessInfo`     strict_sig
                `setLevityInfoWithType` sel_ty
310
311
312

    info | new_tycon
         = base_info `setInlinePragInfo` alwaysInlinePragma
313
314
                     `setUnfoldingInfo`  mkInlineUnfoldingWithArity 1
                                           (mkDictSelRhs clas val_index)
315
316
                   -- See Note [Single-method classes] in TcInstDcls
                   -- for why alwaysInlinePragma
317
318

         | otherwise
319
         = base_info `setRuleInfo` mkRuleInfo [rule]
320
321
322
                   -- Add a magic BuiltinRule, but no unfolding
                   -- so that the rule is always available to fire.
                   -- See Note [ClassOp/DFun selection] in TcInstDcls
323

324
    -- This is the built-in rule that goes
325
326
327
    --      op (dfT d1 d2) --->  opT d1 d2
    rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS`
                                     occNameFS (getOccName name)
328
                       , ru_fn    = name
329
                       , ru_nargs = n_ty_args + 1
330
                       , ru_try   = dictSelRule val_index n_ty_args }
331

332
333
334
335
        -- The strictness signature is of the form U(AAAVAAAA) -> T
        -- where the V depends on which item we are selecting
        -- It's worth giving one, so that absence info etc is generated
        -- even if the selector isn't inlined
336

337
    strict_sig = mkClosedStrictSig [arg_dmd] topRes
338
    arg_dmd | new_tycon = evalDmd
339
            | otherwise = mkManyUsedDmd $
340
341
342
343
344
345
346
347
348
                          mkProdDmd [ if name == sel_name then evalDmd else absDmd
                                    | sel_name <- sel_names ]

mkDictSelRhs :: Class
             -> Int         -- 0-indexed selector among (superclasses ++ methods)
             -> CoreExpr
mkDictSelRhs clas val_index
  = mkLams tyvars (Lam dict_id rhs_body)
  where
349
350
351
352
353
    tycon          = classTyCon clas
    new_tycon      = isNewTyCon tycon
    [data_con]     = tyConDataCons tycon
    tyvars         = dataConUnivTyVars data_con
    arg_tys        = dataConRepArgTys data_con  -- Includes the dictionary superclasses
354

355
    the_arg_id     = getNth arg_ids val_index
356
357
358
    pred           = mkClassPred clas (mkTyVarTys tyvars)
    dict_id        = mkTemplateLocal 1 pred
    arg_ids        = mkTemplateLocalsNum 2 arg_tys
359

360
    rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars) (Var dict_id)
361
             | otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
362
                                [(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)]
363
364
                                -- varToCoreExpr needed for equality superclass selectors
                                --   sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }
365

366
dictSelRule :: Int -> Arity -> RuleFun
367
368
369
-- Tries to persuade the argument to look like a constructor
-- application, using exprIsConApp_maybe, and then selects
-- from it
370
--       sel_i t1..tk (D t1..tk op1 ... opm) = opi
371
--
372
dictSelRule val_index n_ty_args _ id_unf _ args
373
  | (dict_arg : _) <- drop n_ty_args args
374
  , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
375
  = Just (getNth con_args val_index)
376
377
  | otherwise
  = Nothing
378

Austin Seipp's avatar
Austin Seipp committed
379
380
381
{-
************************************************************************
*                                                                      *
Simon Peyton Jones's avatar
Simon Peyton Jones committed
382
        Data constructors
Austin Seipp's avatar
Austin Seipp committed
383
384
385
*                                                                      *
************************************************************************
-}
386
387
388
389
390
391
392
393

mkDataConWorkId :: Name -> DataCon -> Id
mkDataConWorkId wkr_name data_con
  | isNewTyCon tycon
  = mkGlobalId (DataConWrapId data_con) wkr_name nt_wrap_ty nt_work_info
  | otherwise
  = mkGlobalId (DataConWorkId data_con) wkr_name alg_wkr_ty wkr_info

394
  where
395
396
397
398
399
400
    tycon = dataConTyCon data_con

        ----------- Workers for data types --------------
    alg_wkr_ty = dataConRepType data_con
    wkr_arity = dataConRepArity data_con
    wkr_info  = noCafIdInfo
Richard Eisenberg's avatar
Richard Eisenberg committed
401
402
403
404
405
406
407
                `setArityInfo`          wkr_arity
                `setStrictnessInfo`     wkr_sig
                `setUnfoldingInfo`      evaldUnfolding  -- Record that it's evaluated,
                                                        -- even if arity = 0
                `setLevityInfoWithType` alg_wkr_ty
                  -- NB: unboxed tuples have workers, so we can't use
                  -- setNeverLevPoly
408

409
    wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con)
410
        --      Note [Data-con worker strictness]
411
        -- Notice that we do *not* say the worker Id is strict
412
413
        -- even if the data constructor is declared strict
        --      e.g.    data T = MkT !(Int,Int)
414
415
416
417
        -- Why?  Because the *wrapper* $WMkT is strict (and its unfolding has
        -- case expressions that do the evals) but the *worker* MkT itself is
        --  not. If we pretend it is strict then when we see
        --      case x of y -> MkT y
418
        -- the simplifier thinks that y is "sure to be evaluated" (because
419
420
        -- the worker MkT is strict) and drops the case.  No, the workerId
        -- MkT is not strict.
421
        --
422
423
        -- However, the worker does have StrictnessMarks.  When the simplifier
        -- sees a pattern
424
425
426
427
428
429
430
431
432
433
434
        --      case e of MkT x -> ...
        -- it uses the dataConRepStrictness of MkT to mark x as evaluated;
        -- but that's fine... dataConRepStrictness comes from the data con
        -- not from the worker Id.

        ----------- Workers for newtypes --------------
    (nt_tvs, _, nt_arg_tys, _) = dataConSig data_con
    res_ty_args  = mkTyVarTys nt_tvs
    nt_wrap_ty   = dataConUserType data_con
    nt_work_info = noCafIdInfo          -- The NoCaf-ness is set by noCafIdInfo
                  `setArityInfo` 1      -- Arity 1
Richard Eisenberg's avatar
Richard Eisenberg committed
435
436
437
                  `setInlinePragInfo`     alwaysInlinePragma
                  `setUnfoldingInfo`      newtype_unf
                  `setLevityInfoWithType` nt_wrap_ty
438
439
440
    id_arg1      = mkTemplateLocal 1 (head nt_arg_tys)
    newtype_unf  = ASSERT2( isVanillaDataCon data_con &&
                            isSingleton nt_arg_tys, ppr data_con  )
441
442
443
                              -- Note [Newtype datacons]
                   mkCompulsoryUnfolding $
                   mkLams nt_tvs $ Lam id_arg1 $
444
                   wrapNewTypeBody tycon res_ty_args (Var id_arg1)
445

446
447
dataConCPR :: DataCon -> DmdResult
dataConCPR con
448
  | isDataTyCon tycon     -- Real data types only; that is,
449
                          -- not unboxed tuples or newtypes
450
  , null (dataConExTyVars con)  -- No existentials
451
452
  , wkr_arity > 0
  , wkr_arity <= mAX_CPR_SIZE
453
454
  = if is_prod then vanillaCprProdRes (dataConRepArity con)
               else cprSumRes (dataConTag con)
455
  | otherwise
456
  = topRes
457
  where
458
459
    is_prod   = isProductTyCon tycon
    tycon     = dataConTyCon con
460
461
462
463
464
    wkr_arity = dataConRepArity con

    mAX_CPR_SIZE :: Arity
    mAX_CPR_SIZE = 10
    -- We do not treat very big tuples as CPR-ish:
465
466
467
    --      a) for a start we get into trouble because there aren't
    --         "enough" unboxed tuple types (a tiresome restriction,
    --         but hard to fix),
468
469
470
471
    --      b) more importantly, big unboxed tuples get returned mainly
    --         on the stack, and are often then allocated in the heap
    --         by the caller.  So doing CPR for them may in fact make
    --         things worse.
472

Austin Seipp's avatar
Austin Seipp committed
473
{-
474
475
-------------------------------------------------
--         Data constructor representation
476
477
--
-- This is where we decide how to wrap/unwrap the
478
479
480
-- constructor fields
--
--------------------------------------------------
Austin Seipp's avatar
Austin Seipp committed
481
-}
482
483
484
485

type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr)
  -- Unbox: bind rep vars by decomposing src var

486
data Boxer = UnitBox | Boxer (TCvSubst -> UniqSM ([Var], CoreExpr))
487
488
  -- Box:   build src arg using these rep vars

489
-- | Data Constructor Boxer
490
491
492
493
newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))
                       -- Bind these src-level vars, returning the
                       -- rep-level vars to bind in the pattern

494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
{-
Note [Inline partially-applied constructor wrappers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

We allow the wrapper to inline when partially applied to avoid
boxing values unnecessarily. For example, consider

   data Foo a = Foo !Int a

   instance Traversable Foo where
     traverse f (Foo i a) = Foo i <$> f a

This desugars to

   traverse f foo = case foo of
        Foo i# a -> let i = I# i#
                    in map ($WFoo i) (f a)

If the wrapper `$WFoo` is not inlined, we get a fruitless reboxing of `i`.
But if we inline the wrapper, we get

   map (\a. case i of I# i# a -> Foo i# a) (f a)

and now case-of-known-constructor eliminates the redundant allocation.
-}

520
521
522
523
524
525
526
527
mkDataConRep :: DynFlags
             -> FamInstEnvs
             -> Name
             -> Maybe [HsImplBang]
                -- See Note [Bangs on imported data constructors]
             -> DataCon
             -> UniqSM DataConRep
mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
528
529
  | not wrapper_reqd
  = return NoDataConRep
530

531
  | otherwise
532
  = do { wrap_args <- mapM newLocal wrap_arg_tys
533
       ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers)
534
535
536
537
                                 initial_wrap_app

       ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info
             wrap_info = noCafIdInfo
538
539
540
                         `setArityInfo`         wrap_arity
                             -- It's important to specify the arity, so that partial
                             -- applications are treated as values
541
                         `setInlinePragInfo`    wrap_prag
542
543
544
545
546
                         `setUnfoldingInfo`     wrap_unf
                         `setStrictnessInfo`    wrap_sig
                             -- We need to get the CAF info right here because TidyPgm
                             -- does not tidy the IdInfo of implicit bindings (like the wrapper)
                             -- so it not make sure that the CAF info is sane
Richard Eisenberg's avatar
Richard Eisenberg committed
547
                         `setNeverLevPoly`      wrap_ty
548
549

             wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
550

551
552
553
554
555
             wrap_arg_dmds =
               replicate (length theta) topDmd ++ map mk_dmd arg_ibangs
               -- Don't forget the dictionary arguments when building
               -- the strictness signature (#14290).

556
             mk_dmd str | isBanged str = evalDmd
557
                        | otherwise           = topDmd
558

559
560
561
562
             wrap_prag = alwaysInlinePragma `setInlinePragmaActivation`
                         ActiveAfter NoSourceText 2
                         -- See Note [Activation for data constructor wrappers]

563
564
565
566
567
568
569
570
             -- The wrapper will usually be inlined (see wrap_unf), so its
             -- strictness and CPR info is usually irrelevant. But this is
             -- not always the case; GHC may choose not to inline it. In
             -- particular, the wrapper constructor is not inlined inside
             -- an INLINE rhs or when it is not applied to any arguments.
             -- See Note [Inline partially-applied constructor wrappers]
             -- Passing Nothing here allows the wrapper to inline when
             -- unsaturated.
571
             wrap_unf = mkInlineUnfolding wrap_rhs
572
573
574
             wrap_rhs = mkLams wrap_tvs $
                        mkLams wrap_args $
                        wrapFamInstBody tycon res_ty_args $
575
576
577
578
579
580
                        wrap_body

       ; return (DCR { dcr_wrap_id = wrap_id
                     , dcr_boxer   = mk_boxer boxers
                     , dcr_arg_tys = rep_tys
                     , dcr_stricts = rep_strs
581
                     , dcr_bangs   = arg_ibangs }) }
582

583
  where
584
585
    (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty)
      = dataConFullSig data_con
586
    wrap_tvs     = dataConUserTyVars data_con
niteria's avatar
niteria committed
587
    res_ty_args  = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs
588

589
590
591
    tycon        = dataConTyCon data_con       -- The representation TyCon (not family)
    wrap_ty      = dataConUserType data_con
    ev_tys       = eqSpecPreds eq_spec ++ theta
592
    all_arg_tys  = ev_tys ++ orig_arg_tys
593
    ev_ibangs    = map (const HsLazy) ev_tys
594
    orig_bangs   = dataConSrcBangs data_con
595
596
597

    wrap_arg_tys = theta ++ orig_arg_tys
    wrap_arity   = length wrap_arg_tys
598
599
600
             -- The wrap_args are the arguments *other than* the eq_spec
             -- Because we are going to apply the eq_spec args manually in the
             -- wrapper
601

602
603
604
605
606
607
608
609
610
    arg_ibangs =
      case mb_bangs of
        Nothing    -> zipWith (dataConSrcToImplBang dflags fam_envs)
                              orig_arg_tys orig_bangs
        Just bangs -> bangs

    (rep_tys_w_strs, wrappers)
      = unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs))

611
    (unboxers, boxers) = unzip wrappers
612
613
    (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)

614
615
616
617
618
619
620
621
622
623
624
625
626
627
    wrapper_reqd =
        (not (isNewTyCon tycon)
                     -- (Most) newtypes have only a worker, with the exception
                     -- of some newtypes written with GADT syntax. See below.
         && (any isBanged (ev_ibangs ++ arg_ibangs)
                     -- Some forcing/unboxing (includes eq_spec)
             || isFamInstTyCon tycon  -- Cast result
             || (not $ null eq_spec))) -- GADT
      || dataConUserTyVarsArePermuted data_con
                     -- If the data type was written with GADT syntax and
                     -- orders the type variables differently from what the
                     -- worker expects, it needs a data con wrapper to reorder
                     -- the type variables.
                     -- See Note [Data con wrappers and GADT syntax].
628
629

    initial_wrap_app = Var (dataConWorkId data_con)
630
631
632
                       `mkTyApps`  res_ty_args
                       `mkVarApps` ex_tvs
                       `mkCoApps`  map (mkReflCo Nominal . eqSpecType) eq_spec
633
634

    mk_boxer :: [Boxer] -> DataConBoxer
635
    mk_boxer boxers = DCB (\ ty_args src_vars ->
636
                      do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars
637
                               subst1 = zipTvSubst univ_tvs ty_args
638
639
                               subst2 = extendTvSubstList subst1 ex_tvs
                                                          (mkTyVarTys ex_vars)
640
                         ; (rep_ids, binds) <- go subst2 boxers term_vars
641
642
643
644
645
646
647
648
649
650
651
652
653
                         ; return (ex_vars ++ rep_ids, binds) } )

    go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], [])
    go subst (UnitBox : boxers) (src_var : src_vars)
      = do { (rep_ids2, binds) <- go subst boxers src_vars
           ; return (src_var : rep_ids2, binds) }
    go subst (Boxer boxer : boxers) (src_var : src_vars)
      = do { (rep_ids1, arg)  <- boxer subst
           ; (rep_ids2, binds) <- go subst boxers src_vars
           ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) }
    go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con)

    mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr
654
    mk_rep_app [] con_app
655
      = return con_app
656
    mk_rep_app ((wrap_arg, unboxer) : prs) con_app
657
658
659
660
      = do { (rep_ids, unbox_fn) <- unboxer wrap_arg
           ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids)
           ; return (unbox_fn expr) }

661
662
663
664
665
666
667
668
669
670
671
672
673
674
{- Note [Activation for data constructor wrappers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The Activation on a data constructor wrapper allows it to inline in
Phase 2 and later (1, 0).  But not in the InitialPhase.  That gives
rewrite rules a chance to fire (in the InitialPhase) if they mention
a data constructor on the left
   RULE "foo"  f (K a b) = ...
Since the LHS of rules are simplified with InitialPhase, we won't
inline the wrapper on the LHS either.

People have asked for this before, but now that even the InitialPhase
does some inlining, it has become important.


675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
Note [Bangs on imported data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

We pass Maybe [HsImplBang] to mkDataConRep to make use of HsImplBangs
from imported modules.

- Nothing <=> use HsSrcBangs
- Just bangs <=> use HsImplBangs

For imported types we can't work it all out from the HsSrcBangs,
because we want to be very sure to follow what the original module
(where the data type was declared) decided, and that depends on what
flags were enabled when it was compiled. So we record the decisions in
the interface file.

The HsImplBangs passed are in 1-1 correspondence with the
dataConOrigArgTys of the DataCon.

693
694
695
696
697
698
699
700
701
702
703
704
Note [Data con wrappers and unlifted types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   data T = MkT !Int#

We certainly do not want to make a wrapper
   $WMkT x = case x of y { DEFAULT -> MkT y }

For a start, it's still to generate a no-op.  But worse, since wrappers
are currently injected at TidyCore, we don't even optimise it away!
So the stupid case expression stays there.  This actually happened for
the Integer data type (see Trac #1600 comment:66)!
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738

Note [Data con wrappers and GADT syntax]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider these two very similar data types:

  data T1 a b = MkT1 b

  data T2 a b where
    MkT2 :: forall b a. b -> T2 a b

Despite their similar appearance, T2 will have a data con wrapper but T1 will
not. What sets them apart? The types of their constructors, which are:

  MkT1 :: forall a b. b -> T1 a b
  MkT2 :: forall b a. b -> T2 a b

MkT2's use of GADT syntax allows it to permute the order in which `a` and `b`
would normally appear. See Note [DataCon user type variable binders] in DataCon
for further discussion on this topic.

The worker data cons for T1 and T2, however, both have types such that `a` is
expected to come before `b` as arguments. Because MkT2 permutes this order, it
needs a data con wrapper to swizzle around the type variables to be in the
order the worker expects.

A somewhat surprising consequence of this is that *newtypes* can have data con
wrappers! After all, a newtype can also be written with GADT syntax:

  newtype T3 a b where
    MkT3 :: forall b a. b -> T3 a b

Again, this needs a wrapper data con to reorder the type variables. It does
mean that this newtype constructor requires another level of indirection when
being called, but the inliner should make swift work of that.
739
740
-}

741
742
-------------------------
newLocal :: Type -> UniqSM Var
743
newLocal ty = do { uniq <- getUniqueM
744
                 ; return (mkSysLocalOrCoVar (fsLit "dt") uniq ty) }
745

746
747
-- | Unpack/Strictness decisions from source module
dataConSrcToImplBang
748
   :: DynFlags
749
   -> FamInstEnvs
Simon Peyton Jones's avatar
Simon Peyton Jones committed
750
   -> Type
751
752
   -> HsSrcBang
   -> HsImplBang
753

754
dataConSrcToImplBang dflags fam_envs arg_ty
755
                     (HsSrcBang ann unpk NoSrcStrict)
756
  | xopt LangExt.StrictData dflags -- StrictData => strict field
757
758
759
760
  = dataConSrcToImplBang dflags fam_envs arg_ty
                  (HsSrcBang ann unpk SrcStrict)
  | otherwise -- no StrictData => lazy field
  = HsLazy
761

762
763
dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy)
  = HsLazy
764

765
dataConSrcToImplBang dflags fam_envs arg_ty
766
767
768
769
770
                     (HsSrcBang _ unpk_prag SrcStrict)
  | isUnliftedType arg_ty
  = HsLazy  -- For !Int#, say, use HsLazy
            -- See Note [Data con wrappers and unlifted types]

771
  | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
772
          -- Don't unpack if we aren't optimising; rather arbitrarily,
773
          -- we use -fomit-iface-pragmas as the indication
774
  , let mb_co   = topNormaliseType_maybe fam_envs arg_ty
775
                     -- Unwrap type families and newtypes
776
        arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }
777
  , isUnpackableType dflags fam_envs arg_ty'
778
  , (rep_tys, _) <- dataConArgUnpack arg_ty'
779
  , case unpk_prag of
780
781
782
      NoSrcUnpack ->
        gopt Opt_UnboxStrictFields dflags
            || (gopt Opt_UnboxSmallStrictFields dflags
783
                && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields]
784
      srcUnpack -> isSrcUnpacked srcUnpack
785
  = case mb_co of
786
787
      Nothing     -> HsUnpack Nothing
      Just (co,_) -> HsUnpack (Just co)
788

789
  | otherwise -- Record the strict-but-no-unpack decision
790
  = HsStrict
791

792

Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
793
-- | Wrappers/Workers and representation following Unpack/Strictness
794
795
796
797
798
799
800
801
802
-- decisions
dataConArgRep
  :: Type
  -> HsImplBang
  -> ([(Type,StrictnessMark)] -- Rep types
     ,(Unboxer,Boxer))

dataConArgRep arg_ty HsLazy
  = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
803

804
805
806
807
dataConArgRep arg_ty HsStrict
  = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))

dataConArgRep arg_ty (HsUnpack Nothing)
808
  | (rep_tys, wrappers) <- dataConArgUnpack arg_ty
809
  = (rep_tys, wrappers)
810

811
dataConArgRep _ (HsUnpack (Just co))
812
813
  | let co_rep_ty = pSnd (coercionKind co)
  , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty
814
  = (rep_tys, wrapCo co co_rep_ty wrappers)
815
816
817


-------------------------
818
819
820
821
822
823
824
825
wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer)
wrapCo co rep_ty (unbox_rep, box_rep)  -- co :: arg_ty ~ rep_ty
  = (unboxer, boxer)
  where
    unboxer arg_id = do { rep_id <- newLocal rep_ty
                        ; (rep_ids, rep_fn) <- unbox_rep rep_id
                        ; let co_bind = NonRec rep_id (Var arg_id `Cast` co)
                        ; return (rep_ids, Let co_bind . rep_fn) }
826
827
    boxer = Boxer $ \ subst ->
            do { (rep_ids, rep_expr)
828
829
830
831
                    <- case box_rep of
                         UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty)
                                       ; return ([rep_id], Var rep_id) }
                         Boxer boxer -> boxer subst
832
               ; let sco = substCoUnchecked subst co
833
834
835
               ; return (rep_ids, rep_expr `Cast` mkSymCo sco) }

------------------------
836
837
838
839
840
841
842
843
844
845
846
847
seqUnboxer :: Unboxer
seqUnboxer v = return ([v], \e -> Case (Var v) v (exprType e) [(DEFAULT, [], e)])

unitUnboxer :: Unboxer
unitUnboxer v = return ([v], \e -> e)

unitBoxer :: Boxer
unitBoxer = UnitBox

-------------------------
dataConArgUnpack
   :: Type
848
849
   ->  ( [(Type, StrictnessMark)]   -- Rep types
       , (Unboxer, Boxer) )
850
851

dataConArgUnpack arg_ty
852
  | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty
853
854
  , Just con <- tyConSingleAlgDataCon_maybe tc
      -- NB: check for an *algebraic* data type
855
      -- A recursive newtype might mean that
856
      -- 'arg_ty' is a newtype
857
858
859
860
861
862
863
864
865
866
  , let rep_tys = dataConInstArgTys con tc_args
  = ASSERT( isVanillaDataCon con )
    ( rep_tys `zip` dataConRepStrictness con
    ,( \ arg_id ->
       do { rep_ids <- mapM newLocal rep_tys
          ; let unbox_fn body
                  = Case (Var arg_id) arg_id (exprType body)
                         [(DataAlt con, rep_ids, body)]
          ; return (rep_ids, unbox_fn) }
     , Boxer $ \ subst ->
867
       do { rep_ids <- mapM (newLocal . TcType.substTyUnchecked subst) rep_tys
868
          ; return (rep_ids, Var (dataConWorkId con)
869
                             `mkTyApps` (substTysUnchecked subst tc_args)
870
871
872
873
874
                             `mkVarApps` rep_ids ) } ) )
  | otherwise
  = pprPanic "dataConArgUnpack" (ppr arg_ty)
    -- An interface file specified Unpacked, but we couldn't unpack it

875
isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool
876
-- True if we can unpack the UNPACK the argument type
877
878
879
880
-- See Note [Recursive unboxing]
-- We look "deeply" inside rather than relying on the DataCons
-- we encounter on the way, because otherwise we might well
-- end up relying on ourselves!
881
isUnpackableType dflags fam_envs ty
882
  | Just (tc, _) <- splitTyConApp_maybe ty
883
  , Just con <- tyConSingleAlgDataCon_maybe tc
884
885
886
887
  , isVanillaDataCon con
  = ok_con_args (unitNameSet (getName tc)) con
  | otherwise
  = False
888
  where
889
    ok_arg tcs (ty, bang) = not (attempt_unpack bang) || ok_ty tcs norm_ty
890
        where
891
          norm_ty = topNormaliseType fam_envs ty
892
893
894
895
    ok_ty tcs ty
      | Just (tc, _) <- splitTyConApp_maybe ty
      , let tc_name = getName tc
      =  not (tc_name `elemNameSet` tcs)
896
      && case tyConSingleAlgDataCon_maybe tc of
897
            Just con | isVanillaDataCon con
898
                    -> ok_con_args (tcs `extendNameSet` getName tc) con
899
            _ -> True
900
      | otherwise
901
902
903
      = True

    ok_con_args tcs con
Simon Peyton Jones's avatar
Simon Peyton Jones committed
904
905
906
       = all (ok_arg tcs) (dataConOrigArgTys con `zip` dataConSrcBangs con)
         -- NB: dataConSrcBangs gives the *user* request;
         -- We'd get a black hole if we used dataConImplBangs
907

908
    attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict)
909
      = xopt LangExt.StrictData dflags
910
911
912
913
    attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict)
      = True
    attempt_unpack (HsSrcBang _  NoSrcUnpack SrcStrict)
      = True  -- Be conservative
914
    attempt_unpack (HsSrcBang _  NoSrcUnpack NoSrcStrict)
915
      = xopt LangExt.StrictData dflags -- Be conservative
916
    attempt_unpack _ = False
917

Austin Seipp's avatar
Austin Seipp committed
918
{-
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
Note [Unpack one-wide fields]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The flag UnboxSmallStrictFields ensures that any field that can
(safely) be unboxed to a word-sized unboxed field, should be so unboxed.
For example:

    data A = A Int#
    newtype B = B A
    data C = C !B
    data D = D !C
    data E = E !()
    data F = F !D
    data G = G !F !F

All of these should have an Int# as their representation, except
934
G which should have two Int#s.
935

936
However
937
938
939
940
941
942
943
944

    data T = T !(S Int)
    data S = S !a

Here we can represent T with an Int#.

Note [Recursive unboxing]
~~~~~~~~~~~~~~~~~~~~~~~~~
945
Consider
946
947
948
  data R = MkR {-# UNPACK #-} !S Int
  data S = MkS {-# UNPACK #-} !Int
The representation arguments of MkR are the *representation* arguments
949
950
951
of S (plus Int); the rep args of MkS are Int#.  This is all fine.

But be careful not to try to unbox this!
952
        data T = MkT {-# UNPACK #-} !T Int
953
954
955
Because then we'd get an infinite number of arguments.

Here is a more complicated case:
956
957
        data S = MkS {-# UNPACK #-} !T Int
        data T = MkT {-# UNPACK #-} !S Int
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
958
Each of S and T must decide independently whether to unpack
959
960
961
and they had better not both say yes. So they must both say no.

Also behave conservatively when there is no UNPACK pragma
962
        data T = MkS !T Int
963
964
with -funbox-strict-fields or -funbox-small-strict-fields
we need to behave as if there was an UNPACK pragma there.
965
966

But it's the *argument* type that matters. This is fine:
967
        data S = MkS S !Int
968
969
because Int is non-recursive.

Austin Seipp's avatar
Austin Seipp committed
970
971
************************************************************************
*                                                                      *
Ian Lynagh's avatar
Ian Lynagh committed
972
        Wrapping and unwrapping newtypes and type families
Austin Seipp's avatar
Austin Seipp committed
973
974
975
*                                                                      *
************************************************************************
-}
976

977
978
wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
-- The wrapper for the data constructor for a newtype looks like this:
Ian Lynagh's avatar
Ian Lynagh committed
979
980
981
--      newtype T a = MkT (a,Int)
--      MkT :: forall a. (a,Int) -> T a
--      MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a)
Gabor Greif's avatar
Gabor Greif committed
982
-- where CoT is the coercion TyCon associated with the newtype
983
984
985
--
-- The call (wrapNewTypeBody T [a] e) returns the
-- body of the wrapper, namely
Ian Lynagh's avatar
Ian Lynagh committed
986
--      e `cast` (CoT [a])
987
--
988
-- If a coercion constructor is provided in the newtype, then we use
989
-- it, otherwise the wrap/unwrap are both no-ops
990
--
991
-- If the we are dealing with a newtype *instance*, we have a second coercion
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
992
993
994
-- identifying the family instance with the constructor of the newtype
-- instance.  This coercion is applied in any case (ie, composed with the
-- coercion constructor of the newtype or applied by itself).
995

996
wrapNewTypeBody tycon args result_expr
997
998
  = ASSERT( isNewTyCon tycon )
    wrapFamInstBody tycon args $
999
    mkCast result_expr (mkSymCo co)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1000
  where
1001
    co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []
1002

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1003
1004
1005
1006
-- When unwrapping, we do *not* apply any family coercion, because this will
-- be done via a CoPat by the type checker.  We have to do it this way as
-- computing the right type arguments for the coercion requires more than just
-- a spliting operation (cf, TcPat.tcConPat).
1007

1008
1009
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon args result_expr
1010
  = ASSERT( isNewTyCon tycon )
1011
    mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args [])
1012

1013
1014
1015
1016
1017
1018
1019
1020
-- If the type constructor is a representation type of a data instance, wrap
-- the expression into a cast adjusting the expression type, which is an
-- instance of the representation type, to the corresponding instance of the
-- family instance type.
-- See Note [Wrappers for data instance tycons]
wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapFamInstBody tycon args body
  | Just co_con <- tyConFamilyCoercion_maybe tycon
1021
  = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args []))
1022
1023
  | otherwise
  = body
1024

1025
1026
-- Same as `wrapFamInstBody`, but for type family instances, which are
-- represented by a `CoAxiom`, and not a `TyCon`
1027
1028
1029
1030
wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> [Coercion]
                    -> CoreExpr -> CoreExpr
wrapTypeFamInstBody axiom