MkId.hs 60.9 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 91 92 93 94 95 96 97 98 99 100 101 102 103 104
Note [Wired-in Ids]
~~~~~~~~~~~~~~~~~~~
There are several reasons why an Id might appear in the wiredInIds:

(1) The ghcPrimIds are wired in because they can't be defined in
    Haskell at all, although the can be defined in Core.  They have
    compulsory unfoldings, so they are always inlined and they  have
    no definition site.  Their home module is GHC.Prim, so they
    also have a description in primops.txt.pp, where they are called
    'pseudoops'.

(2) The 'error' function, eRROR_ID, is wired in because we don't yet have
    a way to express in an interface file that the result type variable
    is 'open'; that is can be unified with an unboxed type

    [The interface file format now carry such information, but there's
105 106
    no way yet of expressing at the definition site for these
    error-reporting functions that they have an 'open'
107 108 109
    result type. -- sof 1/99]

(3) Other error functions (rUNTIME_ERROR_ID) are wired in (a) because
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
110
    the desugarer generates code that mentions them directly, and
111 112 113 114 115
    (b) for the same reason as eRROR_ID

(4) lazyId is wired in because the wired-in version overrides the
    strictness of the version defined in GHC.Base

116 117 118
(5) noinlineId is wired in because when we serialize to interfaces
    we may insert noinline statements.

119
In cases (2-4), the function has a definition in a library module, and
120
can be called; but the wired-in version means that the details are
121 122
never read from that module's interface file; instead, the full definition
is right here.
Austin Seipp's avatar
Austin Seipp committed
123
-}
124

125
wiredInIds :: [Id]
126
wiredInIds
127
  =  [lazyId, dollarId, oneShotId, runRWId, noinlineId]
128
  ++ errorIds           -- Defined in MkCore
129
  ++ ghcPrimIds
130 131

-- These Ids are exported from GHC.Prim
132
ghcPrimIds :: [Id]
133
ghcPrimIds
Ian Lynagh's avatar
Ian Lynagh committed
134 135
  = [   -- These can't be defined in Haskell, but they have
        -- perfectly reasonable unfoldings in Core
136
    realWorldPrimId,
137
    voidPrimId,
138 139
    unsafeCoerceId,
    nullAddrId,
140
    seqId,
141
    magicDictId,
142 143
    coerceId,
    proxyHashId
144 145
    ]

Austin Seipp's avatar
Austin Seipp committed
146 147 148
{-
************************************************************************
*                                                                      *
149
\subsection{Data constructors}
Austin Seipp's avatar
Austin Seipp committed
150 151
*                                                                      *
************************************************************************
152

153 154 155 156
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.

157 158
We're going to build a constructor that looks like:

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

161
        T1 = /\ a b ->
Ian Lynagh's avatar
Ian Lynagh committed
162 163 164 165
             \d1::Data a, d2::C b ->
             \p q r -> case p of { p ->
                       case q of { q ->
                       Con T1 [a,b] [p,q,r]}}
166 167 168 169 170 171 172 173 174 175

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.

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

181 182 183 184 185 186 187 188 189
  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.

190 191
Note [Wrappers for data instance tycons]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
192 193
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
194 195 196 197 198
the wrapper.  For example, consider the declarations

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

199 200 201 202 203 204 205
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

206
  Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v}
207 208

The wrapper and worker of MapPair get the types
209

Ian Lynagh's avatar
Ian Lynagh committed
210
        -- Wrapper
211
  $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v
212
  $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v)
213

Ian Lynagh's avatar
Ian Lynagh committed
214
        -- Worker
215
  MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v
216

217
This coercion is conditionally applied by wrapFamInstBody.
218

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

221
   data instance T [a] where
Ian Lynagh's avatar
Ian Lynagh committed
222
        T1 :: forall b. b -> T [Maybe b]
223

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
224
Hence we translate to
225

Ian Lynagh's avatar
Ian Lynagh committed
226
        -- Wrapper
227
  $WT1 :: forall b. b -> T [Maybe b]
228
  $WT1 b v = T1 (Maybe b) b (Maybe b) v
Ian Lynagh's avatar
Ian Lynagh committed
229
                        `cast` sym (Co7T (Maybe b))
230

Ian Lynagh's avatar
Ian Lynagh committed
231
        -- Worker
232
  T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c
233

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

237 238 239 240 241 242 243 244 245 246 247
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.

248

Austin Seipp's avatar
Austin Seipp committed
249 250
************************************************************************
*                                                                      *
251
\subsection{Dictionary selectors}
Austin Seipp's avatar
Austin Seipp committed
252 253
*                                                                      *
************************************************************************
254

255
Selecting a field for a dictionary.  If there is just one field, then
256
there's nothing to do.
257

258
Dictionary selectors may get nested forall-types.  Thus:
259

260 261
        class Foo a where
          op :: forall b. Ord b => a -> b -> b
262

263
Then the top-level type for op is
264

265 266
        op :: forall a. Foo a =>
              forall b. Ord b =>
267
              a -> b -> b
268

Austin Seipp's avatar
Austin Seipp committed
269
-}
270

271 272
mkDictSelId :: Name          -- Name of one of the *value* selectors
                             -- (dictionary superclass or method)
273
            -> Class -> Id
274
mkDictSelId name clas
275 276
  = mkGlobalId (ClassOpId clas) name sel_ty info
  where
277
    tycon          = classTyCon clas
278
    sel_names      = map idName (classAllSelIds clas)
279 280
    new_tycon      = isNewTyCon tycon
    [data_con]     = tyConDataCons tycon
Simon Peyton Jones's avatar
Simon Peyton Jones committed
281 282
    tyvars         = dataConUnivTyVarBinders data_con
    n_ty_args      = length tyvars
283
    arg_tys        = dataConRepArgTys data_con  -- Includes the dictionary superclasses
284 285
    val_index      = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name

Simon Peyton Jones's avatar
Simon Peyton Jones committed
286
    sel_ty = mkForAllTys tyvars $
287
             mkFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $
288 289
             getNth arg_tys val_index

290
    base_info = noCafIdInfo
Richard Eisenberg's avatar
Richard Eisenberg committed
291 292 293
                `setArityInfo`          1
                `setStrictnessInfo`     strict_sig
                `setLevityInfoWithType` sel_ty
294 295 296

    info | new_tycon
         = base_info `setInlinePragInfo` alwaysInlinePragma
297 298
                     `setUnfoldingInfo`  mkInlineUnfoldingWithArity 1
                                           (mkDictSelRhs clas val_index)
299 300
                   -- See Note [Single-method classes] in TcInstDcls
                   -- for why alwaysInlinePragma
301 302

         | otherwise
303
         = base_info `setRuleInfo` mkRuleInfo [rule]
304 305 306
                   -- Add a magic BuiltinRule, but no unfolding
                   -- so that the rule is always available to fire.
                   -- See Note [ClassOp/DFun selection] in TcInstDcls
307

308
    -- This is the built-in rule that goes
309 310 311
    --      op (dfT d1 d2) --->  opT d1 d2
    rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS`
                                     occNameFS (getOccName name)
312
                       , ru_fn    = name
313
                       , ru_nargs = n_ty_args + 1
314
                       , ru_try   = dictSelRule val_index n_ty_args }
315

316 317 318 319
        -- 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
320

321
    strict_sig = mkClosedStrictSig [arg_dmd] topRes
322
    arg_dmd | new_tycon = evalDmd
323
            | otherwise = mkManyUsedDmd $
324 325 326 327 328 329 330 331 332
                          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
333 334 335 336 337
    tycon          = classTyCon clas
    new_tycon      = isNewTyCon tycon
    [data_con]     = tyConDataCons tycon
    tyvars         = dataConUnivTyVars data_con
    arg_tys        = dataConRepArgTys data_con  -- Includes the dictionary superclasses
338

339
    the_arg_id     = getNth arg_ids val_index
340 341 342
    pred           = mkClassPred clas (mkTyVarTys tyvars)
    dict_id        = mkTemplateLocal 1 pred
    arg_ids        = mkTemplateLocalsNum 2 arg_tys
343

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

350
dictSelRule :: Int -> Arity -> RuleFun
351 352 353
-- Tries to persuade the argument to look like a constructor
-- application, using exprIsConApp_maybe, and then selects
-- from it
354
--       sel_i t1..tk (D t1..tk op1 ... opm) = opi
355
--
356
dictSelRule val_index n_ty_args _ id_unf _ args
357
  | (dict_arg : _) <- drop n_ty_args args
358
  , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
359
  = Just (getNth con_args val_index)
360 361
  | otherwise
  = Nothing
362

Austin Seipp's avatar
Austin Seipp committed
363 364 365
{-
************************************************************************
*                                                                      *
Simon Peyton Jones's avatar
Simon Peyton Jones committed
366
        Data constructors
Austin Seipp's avatar
Austin Seipp committed
367 368 369
*                                                                      *
************************************************************************
-}
370 371 372 373 374 375 376 377

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

378
  where
379 380 381 382 383 384
    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
385 386 387 388 389 390 391
                `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
392

393
    wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con)
394 395 396 397 398
        --      Note [Data-con worker strictness]
        -- Notice that we do *not* say the worker is strict
        -- even if the data constructor is declared strict
        --      e.g.    data T = MkT !(Int,Int)
        -- Why?  Because the *wrapper* is strict (and its unfolding has case
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
399
        -- expressions that do the evals) but the *worker* itself is not.
400 401 402 403 404
        -- If we pretend it is strict then when we see
        --      case x of y -> $wMkT y
        -- the simplifier thinks that y is "sure to be evaluated" (because
        --  $wMkT is strict) and drops the case.  No, $wMkT is not strict.
        --
Gabor Greif's avatar
Gabor Greif committed
405
        -- When the simplifier sees a pattern
406 407 408 409 410 411 412 413 414 415 416
        --      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
417 418 419
                  `setInlinePragInfo`     alwaysInlinePragma
                  `setUnfoldingInfo`      newtype_unf
                  `setLevityInfoWithType` nt_wrap_ty
420 421 422
    id_arg1      = mkTemplateLocal 1 (head nt_arg_tys)
    newtype_unf  = ASSERT2( isVanillaDataCon data_con &&
                            isSingleton nt_arg_tys, ppr data_con  )
423 424 425
                              -- Note [Newtype datacons]
                   mkCompulsoryUnfolding $
                   mkLams nt_tvs $ Lam id_arg1 $
426
                   wrapNewTypeBody tycon res_ty_args (Var id_arg1)
427

428 429
dataConCPR :: DataCon -> DmdResult
dataConCPR con
430
  | isDataTyCon tycon     -- Real data types only; that is,
431
                          -- not unboxed tuples or newtypes
432
  , null (dataConExTyVars con)  -- No existentials
433 434
  , wkr_arity > 0
  , wkr_arity <= mAX_CPR_SIZE
435 436
  = if is_prod then vanillaCprProdRes (dataConRepArity con)
               else cprSumRes (dataConTag con)
437
  | otherwise
438
  = topRes
439
  where
440 441
    is_prod   = isProductTyCon tycon
    tycon     = dataConTyCon con
442 443 444 445 446
    wkr_arity = dataConRepArity con

    mAX_CPR_SIZE :: Arity
    mAX_CPR_SIZE = 10
    -- We do not treat very big tuples as CPR-ish:
447 448 449
    --      a) for a start we get into trouble because there aren't
    --         "enough" unboxed tuple types (a tiresome restriction,
    --         but hard to fix),
450 451 452 453
    --      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.
454

Austin Seipp's avatar
Austin Seipp committed
455
{-
456 457
-------------------------------------------------
--         Data constructor representation
458 459
--
-- This is where we decide how to wrap/unwrap the
460 461 462
-- constructor fields
--
--------------------------------------------------
Austin Seipp's avatar
Austin Seipp committed
463
-}
464 465 466 467

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

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

471
-- | Data Constructor Boxer
472 473 474 475
newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))
                       -- Bind these src-level vars, returning the
                       -- rep-level vars to bind in the pattern

476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501
{-
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.
-}

502 503 504 505 506 507 508 509
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
510 511
  | not wrapper_reqd
  = return NoDataConRep
512

513
  | otherwise
514
  = do { wrap_args <- mapM newLocal wrap_arg_tys
515
       ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers)
516 517 518 519
                                 initial_wrap_app

       ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info
             wrap_info = noCafIdInfo
520 521 522
                         `setArityInfo`         wrap_arity
                             -- It's important to specify the arity, so that partial
                             -- applications are treated as values
523
                         `setInlinePragInfo`    wrap_prag
524 525 526 527 528
                         `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
529
                         `setNeverLevPoly`      wrap_ty
530 531

             wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
532

533
             wrap_arg_dmds = map mk_dmd arg_ibangs
534
             mk_dmd str | isBanged str = evalDmd
535
                        | otherwise           = topDmd
536

537 538 539 540
             wrap_prag = alwaysInlinePragma `setInlinePragmaActivation`
                         ActiveAfter NoSourceText 2
                         -- See Note [Activation for data constructor wrappers]

541 542 543 544 545 546 547 548
             -- 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.
549
             wrap_unf = mkInlineUnfolding wrap_rhs
550
             wrap_tvs = (univ_tvs `minusList` map eqSpecTyVar eq_spec) ++ ex_tvs
551 552 553
             wrap_rhs = mkLams wrap_tvs $
                        mkLams wrap_args $
                        wrapFamInstBody tycon res_ty_args $
554 555 556 557 558 559
                        wrap_body

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

562
  where
563 564
    (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty)
      = dataConFullSig data_con
niteria's avatar
niteria committed
565
    res_ty_args  = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs
566

567 568 569
    tycon        = dataConTyCon data_con       -- The representation TyCon (not family)
    wrap_ty      = dataConUserType data_con
    ev_tys       = eqSpecPreds eq_spec ++ theta
570
    all_arg_tys  = ev_tys ++ orig_arg_tys
571
    ev_ibangs    = map (const HsLazy) ev_tys
572
    orig_bangs   = dataConSrcBangs data_con
573 574 575

    wrap_arg_tys = theta ++ orig_arg_tys
    wrap_arity   = length wrap_arg_tys
576 577 578
             -- 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
579

580 581 582 583 584 585 586 587 588
    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))

589
    (unboxers, boxers) = unzip wrappers
590 591 592
    (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)

    wrapper_reqd = not (isNewTyCon tycon)  -- Newtypes have only a worker
593 594
                && (any isBanged (ev_ibangs ++ arg_ibangs)
                      -- Some forcing/unboxing (includes eq_spec)
595 596
                    || isFamInstTyCon tycon  -- Cast result
                    || (not $ null eq_spec)) -- GADT
597 598

    initial_wrap_app = Var (dataConWorkId data_con)
599 600 601
                       `mkTyApps`  res_ty_args
                       `mkVarApps` ex_tvs
                       `mkCoApps`  map (mkReflCo Nominal . eqSpecType) eq_spec
602 603

    mk_boxer :: [Boxer] -> DataConBoxer
604
    mk_boxer boxers = DCB (\ ty_args src_vars ->
605
                      do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars
606
                               subst1 = zipTvSubst univ_tvs ty_args
607 608
                               subst2 = extendTvSubstList subst1 ex_tvs
                                                          (mkTyVarTys ex_vars)
609
                         ; (rep_ids, binds) <- go subst2 boxers term_vars
610 611 612 613 614 615 616 617 618 619 620 621 622
                         ; 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
623
    mk_rep_app [] con_app
624
      = return con_app
625
    mk_rep_app ((wrap_arg, unboxer) : prs) con_app
626 627 628 629
      = do { (rep_ids, unbox_fn) <- unboxer wrap_arg
           ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids)
           ; return (unbox_fn expr) }

630 631 632 633 634 635 636 637 638 639 640 641 642 643
{- 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.


644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661
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.

662 663 664 665 666 667 668 669 670 671 672 673
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)!
674 675
-}

676 677
-------------------------
newLocal :: Type -> UniqSM Var
678
newLocal ty = do { uniq <- getUniqueM
679
                 ; return (mkSysLocalOrCoVar (fsLit "dt") uniq ty) }
680

681 682
-- | Unpack/Strictness decisions from source module
dataConSrcToImplBang
683
   :: DynFlags
684
   -> FamInstEnvs
Simon Peyton Jones's avatar
Simon Peyton Jones committed
685
   -> Type
686 687
   -> HsSrcBang
   -> HsImplBang
688

689
dataConSrcToImplBang dflags fam_envs arg_ty
690
                     (HsSrcBang ann unpk NoSrcStrict)
691
  | xopt LangExt.StrictData dflags -- StrictData => strict field
692 693 694 695
  = dataConSrcToImplBang dflags fam_envs arg_ty
                  (HsSrcBang ann unpk SrcStrict)
  | otherwise -- no StrictData => lazy field
  = HsLazy
696

697 698
dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy)
  = HsLazy
699

700
dataConSrcToImplBang dflags fam_envs arg_ty
701 702 703 704 705
                     (HsSrcBang _ unpk_prag SrcStrict)
  | isUnliftedType arg_ty
  = HsLazy  -- For !Int#, say, use HsLazy
            -- See Note [Data con wrappers and unlifted types]

706
  | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
707
          -- Don't unpack if we aren't optimising; rather arbitrarily,
708
          -- we use -fomit-iface-pragmas as the indication
709
  , let mb_co   = topNormaliseType_maybe fam_envs arg_ty
710
                     -- Unwrap type families and newtypes
711
        arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }
712
  , isUnpackableType dflags fam_envs arg_ty'
713
  , (rep_tys, _) <- dataConArgUnpack arg_ty'
714
  , case unpk_prag of
715 716 717
      NoSrcUnpack ->
        gopt Opt_UnboxStrictFields dflags
            || (gopt Opt_UnboxSmallStrictFields dflags
718
                && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields]
719
      srcUnpack -> isSrcUnpacked srcUnpack
720
  = case mb_co of
721 722
      Nothing     -> HsUnpack Nothing
      Just (co,_) -> HsUnpack (Just co)
723

724
  | otherwise -- Record the strict-but-no-unpack decision
725
  = HsStrict
726

727

Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
728
-- | Wrappers/Workers and representation following Unpack/Strictness
729 730 731 732 733 734 735 736 737
-- decisions
dataConArgRep
  :: Type
  -> HsImplBang
  -> ([(Type,StrictnessMark)] -- Rep types
     ,(Unboxer,Boxer))

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

739 740 741 742
dataConArgRep arg_ty HsStrict
  = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))

dataConArgRep arg_ty (HsUnpack Nothing)
743
  | (rep_tys, wrappers) <- dataConArgUnpack arg_ty
744
  = (rep_tys, wrappers)
745

746
dataConArgRep _ (HsUnpack (Just co))
747 748
  | let co_rep_ty = pSnd (coercionKind co)
  , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty
749
  = (rep_tys, wrapCo co co_rep_ty wrappers)
750 751 752


-------------------------
753 754 755 756 757 758 759 760
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) }
761 762
    boxer = Boxer $ \ subst ->
            do { (rep_ids, rep_expr)
763 764 765 766
                    <- case box_rep of
                         UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty)
                                       ; return ([rep_id], Var rep_id) }
                         Boxer boxer -> boxer subst
767
               ; let sco = substCoUnchecked subst co
768 769 770
               ; return (rep_ids, rep_expr `Cast` mkSymCo sco) }

------------------------
771 772 773 774 775 776 777 778 779 780 781 782
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
783 784
   ->  ( [(Type, StrictnessMark)]   -- Rep types
       , (Unboxer, Boxer) )
785 786

dataConArgUnpack arg_ty
787
  | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty
788 789
  , Just con <- tyConSingleAlgDataCon_maybe tc
      -- NB: check for an *algebraic* data type
790
      -- A recursive newtype might mean that
791
      -- 'arg_ty' is a newtype
792 793 794 795 796 797 798 799 800 801
  , 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 ->
802
       do { rep_ids <- mapM (newLocal . TcType.substTyUnchecked subst) rep_tys
803
          ; return (rep_ids, Var (dataConWorkId con)
804
                             `mkTyApps` (substTysUnchecked subst tc_args)
805 806 807 808 809
                             `mkVarApps` rep_ids ) } ) )
  | otherwise
  = pprPanic "dataConArgUnpack" (ppr arg_ty)
    -- An interface file specified Unpacked, but we couldn't unpack it

810
isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool
811
-- True if we can unpack the UNPACK the argument type
812 813 814 815
-- 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!
816
isUnpackableType dflags fam_envs ty
817
  | Just (tc, _) <- splitTyConApp_maybe ty
818
  , Just con <- tyConSingleAlgDataCon_maybe tc
819 820 821 822
  , isVanillaDataCon con
  = ok_con_args (unitNameSet (getName tc)) con
  | otherwise
  = False
823
  where
824
    ok_arg tcs (ty, bang) = not (attempt_unpack bang) || ok_ty tcs norm_ty
825
        where
826
          norm_ty = topNormaliseType fam_envs ty
827 828 829 830
    ok_ty tcs ty
      | Just (tc, _) <- splitTyConApp_maybe ty
      , let tc_name = getName tc
      =  not (tc_name `elemNameSet` tcs)
831
      && case tyConSingleAlgDataCon_maybe tc of
832
            Just con | isVanillaDataCon con
833
                    -> ok_con_args (tcs `extendNameSet` getName tc) con
834
            _ -> True
835
      | otherwise
836 837 838
      = True

    ok_con_args tcs con
Simon Peyton Jones's avatar
Simon Peyton Jones committed
839 840 841
       = 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
842

843
    attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict)
844
      = xopt LangExt.StrictData dflags
845 846 847 848
    attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict)
      = True
    attempt_unpack (HsSrcBang _  NoSrcUnpack SrcStrict)
      = True  -- Be conservative
849
    attempt_unpack (HsSrcBang _  NoSrcUnpack NoSrcStrict)
850
      = xopt LangExt.StrictData dflags -- Be conservative
851
    attempt_unpack _ = False
852

Austin Seipp's avatar
Austin Seipp committed
853
{-
854 855 856 857 858 859 860 861 862 863 864 865 866 867 868
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
869
G which should have two Int#s.
870

871
However
872 873 874 875 876 877 878 879

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

Here we can represent T with an Int#.

Note [Recursive unboxing]
~~~~~~~~~~~~~~~~~~~~~~~~~
880
Consider
881 882 883
  data R = MkR {-# UNPACK #-} !S Int
  data S = MkS {-# UNPACK #-} !Int
The representation arguments of MkR are the *representation* arguments
884 885 886
of S (plus Int); the rep args of MkS are Int#.  This is all fine.

But be careful not to try to unbox this!
887
        data T = MkT {-# UNPACK #-} !T Int
888 889 890
Because then we'd get an infinite number of arguments.

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

Also behave conservatively when there is no UNPACK pragma
897
        data T = MkS !T Int
898 899
with -funbox-strict-fields or -funbox-small-strict-fields
we need to behave as if there was an UNPACK pragma there.
90