MkId.hs 59 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,
24
        DataConBoxer(..), mkDataConRep, mkDataConWorkId,
25

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

34 35
        -- Re-export error Ids
        module PrelRules
36 37 38 39
    ) where

#include "HsVersions.h"

40 41
import GhcPrelude

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

import Data.Maybe       ( maybeToList )
78

Austin Seipp's avatar
Austin Seipp committed
79 80 81
{-
************************************************************************
*                                                                      *
82
\subsection{Wired in Ids}
Austin Seipp's avatar
Austin Seipp committed
83 84
*                                                                      *
************************************************************************
85

86 87
Note [Wired-in Ids]
~~~~~~~~~~~~~~~~~~~
88 89 90 91
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.

92 93
There are several reasons why an Id might appear in the wiredInIds:

94 95 96 97 98 99
* 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
100
  because the desugarer generates code that mentions them directly
101 102 103 104 105 106 107 108 109 110

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
111

112
  * Are exported from GHC.Prim
113

114 115
  * Can't be defined in Haskell, and hence no Haskell binding site,
    but have perfectly reasonable unfoldings in Core
116

117 118
  * Either have a CompulsoryUnfolding (hence always inlined), or
        of an EvaldUnfolding and void representation (e.g. void#)
119

120 121
  * Are (or should be) defined in primops.txt.pp as 'pseudoop'
    Reason: that's how we generate documentation for them
122

123 124 125
Note [magicIds]
~~~~~~~~~~~~~~~
The magicIds
126

127 128 129 130 131 132 133 134 135
  * 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
136
-}
137

138
wiredInIds :: [Id]
139
wiredInIds
140
  =  magicIds
141
  ++ ghcPrimIds
142 143 144
  ++ errorIds           -- Defined in MkCore

magicIds :: [Id]    -- See Note [magicIds]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
145
magicIds = [lazyId, oneShotId, noinlineId]
146

147
ghcPrimIds :: [Id]  -- See Note [ghcPrimIds (aka pseudoops)]
148
ghcPrimIds
149 150 151 152 153 154 155 156
  = [ realWorldPrimId
    , voidPrimId
    , unsafeCoerceId
    , nullAddrId
    , seqId
    , magicDictId
    , coerceId
    , proxyHashId
157 158
    ]

Austin Seipp's avatar
Austin Seipp committed
159 160 161
{-
************************************************************************
*                                                                      *
162
\subsection{Data constructors}
Austin Seipp's avatar
Austin Seipp committed
163 164
*                                                                      *
************************************************************************
165

166 167 168 169
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.

170 171
We're going to build a constructor that looks like:

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

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

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.

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

194 195 196 197 198 199 200 201 202
  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.

203 204
Note [Wrappers for data instance tycons]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
205 206
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
207 208 209 210 211
the wrapper.  For example, consider the declarations

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

212 213 214 215 216 217 218
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

219
  Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v}
220 221

The wrapper and worker of MapPair get the types
222

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

Ian Lynagh's avatar
Ian Lynagh committed
227
        -- Worker
228
  MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v
229

230
This coercion is conditionally applied by wrapFamInstBody.
231

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

234
   data instance T [a] where
Ian Lynagh's avatar
Ian Lynagh committed
235
        T1 :: forall b. b -> T [Maybe b]
236

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
237
Hence we translate to
238

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

Ian Lynagh's avatar
Ian Lynagh committed
244
        -- Worker
245
  T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c
246

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

250 251 252 253 254 255 256 257 258 259 260
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.

261

Austin Seipp's avatar
Austin Seipp committed
262 263
************************************************************************
*                                                                      *
264
\subsection{Dictionary selectors}
Austin Seipp's avatar
Austin Seipp committed
265 266
*                                                                      *
************************************************************************
267

268
Selecting a field for a dictionary.  If there is just one field, then
269
there's nothing to do.
270

271
Dictionary selectors may get nested forall-types.  Thus:
272

273 274
        class Foo a where
          op :: forall b. Ord b => a -> b -> b
275

276
Then the top-level type for op is
277

278 279
        op :: forall a. Foo a =>
              forall b. Ord b =>
280
              a -> b -> b
281

Austin Seipp's avatar
Austin Seipp committed
282
-}
283

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

299
    sel_ty = mkForAllTys tyvars $
300
             mkFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $
301 302
             getNth arg_tys val_index

303
    base_info = noCafIdInfo
304 305 306
                `setArityInfo`          1
                `setStrictnessInfo`     strict_sig
                `setLevityInfoWithType` sel_ty
307 308 309

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

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

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

329 330 331 332
        -- 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
333

334
    strict_sig = mkClosedStrictSig [arg_dmd] topRes
335
    arg_dmd | new_tycon = evalDmd
336
            | otherwise = mkManyUsedDmd $
337 338 339 340 341 342 343 344 345
                          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
346 347 348 349 350
    tycon          = classTyCon clas
    new_tycon      = isNewTyCon tycon
    [data_con]     = tyConDataCons tycon
    tyvars         = dataConUnivTyVars data_con
    arg_tys        = dataConRepArgTys data_con  -- Includes the dictionary superclasses
351

352
    the_arg_id     = getNth arg_ids val_index
353 354 355
    pred           = mkClassPred clas (mkTyVarTys tyvars)
    dict_id        = mkTemplateLocal 1 pred
    arg_ids        = mkTemplateLocalsNum 2 arg_tys
356

357
    rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars) (Var dict_id)
358
             | otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
359
                                [(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)]
360 361
                                -- varToCoreExpr needed for equality superclass selectors
                                --   sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }
362

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

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

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

391
  where
392 393 394 395 396 397
    tycon = dataConTyCon data_con

        ----------- Workers for data types --------------
    alg_wkr_ty = dataConRepType data_con
    wkr_arity = dataConRepArity data_con
    wkr_info  = noCafIdInfo
398 399 400 401 402 403 404
                `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
405

406
    wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con)
407
        --      Note [Data-con worker strictness]
408
        -- Notice that we do *not* say the worker Id is strict
409 410
        -- even if the data constructor is declared strict
        --      e.g.    data T = MkT !(Int,Int)
411 412 413 414
        -- 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
415
        -- the simplifier thinks that y is "sure to be evaluated" (because
416 417
        -- the worker MkT is strict) and drops the case.  No, the workerId
        -- MkT is not strict.
418
        --
419 420
        -- However, the worker does have StrictnessMarks.  When the simplifier
        -- sees a pattern
421 422 423 424 425 426 427 428 429 430 431
        --      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
432 433 434
                  `setInlinePragInfo`     alwaysInlinePragma
                  `setUnfoldingInfo`      newtype_unf
                  `setLevityInfoWithType` nt_wrap_ty
435 436 437
    id_arg1      = mkTemplateLocal 1 (head nt_arg_tys)
    newtype_unf  = ASSERT2( isVanillaDataCon data_con &&
                            isSingleton nt_arg_tys, ppr data_con  )
438 439 440
                              -- Note [Newtype datacons]
                   mkCompulsoryUnfolding $
                   mkLams nt_tvs $ Lam id_arg1 $
441
                   wrapNewTypeBody tycon res_ty_args (Var id_arg1)
442

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

    mAX_CPR_SIZE :: Arity
    mAX_CPR_SIZE = 10
    -- We do not treat very big tuples as CPR-ish:
462 463 464
    --      a) for a start we get into trouble because there aren't
    --         "enough" unboxed tuple types (a tiresome restriction,
    --         but hard to fix),
465 466 467 468
    --      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.
469

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

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

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

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

491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516
{-
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.
-}

517 518 519 520 521 522 523 524
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
525 526
  | not wrapper_reqd
  = return NoDataConRep
527

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

       ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info
             wrap_info = noCafIdInfo
535 536 537
                         `setArityInfo`         wrap_arity
                             -- It's important to specify the arity, so that partial
                             -- applications are treated as values
538
                         `setInlinePragInfo`    wrap_prag
539 540 541 542 543
                         `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
544
                         `setNeverLevPoly`      wrap_ty
545 546

             wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
547

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

553
             mk_dmd str | isBanged str = evalDmd
554
                        | otherwise           = topDmd
555

556 557 558 559
             wrap_prag = alwaysInlinePragma `setInlinePragmaActivation`
                         ActiveAfter NoSourceText 2
                         -- See Note [Activation for data constructor wrappers]

560 561 562 563 564 565 566 567
             -- 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.
568
             wrap_unf = mkInlineUnfolding wrap_rhs
569 570 571
             wrap_rhs = mkLams wrap_tvs $
                        mkLams wrap_args $
                        wrapFamInstBody tycon res_ty_args $
572 573 574 575 576 577
                        wrap_body

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

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

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

    wrap_arg_tys = theta ++ orig_arg_tys
    wrap_arity   = length wrap_arg_tys
595 596 597
             -- 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
598

599 600 601 602 603 604 605 606 607
    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))

608
    (unboxers, boxers) = unzip wrappers
609 610
    (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)

611 612 613 614 615 616 617 618 619 620 621 622 623 624
    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].
625 626

    initial_wrap_app = Var (dataConWorkId data_con)
627 628 629
                       `mkTyApps`  res_ty_args
                       `mkVarApps` ex_tvs
                       `mkCoApps`  map (mkReflCo Nominal . eqSpecType) eq_spec
630 631

    mk_boxer :: [Boxer] -> DataConBoxer
632
    mk_boxer boxers = DCB (\ ty_args src_vars ->
633
                      do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars
634
                               subst1 = zipTvSubst univ_tvs ty_args
635 636
                               subst2 = extendTvSubstList subst1 ex_tvs
                                                          (mkTyVarTys ex_vars)
637
                         ; (rep_ids, binds) <- go subst2 boxers term_vars
638 639 640 641 642 643 644 645 646 647 648 649 650
                         ; 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
651
    mk_rep_app [] con_app
652
      = return con_app
653
    mk_rep_app ((wrap_arg, unboxer) : prs) con_app
654 655 656 657
      = do { (rep_ids, unbox_fn) <- unboxer wrap_arg
           ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids)
           ; return (unbox_fn expr) }

658 659 660 661 662 663 664 665 666 667 668 669 670 671
{- 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.


672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689
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.

690 691 692 693 694 695 696 697 698 699 700 701
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)!
702 703 704 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

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.
736 737
-}

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

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

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

759 760
dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy)
  = HsLazy
761

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

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

786
  | otherwise -- Record the strict-but-no-unpack decision
787
  = HsStrict
788

789

790
-- | Wrappers/Workers and representation following Unpack/Strictness
791 792 793 794 795 796 797 798 799
-- decisions
dataConArgRep
  :: Type
  -> HsImplBang
  -> ([(Type,StrictnessMark)] -- Rep types
     ,(Unboxer,Boxer))

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

801 802 803 804
dataConArgRep arg_ty HsStrict
  = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))

dataConArgRep arg_ty (HsUnpack Nothing)
805
  | (rep_tys, wrappers) <- dataConArgUnpack arg_ty
806
  = (rep_tys, wrappers)
807

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


-------------------------
815 816 817 818 819 820 821 822
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) }
823 824
    boxer = Boxer $ \ subst ->
            do { (rep_ids, rep_expr)
825 826 827 828
                    <- case box_rep of
                         UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty)
                                       ; return ([rep_id], Var rep_id) }
                         Boxer boxer -> boxer subst
829
               ; let sco = substCoUnchecked subst co
830 831 832
               ; return (rep_ids, rep_expr `Cast` mkSymCo sco) }

------------------------
833 834 835 836 837 838 839 840 841 842 843 844
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
845 846
   ->  ( [(Type, StrictnessMark)]   -- Rep types
       , (Unboxer, Boxer) )
847 848

dataConArgUnpack arg_ty
849
  | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty
850 851
  , Just con <- tyConSingleAlgDataCon_maybe tc
      -- NB: check for an *algebraic* data type
852
      -- A recursive newtype might mean that
853
      -- 'arg_ty' is a newtype
854
  , let rep_tys = dataConInstArgTys con tc_args
855
  = ASSERT( null (dataConExTyVars con) )  -- Note [Unpacking GADTs and existentials]
856 857 858 859 860 861 862 863
    ( 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 ->
864
       do { rep_ids <- mapM (newLocal . TcType.substTyUnchecked subst) rep_tys
865
          ; return (rep_ids, Var (dataConWorkId con)
866
                             `mkTyApps` (substTysUnchecked subst tc_args)
867 868 869 870 871
                             `mkVarApps` rep_ids ) } ) )
  | otherwise
  = pprPanic "dataConArgUnpack" (ppr arg_ty)
    -- An interface file specified Unpacked, but we couldn't unpack it

872
isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool
873
-- True if we can unpack the UNPACK the argument type
874 875 876 877
-- 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!
878
isUnpackableType dflags fam_envs ty
879
  | Just data_con <- unpackable_type ty
880
  = ok_con_args emptyNameSet data_con
881 882
  | otherwise
  = False
883
  where
884
    ok_con_args dcs con
885 886 887 888 889 890 891 892 893 894 895 896 897 898 899
       | dc_name `elemNameSet` dcs
       = False
       | otherwise
       = all (ok_arg dcs')
             (dataConOrigArgTys con `zip` dataConSrcBangs con)
          -- NB: dataConSrcBangs gives the *user* request;
          -- We'd get a black hole if we used dataConImplBangs
       where
         dc_name = getName con
         dcs' = dcs `extendNameSet` dc_name

    ok_arg dcs (ty, bang)
      = not (attempt_unpack bang) || ok_ty dcs norm_ty
      where
        norm_ty = topNormaliseType fam_envs ty
900

901 902
    ok_ty dcs ty
      | Just data_con <- unpackable_type ty
903
      = ok_con_args dcs data_con
904
      | otherwise
905
      = True        -- NB True here, in contrast to False at top level
906

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

917 918 919 920 921 922 923 924 925 926
    unpackable_type :: Type -> Maybe DataCon
    -- Works just on a single level
    unpackable_type ty
      | Just (tc, _) <- splitTyConApp_maybe ty
      , Just data_con <- tyConSingleAlgDataCon_maybe tc
      , null (dataConExTyVars data_con)  -- See Note [Unpacking GADTs and existentials]
      = Just data_con
      | otherwise
      = Nothing

Austin Seipp's avatar
Austin Seipp committed
927
{-
928 929 930 931 932 933 934 935 936 937 938 939 940
Note [Unpacking GADTs and existentials]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There is nothing stopping us unpacking a data type with equality
components, like
  data Equal a b where
    Equal :: Equal a a

And it'd be fine to unpack a product type with existential components
too, but that would require a bit more plumbing, so currently we don't.

So for now we require: null (dataConExTyVars data_con)
See Trac #14978

941 942 943 944 945 946 947 948 949 950 951 952 953 954 955
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
956
G which should have two Int#s.
957

958
However
959 960 961 962 963 964 965 966

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

Here we can represent T with an Int#.

Note [Recursive unboxing]
~~~~~~~~~~~~~~~~~~~~~~~~~
967
Consider
968 969 970
  data R = MkR {-# UNPACK #-} !S Int
  data S = MkS {-# UNPACK #-} !Int
The representation arguments of MkR are the *representation* arguments
971 972 973
of S (plus Int); the rep args of MkS are Int#.  This is all fine.

But be careful not to try to unbox this!
974
        data T = MkT {-# UNPACK #-} !T Int
975 976 977
Because then we'd get an infinite number of arguments.

Here is a more complicated case:
978 979
        data S = MkS {-# UNPACK #-} !T Int
        data T = MkT {-# UNPACK #-} !S Int
980
Each of S and T must decide independently whether to unpack
981 982 983
and they had better not both say yes. So they must both say no.

Also behave conservatively when there is no UNPACK pragma
984
        data T = MkS !T Int
985 986
with -funbox-strict-fields or -funbox-small-strict-fields
we need to behave as if there was an UNPACK pragma there.
987 988

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

Austin Seipp's avatar
Austin Seipp committed
992 993
************************************************************************
*                                                                      *
Ian Lynagh's avatar
Ian Lynagh committed
994
        Wrapping and unwrapping newtypes and type families
Austin Seipp's avatar
Austin Seipp committed
995 996 997
*                                                                      *
************************************************************************
-}
998

999 1000
wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
-- The wrapper for the data constructor for a newtype looks like this:
Ian Lynagh's avatar
Ian Lynagh committed
1001 1002 1003
--      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
1004
-- where CoT is the coercion TyCon associated with the newtype
1005 1006 1007
--
-- The call (wrapNewTypeBody T [a] e) returns the
-- body of the wrapper, namely
Ian Lynagh's avatar
Ian Lynagh committed
1008
--      e `cast` (CoT [a])
1009
--
1010
-- If a coercion constructor is provided in the newtype, then we use
1011
-- it, otherwise the wrap/unwrap are both no-ops
1012
--
1013
-- 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
1014 1015 1016
-- 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).
1017

1018
wrapNewTypeBody tycon args result_expr
1019 1020
  = ASSERT( isNewTyCon tycon )
    wrapFamInstBody tycon args $
1021
    mkCast result_expr (mkSymCo co)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1022
  where
1023
    co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []
1024

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1025 1026 1027 1028
-- 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).
1029

1030 1031
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon args result_expr
1032
  = ASSERT( isNewTyCon tycon )
1033
    mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args [])
1034

1035 1036 1037 1038 1039 1040 1041 1042
-- 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
1043
  = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args []))
1044 1045
  | otherwise
  = body
1046

Austin Seipp's avatar
Austin Seipp committed
1047 1048 1049
{-
************************************************************************
*                                                                      *
1050
\subsection{Primitive operations}
Austin Seipp's avatar
Austin Seipp committed
1051 1052 1053
*                                                                      *
************************************************************************
-}
1054

1055
mkPrimOpId :: PrimOp -> Id
1056
mkPrimOpId prim_op
1057
  = id
1058
  where
1059
    (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
1060
    ty   = mkSpecForAllTys tyvars (mkFunTys arg_tys res_ty)
1061
    name = mkWiredInName gHC_PRIM (primOpOcc prim_op)
Ian Lynagh's avatar
Ian Lynagh committed
1062 1063
                         (mkPrimOpIdUnique (primOpTag prim_op))
                         (AnId id) UserSyntax
1064
    id   = mkGlobalId (PrimOpId prim_op) name ty info
1065

1066
    info = noCafIdInfo
1067 1068 1069 1070 1071
           `setRuleInfo`           mkRuleInfo (maybeToList $ primOpRules name prim_op)
           `setArityInfo`          arity
           `setStrictnessInfo`     strict_sig
           `setInlinePragInfo`     neverInlinePragma
           `setLevityInfoWithType` res_ty
1072
               -- We give PrimOps a NOINLINE pragma so that we don't