MkId.hs 55 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 25
        wrapTypeFamInstBody, wrapTypeUnbranchedFamInstBody, unwrapTypeFamInstScrut,
        unwrapTypeUnbranchedFamInstScrut,
26 27

        DataConBoxer(..), mkDataConRep, mkDataConWorkId,
28

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

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

#include "HsVersions.h"

Simon Marlow's avatar
Simon Marlow committed
43 44
import Rules
import TysPrim
45
import TysWiredIn
Simon Marlow's avatar
Simon Marlow committed
46 47
import PrelRules
import Type
48 49
import FamInstEnv
import Coercion
Simon Marlow's avatar
Simon Marlow committed
50
import TcType
51
import MkCore
52
import CoreUtils        ( exprType, mkCast )
Simon Marlow's avatar
Simon Marlow committed
53 54 55
import CoreUnfold
import Literal
import TyCon
56
import CoAxiom
Simon Marlow's avatar
Simon Marlow committed
57
import Class
58
import NameSet
Simon Marlow's avatar
Simon Marlow committed
59 60 61 62 63 64 65
import VarSet
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 79

import Data.Maybe       ( maybeToList )
80

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

88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103
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
104 105
    no way yet of expressing at the definition site for these
    error-reporting functions that they have an 'open'
106 107 108 109 110 111 112 113 114 115
    result type. -- sof 1/99]

(3) Other error functions (rUNTIME_ERROR_ID) are wired in (a) because
    the desugarer generates code that mentiones them directly, and
    (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

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

121
wiredInIds :: [Id]
122
wiredInIds
Joachim Breitner's avatar
Joachim Breitner committed
123
  =  [lazyId, dollarId, oneShotId]
124
  ++ errorIds           -- Defined in MkCore
125
  ++ ghcPrimIds
126 127

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

Austin Seipp's avatar
Austin Seipp committed
142 143 144
{-
************************************************************************
*                                                                      *
145
\subsection{Data constructors}
Austin Seipp's avatar
Austin Seipp committed
146 147
*                                                                      *
************************************************************************
148

149 150 151 152
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.

153 154
We're going to build a constructor that looks like:

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

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

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.

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

177 178 179 180 181 182 183 184 185
  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.

186 187
Note [Wrappers for data instance tycons]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
188 189
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
190 191 192 193 194
the wrapper.  For example, consider the declarations

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

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

202
  Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v}
203 204

The wrapper and worker of MapPair get the types
205

Ian Lynagh's avatar
Ian Lynagh committed
206
        -- Wrapper
207
  $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v
208
  $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v)
209

Ian Lynagh's avatar
Ian Lynagh committed
210
        -- Worker
211
  MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v
212

213
This coercion is conditionally applied by wrapFamInstBody.
214

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

217
   data instance T [a] where
Ian Lynagh's avatar
Ian Lynagh committed
218
        T1 :: forall b. b -> T [Maybe b]
219

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
220
Hence we translate to
221

Ian Lynagh's avatar
Ian Lynagh committed
222
        -- Wrapper
223
  $WT1 :: forall b. b -> T [Maybe b]
224
  $WT1 b v = T1 (Maybe b) b (Maybe b) v
Ian Lynagh's avatar
Ian Lynagh committed
225
                        `cast` sym (Co7T (Maybe b))
226

Ian Lynagh's avatar
Ian Lynagh committed
227
        -- Worker
228
  T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c
229

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

233 234 235 236 237 238 239 240 241 242 243
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.

244

Austin Seipp's avatar
Austin Seipp committed
245 246
************************************************************************
*                                                                      *
247
\subsection{Dictionary selectors}
Austin Seipp's avatar
Austin Seipp committed
248 249
*                                                                      *
************************************************************************
250

251
Selecting a field for a dictionary.  If there is just one field, then
252
there's nothing to do.
253

254
Dictionary selectors may get nested forall-types.  Thus:
255

256 257
        class Foo a where
          op :: forall b. Ord b => a -> b -> b
258

259
Then the top-level type for op is
260

261 262
        op :: forall a. Foo a =>
              forall b. Ord b =>
263
              a -> b -> b
264

265 266 267
This is unlike ordinary record selectors, which have all the for-alls
at the outside.  When dealing with classes it's very convenient to
recover the original type signature from the class op selector.
Austin Seipp's avatar
Austin Seipp committed
268
-}
269

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

    sel_ty = mkForAllTys tyvars (mkFunTy (mkClassPred clas (mkTyVarTys tyvars))
                                         (getNth arg_tys val_index))
286

287
    base_info = noCafIdInfo
288 289
                `setArityInfo`         1
                `setStrictnessInfo`    strict_sig
290 291 292 293

    info | new_tycon
         = base_info `setInlinePragInfo` alwaysInlinePragma
                     `setUnfoldingInfo`  mkInlineUnfolding (Just 1) (mkDictSelRhs clas val_index)
294 295
                   -- See Note [Single-method classes] in TcInstDcls
                   -- for why alwaysInlinePragma
296 297

         | otherwise
298
         = base_info `setRuleInfo` mkRuleInfo [rule]
299 300 301
                   -- Add a magic BuiltinRule, but no unfolding
                   -- so that the rule is always available to fire.
                   -- See Note [ClassOp/DFun selection] in TcInstDcls
302

303 304 305
    n_ty_args = length tyvars

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

313 314 315 316
        -- 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
317

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

336
    the_arg_id     = getNth arg_ids val_index
337 338 339
    pred           = mkClassPred clas (mkTyVarTys tyvars)
    dict_id        = mkTemplateLocal 1 pred
    arg_ids        = mkTemplateLocalsNum 2 arg_tys
340

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

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

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

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

375
  where
376 377 378 379 380 381 382
    tycon = dataConTyCon data_con

        ----------- Workers for data types --------------
    alg_wkr_ty = dataConRepType data_con
    wkr_arity = dataConRepArity data_con
    wkr_info  = noCafIdInfo
                `setArityInfo`       wkr_arity
383
                `setStrictnessInfo`  wkr_sig
384 385 386
                `setUnfoldingInfo`   evaldUnfolding  -- Record that it's evaluated,
                                                     -- even if arity = 0

387
    wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con)
388 389 390 391 392 393 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
        -- expresssions that do the evals) but the *worker* itself is not.
        -- 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.
        --
399
        -- When the simplifer sees a pattern
400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415
        --      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
                  `setInlinePragInfo`    alwaysInlinePragma
                  `setUnfoldingInfo`     newtype_unf
    id_arg1      = mkTemplateLocal 1 (head nt_arg_tys)
    newtype_unf  = ASSERT2( isVanillaDataCon data_con &&
                            isSingleton nt_arg_tys, ppr data_con  )
416 417 418
                              -- Note [Newtype datacons]
                   mkCompulsoryUnfolding $
                   mkLams nt_tvs $ Lam id_arg1 $
419
                   wrapNewTypeBody tycon res_ty_args (Var id_arg1)
420

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

    mAX_CPR_SIZE :: Arity
    mAX_CPR_SIZE = 10
    -- We do not treat very big tuples as CPR-ish:
440 441 442
    --      a) for a start we get into trouble because there aren't
    --         "enough" unboxed tuple types (a tiresome restriction,
    --         but hard to fix),
443 444 445 446
    --      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.
447

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

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

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

newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))
                       -- Bind these src-level vars, returning the
                       -- rep-level vars to bind in the pattern

468 469 470 471 472 473 474 475
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
476 477
  | not wrapper_reqd
  = return NoDataConRep
478

479
  | otherwise
480
  = do { wrap_args <- mapM newLocal wrap_arg_tys
481
       ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers)
482 483 484 485
                                 initial_wrap_app

       ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info
             wrap_info = noCafIdInfo
486 487 488 489 490 491 492 493 494 495 496
                         `setArityInfo`         wrap_arity
                             -- It's important to specify the arity, so that partial
                             -- applications are treated as values
                         `setInlinePragInfo`    alwaysInlinePragma
                         `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

             wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
497
             wrap_arg_dmds = map mk_dmd arg_ibangs
498
             mk_dmd str | isBanged str = evalDmd
499
                        | otherwise           = topDmd
500 501 502 503 504 505 506 507 508 509
                 -- The Cpr info can be important inside INLINE rhss, where the
                 -- wrapper constructor isn't inlined.
                 -- And the argument strictness can be important too; we
                 -- may not inline a contructor when it is partially applied.
                 -- For example:
                 --      data W = C !Int !Int !Int
                 --      ...(let w = C x in ...(w p q)...)...
                 -- we want to see that w is strict in its two arguments

             wrap_unf = mkInlineUnfolding (Just wrap_arity) wrap_rhs
510
             wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
511 512 513
             wrap_rhs = mkLams wrap_tvs $
                        mkLams wrap_args $
                        wrapFamInstBody tycon res_ty_args $
514 515 516 517 518 519
                        wrap_body

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

522
  where
523 524 525 526 527
    (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig data_con
    res_ty_args  = substTyVars (mkTopTvSubst eq_spec) univ_tvs
    tycon        = dataConTyCon data_con       -- The representation TyCon (not family)
    wrap_ty      = dataConUserType data_con
    ev_tys       = eqSpecPreds eq_spec ++ theta
528 529 530
    all_arg_tys  = ev_tys ++ orig_arg_tys
    ev_ibangs    = map mk_pred_strict_mark ev_tys
    orig_bangs   = dataConSrcBangs data_con
531 532 533

    wrap_arg_tys = theta ++ orig_arg_tys
    wrap_arity   = length wrap_arg_tys
534 535 536
             -- 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
537

538 539 540 541 542 543 544 545 546
    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))

547
    (unboxers, boxers) = unzip wrappers
548 549 550
    (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)

    wrapper_reqd = not (isNewTyCon tycon)  -- Newtypes have only a worker
551 552
                && (any isBanged (ev_ibangs ++ arg_ibangs)
                      -- Some forcing/unboxing (includes eq_spec)
553
                    || isFamInstTyCon tycon) -- Cast result
554 555 556

    initial_wrap_app = Var (dataConWorkId data_con)
                      `mkTyApps`  res_ty_args
557 558 559 560
                      `mkVarApps` ex_tvs
                      `mkCoApps`  map (mkReflCo Nominal . snd) eq_spec
                        -- Dont box the eq_spec coercions since they are
                        -- marked as HsUnpack by mk_dict_strict_mark
561 562

    mk_boxer :: [Boxer] -> DataConBoxer
563
    mk_boxer boxers = DCB (\ ty_args src_vars ->
564 565
                      do { let ex_vars = takeList ex_tvs src_vars
                               subst1 = mkTopTvSubst (univ_tvs `zip` ty_args)
566
                               subst2 = extendTvSubstList subst1 ex_tvs
567 568 569 570 571 572 573 574 575 576 577 578 579 580 581
                                                          (mkTyVarTys ex_vars)
                         ; (rep_ids, binds) <- go subst2 boxers (dropList ex_tvs src_vars)
                         ; 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
582
    mk_rep_app [] con_app
583
      = return con_app
584
    mk_rep_app ((wrap_arg, unboxer) : prs) con_app
585 586 587 588
      = do { (rep_ids, unbox_fn) <- unboxer wrap_arg
           ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids)
           ; return (unbox_fn expr) }

589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609
{-
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.

-}

610 611
-------------------------
newLocal :: Type -> UniqSM Var
612
newLocal ty = do { uniq <- getUniqueM
613 614
                 ; return (mkSysLocal (fsLit "dt") uniq ty) }

615 616
-- | Unpack/Strictness decisions from source module
dataConSrcToImplBang
617
   :: DynFlags
618
   -> FamInstEnvs
Simon Peyton Jones's avatar
Simon Peyton Jones committed
619
   -> Type
620 621
   -> HsSrcBang
   -> HsImplBang
622

623 624 625 626 627 628 629
dataConSrcToImplBang dflags fam_envs arg_ty
              (HsSrcBang ann unpk NoSrcStrict)
  | xopt Opt_StrictData dflags -- StrictData => strict field
  = dataConSrcToImplBang dflags fam_envs arg_ty
                  (HsSrcBang ann unpk SrcStrict)
  | otherwise -- no StrictData => lazy field
  = HsLazy
630

631 632
dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy)
  = HsLazy
633

634
dataConSrcToImplBang dflags fam_envs arg_ty
635
    (HsSrcBang _ unpk_prag SrcStrict)
636
  | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
637
          -- Don't unpack if we aren't optimising; rather arbitrarily,
638
          -- we use -fomit-iface-pragmas as the indication
639
  , let mb_co   = topNormaliseType_maybe fam_envs arg_ty
640
                     -- Unwrap type families and newtypes
641
        arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }
642
  , isUnpackableType dflags fam_envs arg_ty'
643
  , (rep_tys, _) <- dataConArgUnpack arg_ty'
644
  , case unpk_prag of
645 646 647 648 649
      NoSrcUnpack ->
        gopt Opt_UnboxStrictFields dflags
            || (gopt Opt_UnboxSmallStrictFields dflags
                && length rep_tys <= 1) -- See Note [Unpack one-wide fields]
      srcUnpack -> isSrcUnpacked srcUnpack
650
  = case mb_co of
651 652
      Nothing     -> HsUnpack Nothing
      Just (co,_) -> HsUnpack (Just co)
653

654
  | otherwise -- Record the strict-but-no-unpack decision
655
  = HsStrict
656

657

658 659 660 661 662 663 664 665 666 667
-- | Wrappers/Workser and representation following Unpack/Strictness
-- decisions
dataConArgRep
  :: Type
  -> HsImplBang
  -> ([(Type,StrictnessMark)] -- Rep types
     ,(Unboxer,Boxer))

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

669 670 671 672
dataConArgRep arg_ty HsStrict
  = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))

dataConArgRep arg_ty (HsUnpack Nothing)
673
  | (rep_tys, wrappers) <- dataConArgUnpack arg_ty
674
  = (rep_tys, wrappers)
675

676
dataConArgRep _ (HsUnpack (Just co))
677 678
  | let co_rep_ty = pSnd (coercionKind co)
  , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty
679
  = (rep_tys, wrapCo co co_rep_ty wrappers)
680 681 682


-------------------------
683 684 685 686 687 688 689 690
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) }
691 692
    boxer = Boxer $ \ subst ->
            do { (rep_ids, rep_expr)
693 694 695 696 697 698 699 700
                    <- case box_rep of
                         UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty)
                                       ; return ([rep_id], Var rep_id) }
                         Boxer boxer -> boxer subst
               ; let sco = substCo (tvCvSubst subst) co
               ; return (rep_ids, rep_expr `Cast` mkSymCo sco) }

------------------------
701 702 703 704 705 706 707 708 709 710 711 712
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
713 714
   ->  ( [(Type, StrictnessMark)]   -- Rep types
       , (Unboxer, Boxer) )
715 716

dataConArgUnpack arg_ty
717
  | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty
718 719
  , Just con <- tyConSingleAlgDataCon_maybe tc
      -- NB: check for an *algebraic* data type
720
      -- A recursive newtype might mean that
721
      -- 'arg_ty' is a newtype
722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739
  , 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 ->
       do { rep_ids <- mapM (newLocal . TcType.substTy subst) rep_tys
          ; return (rep_ids, Var (dataConWorkId con)
                             `mkTyApps` (substTys subst tc_args)
                             `mkVarApps` rep_ids ) } ) )
  | otherwise
  = pprPanic "dataConArgUnpack" (ppr arg_ty)
    -- An interface file specified Unpacked, but we couldn't unpack it

740
isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool
741
-- True if we can unpack the UNPACK the argument type
742 743 744 745
-- 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!
746
isUnpackableType dflags fam_envs ty
747
  | Just (tc, _) <- splitTyConApp_maybe ty
748
  , Just con <- tyConSingleAlgDataCon_maybe tc
749 750 751 752
  , isVanillaDataCon con
  = ok_con_args (unitNameSet (getName tc)) con
  | otherwise
  = False
753
  where
754
    ok_arg tcs (ty, bang) = not (attempt_unpack bang) || ok_ty tcs norm_ty
755
        where
756
          norm_ty = topNormaliseType fam_envs ty
757 758 759 760
    ok_ty tcs ty
      | Just (tc, _) <- splitTyConApp_maybe ty
      , let tc_name = getName tc
      =  not (tc_name `elemNameSet` tcs)
761
      && case tyConSingleAlgDataCon_maybe tc of
762
            Just con | isVanillaDataCon con
763
                    -> ok_con_args (tcs `extendNameSet` getName tc) con
764
            _ -> True
765
      | otherwise
766 767 768
      = True

    ok_con_args tcs con
Simon Peyton Jones's avatar
Simon Peyton Jones committed
769 770 771
       = 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
772

773
    attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict)
774 775 776 777 778
      = xopt Opt_StrictData dflags
    attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict)
      = True
    attempt_unpack (HsSrcBang _  NoSrcUnpack SrcStrict)
      = True  -- Be conservative
779
    attempt_unpack (HsSrcBang _  NoSrcUnpack NoSrcStrict)
780 781
      = xopt Opt_StrictData dflags -- Be conservative
    attempt_unpack _ = False
782

Austin Seipp's avatar
Austin Seipp committed
783
{-
784 785 786 787 788 789 790 791 792 793 794 795 796 797 798
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
799
G which should have two Int#s.
800

801
However
802 803 804 805 806 807 808 809

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

Here we can represent T with an Int#.

Note [Recursive unboxing]
~~~~~~~~~~~~~~~~~~~~~~~~~
810
Consider
811 812 813
  data R = MkR {-# UNPACK #-} !S Int
  data S = MkS {-# UNPACK #-} !Int
The representation arguments of MkR are the *representation* arguments
814 815 816
of S (plus Int); the rep args of MkS are Int#.  This is all fine.

But be careful not to try to unbox this!
817
        data T = MkT {-# UNPACK #-} !T Int
818 819 820
Because then we'd get an infinite number of arguments.

Here is a more complicated case:
821 822
        data S = MkS {-# UNPACK #-} !T Int
        data T = MkT {-# UNPACK #-} !S Int
823 824 825 826
Each of S and T must decide independendently whether to unpack
and they had better not both say yes. So they must both say no.

Also behave conservatively when there is no UNPACK pragma
827
        data T = MkS !T Int
828 829
with -funbox-strict-fields or -funbox-small-strict-fields
we need to behave as if there was an UNPACK pragma there.
830 831

But it's the *argument* type that matters. This is fine:
832
        data S = MkS S !Int
833 834 835 836 837 838 839 840 841 842 843
because Int is non-recursive.


Note [Unpack equality predicates]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we have a GADT with a contructor C :: (a~[b]) => b -> T a
we definitely want that equality predicate *unboxed* so that it
takes no space at all.  This is easily done: just give it
an UNPACK pragma. The rest of the unpack/repack code does the
heavy lifting.  This one line makes every GADT take a word less
space for each equality predicate, so it's pretty important!
Austin Seipp's avatar
Austin Seipp committed
844
-}
845

846
mk_pred_strict_mark :: PredType -> HsImplBang
847
mk_pred_strict_mark pred
848 849
  | isEqPred pred = HsUnpack Nothing
  -- Note [Unpack equality predicates]
850
  | otherwise     = HsLazy
851

Austin Seipp's avatar
Austin Seipp committed
852 853 854
{-
************************************************************************
*                                                                      *
Ian Lynagh's avatar
Ian Lynagh committed
855
        Wrapping and unwrapping newtypes and type families
Austin Seipp's avatar
Austin Seipp committed
856 857 858
*                                                                      *
************************************************************************
-}
859

860 861
wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
-- The wrapper for the data constructor for a newtype looks like this:
Ian Lynagh's avatar
Ian Lynagh committed
862 863 864
--      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
865
-- where CoT is the coercion TyCon associated with the newtype
866 867 868
--
-- The call (wrapNewTypeBody T [a] e) returns the
-- body of the wrapper, namely
Ian Lynagh's avatar
Ian Lynagh committed
869
--      e `cast` (CoT [a])
870
--
871
-- If a coercion constructor is provided in the newtype, then we use
872
-- it, otherwise the wrap/unwrap are both no-ops
873
--
874
-- 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
875 876 877
-- 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).
878

879
wrapNewTypeBody tycon args result_expr
880 881
  = ASSERT( isNewTyCon tycon )
    wrapFamInstBody tycon args $
882
    mkCast result_expr (mkSymCo co)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
883
  where
884
    co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args
885

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
886 887 888 889
-- 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).
890

891 892
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon args result_expr
893
  = ASSERT( isNewTyCon tycon )
894
    mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args)
895

896 897 898 899 900 901 902 903
-- 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
904
  = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args))
905 906
  | otherwise
  = body
907

908 909
-- Same as `wrapFamInstBody`, but for type family instances, which are
-- represented by a `CoAxiom`, and not a `TyCon`
910 911
wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr
wrapTypeFamInstBody axiom ind args body
912
  = mkCast body (mkSymCo (mkAxInstCo Representational axiom ind args))
913

Jan Stolarek's avatar
Jan Stolarek committed
914 915
wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> CoreExpr
                              -> CoreExpr
916 917
wrapTypeUnbranchedFamInstBody axiom
  = wrapTypeFamInstBody axiom 0