MkId.hs 53 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

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

#include "HsVersions.h"

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
import CoreUnfold
import Literal
import TyCon
55
import CoAxiom
Simon Marlow's avatar
Simon Marlow committed
56
import Class
57
import NameSet
Simon Marlow's avatar
Simon Marlow committed
58 59 60 61 62 63 64
import VarSet
import Name
import PrimOp
import ForeignCall
import DataCon
import Id
import IdInfo
65
import Demand
66
import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
67
import Unique
68
import UniqSupply
69
import PrelNames
Simon Marlow's avatar
Simon Marlow committed
70 71
import BasicTypes       hiding ( SuccessFlag(..) )
import Util
72
import Pair
Ian Lynagh's avatar
Ian Lynagh committed
73
import DynFlags
74
import Outputable
75
import FastString
Simon Marlow's avatar
Simon Marlow committed
76
import ListSetOps
77 78

import Data.Maybe       ( maybeToList )
79

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

87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102
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
103 104
    no way yet of expressing at the definition site for these
    error-reporting functions that they have an 'open'
105 106 107 108 109 110 111 112 113 114
    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
115
can be called; but the wired-in version means that the details are
116 117
never read from that module's interface file; instead, the full definition
is right here.
Austin Seipp's avatar
Austin Seipp committed
118
-}
119

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

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

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

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

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

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

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

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.

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

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

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

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

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

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

The wrapper and worker of MapPair get the types
204

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

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

212
This coercion is conditionally applied by wrapFamInstBody.
213

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

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

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

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

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

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

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

243

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

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

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

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

258
Then the top-level type for op is
259

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

264 265 266
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
267
-}
268

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

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

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

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

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

302 303 304
    n_ty_args = length tyvars

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

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

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

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

340 341
    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
342
                                [(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)]
343 344
                                -- varToCoreExpr needed for equality superclass selectors
                                --   sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }
345

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

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

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

374
  where
375 376 377 378 379 380 381
    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
382
                `setStrictnessInfo`  wkr_sig
383 384 385
                `setUnfoldingInfo`   evaldUnfolding  -- Record that it's evaluated,
                                                     -- even if arity = 0

386
    wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con)
387 388 389 390 391 392 393 394 395 396 397
        --      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.
        --
398
        -- When the simplifer sees a pattern
399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414
        --      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  )
415 416 417
                              -- Note [Newtype datacons]
                   mkCompulsoryUnfolding $
                   mkLams nt_tvs $ Lam id_arg1 $
418
                   wrapNewTypeBody tycon res_ty_args (Var id_arg1)
419

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

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

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

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

mkDataConRep :: DynFlags -> FamInstEnvs -> Name -> DataCon -> UniqSM DataConRep
mkDataConRep dflags fam_envs wrap_name data_con
469 470
  | not wrapper_reqd
  = return NoDataConRep
471

472
  | otherwise
473
  = do { wrap_args <- mapM newLocal wrap_arg_tys
474
       ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers)
475 476 477 478
                                 initial_wrap_app

       ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info
             wrap_info = noCafIdInfo
479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502
                         `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)
             wrap_arg_dmds = map mk_dmd (dropList eq_spec wrap_bangs)
             mk_dmd str | isBanged str = evalDmd
                        | otherwise    = topDmd
                 -- 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
503
             wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
504 505 506
             wrap_rhs = mkLams wrap_tvs $
                        mkLams wrap_args $
                        wrapFamInstBody tycon res_ty_args $
507 508 509 510 511 512 513
                        wrap_body

       ; return (DCR { dcr_wrap_id = wrap_id
                     , dcr_boxer   = mk_boxer boxers
                     , dcr_arg_tys = rep_tys
                     , dcr_stricts = rep_strs
                     , dcr_bangs   = dropList ev_tys wrap_bangs }) }
514

515
  where
516 517 518 519 520 521
    (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
    all_arg_tys  = ev_tys                         ++ orig_arg_tys
Simon Peyton Jones's avatar
Simon Peyton Jones committed
522
    orig_bangs   = map mk_pred_strict_mark ev_tys ++ dataConSrcBangs data_con
523 524 525

    wrap_arg_tys = theta ++ orig_arg_tys
    wrap_arity   = length wrap_arg_tys
526 527 528
             -- 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
529

530 531 532
    (wrap_bangs, rep_tys_w_strs, wrappers)
       = unzip3 (zipWith (dataConArgRep dflags fam_envs) all_arg_tys orig_bangs)
    (unboxers, boxers) = unzip wrappers
533 534 535 536 537 538 539 540 541
    (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)

    wrapper_reqd = not (isNewTyCon tycon)  -- Newtypes have only a worker
                && (any isBanged orig_bangs   -- Some forcing/unboxing
                                              -- (includes eq_spec)
                    || isFamInstTyCon tycon)  -- Cast result

    initial_wrap_app = Var (dataConWorkId data_con)
                      `mkTyApps`  res_ty_args
542 543 544 545
                      `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
546 547

    mk_boxer :: [Boxer] -> DataConBoxer
548
    mk_boxer boxers = DCB (\ ty_args src_vars ->
549 550
                      do { let ex_vars = takeList ex_tvs src_vars
                               subst1 = mkTopTvSubst (univ_tvs `zip` ty_args)
551
                               subst2 = extendTvSubstList subst1 ex_tvs
552 553 554 555 556 557 558 559 560 561 562 563 564 565 566
                                                          (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
567
    mk_rep_app [] con_app
568
      = return con_app
569
    mk_rep_app ((wrap_arg, unboxer) : prs) con_app
570 571 572 573 574 575
      = do { (rep_ids, unbox_fn) <- unboxer wrap_arg
           ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids)
           ; return (unbox_fn expr) }

-------------------------
newLocal :: Type -> UniqSM Var
576
newLocal ty = do { uniq <- getUniqueM
577 578 579 580
                 ; return (mkSysLocal (fsLit "dt") uniq ty) }

-------------------------
dataConArgRep
581
   :: DynFlags
582
   -> FamInstEnvs
Simon Peyton Jones's avatar
Simon Peyton Jones committed
583 584 585 586 587 588 589 590
   -> Type 
   -> HsSrcBang     -- For DataCons defined in this module, this is the
                    --    bang/unpack annotation that the programmer wrote
                    -- For DataCons imported from an interface file, this
                    --    is the HsImplBang implementation decision taken
                    --    by the compiler in the defining module; just follow
                    --    it slavishly, so that we make the same decision as
                    --    in the defining module
Simon Peyton Jones's avatar
Simon Peyton Jones committed
591
   -> ( HsImplBang                 -- Implementation decision about unpack strategy
592
      , [(Type, StrictnessMark)]   -- Rep types
593 594 595 596 597
      , (Unboxer, Boxer) )

dataConArgRep _ _ arg_ty HsNoBang
  = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))

Alan Zimmerman's avatar
Alan Zimmerman committed
598
dataConArgRep _ _ arg_ty (HsSrcBang _ _ False)  -- No '!'
599 600
  = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))

601
dataConArgRep dflags fam_envs arg_ty
Alan Zimmerman's avatar
Alan Zimmerman committed
602
    (HsSrcBang _ unpk_prag True)  -- {-# UNPACK #-} !
603
  | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
604
          -- Don't unpack if we aren't optimising; rather arbitrarily,
605
          -- we use -fomit-iface-pragmas as the indication
606
  , let mb_co   = topNormaliseType_maybe fam_envs arg_ty
607
                     -- Unwrap type families and newtypes
608 609 610
        arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }
  , isUnpackableType fam_envs arg_ty'
  , (rep_tys, wrappers) <- dataConArgUnpack arg_ty'
611 612
  , case unpk_prag of
      Nothing -> gopt Opt_UnboxStrictFields dflags
613
              || (gopt Opt_UnboxSmallStrictFields dflags
614 615
                   && length rep_tys <= 1)  -- See Note [Unpack one-wide fields]
      Just unpack_me -> unpack_me
616 617 618
  = case mb_co of
      Nothing          -> (HsUnpack Nothing,   rep_tys, wrappers)
      Just (co,rep_ty) -> (HsUnpack (Just co), rep_tys, wrapCo co rep_ty wrappers)
619 620 621 622

  | otherwise  -- Record the strict-but-no-unpack decision
  = strict_but_not_unpacked arg_ty

623 624
dataConArgRep _ _ arg_ty HsStrict
  = strict_but_not_unpacked arg_ty
625

626 627 628
dataConArgRep _ _ arg_ty (HsUnpack Nothing)
  | (rep_tys, wrappers) <- dataConArgUnpack arg_ty
  = (HsUnpack Nothing, rep_tys, wrappers)
629

630 631 632 633
dataConArgRep _ _ _ (HsUnpack (Just co))
  | let co_rep_ty = pSnd (coercionKind co)
  , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty
  = (HsUnpack (Just co), rep_tys, wrapCo co co_rep_ty wrappers)
634

Simon Peyton Jones's avatar
Simon Peyton Jones committed
635
strict_but_not_unpacked :: Type -> (HsImplBang, [(Type,StrictnessMark)], (Unboxer, Boxer))
636
strict_but_not_unpacked arg_ty
637
  = (HsStrict, [(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))
638 639

-------------------------
640 641 642 643 644 645 646 647
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) }
648 649
    boxer = Boxer $ \ subst ->
            do { (rep_ids, rep_expr)
650 651 652 653 654 655 656 657
                    <- 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) }

------------------------
658 659 660 661 662 663 664 665 666 667 668 669
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
670 671
   ->  ( [(Type, StrictnessMark)]   -- Rep types
       , (Unboxer, Boxer) )
672 673

dataConArgUnpack arg_ty
674
  | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty
675 676
  , Just con <- tyConSingleAlgDataCon_maybe tc
      -- NB: check for an *algebraic* data type
677
      -- A recursive newtype might mean that
678
      -- 'arg_ty' is a newtype
679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697
  , 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

isUnpackableType :: FamInstEnvs -> Type -> Bool
698
-- True if we can unpack the UNPACK the argument type
699 700 701 702
-- 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!
703 704
isUnpackableType fam_envs ty
  | Just (tc, _) <- splitTyConApp_maybe ty
705
  , Just con <- tyConSingleAlgDataCon_maybe tc
706 707 708 709
  , isVanillaDataCon con
  = ok_con_args (unitNameSet (getName tc)) con
  | otherwise
  = False
710
  where
711
    ok_arg tcs (ty, bang) = not (attempt_unpack bang) || ok_ty tcs norm_ty
712
        where
713
          norm_ty = topNormaliseType fam_envs ty
714 715 716 717
    ok_ty tcs ty
      | Just (tc, _) <- splitTyConApp_maybe ty
      , let tc_name = getName tc
      =  not (tc_name `elemNameSet` tcs)
718
      && case tyConSingleAlgDataCon_maybe tc of
719
            Just con | isVanillaDataCon con
720
                    -> ok_con_args (tcs `extendNameSet` getName tc) con
721
            _ -> True
722
      | otherwise
723 724 725
      = True

    ok_con_args tcs con
Simon Peyton Jones's avatar
Simon Peyton Jones committed
726 727 728
       = 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
729

Alan Zimmerman's avatar
Alan Zimmerman committed
730 731 732 733 734
    attempt_unpack (HsUnpack {})                  = True
    attempt_unpack (HsSrcBang _ (Just unpk) bang) = bang && unpk
    attempt_unpack (HsSrcBang _  Nothing bang)     = bang  -- Be conservative
    attempt_unpack HsStrict                       = False
    attempt_unpack HsNoBang                       = False
735

Austin Seipp's avatar
Austin Seipp committed
736
{-
737 738 739 740 741 742 743 744 745 746 747 748 749 750 751
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
752
G which should have two Int#s.
753

754
However
755 756 757 758 759 760 761 762

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

Here we can represent T with an Int#.

Note [Recursive unboxing]
~~~~~~~~~~~~~~~~~~~~~~~~~
763
Consider
764 765 766
  data R = MkR {-# UNPACK #-} !S Int
  data S = MkS {-# UNPACK #-} !Int
The representation arguments of MkR are the *representation* arguments
767 768 769
of S (plus Int); the rep args of MkS are Int#.  This is all fine.

But be careful not to try to unbox this!
770
        data T = MkT {-# UNPACK #-} !T Int
771 772 773
Because then we'd get an infinite number of arguments.

Here is a more complicated case:
774 775
        data S = MkS {-# UNPACK #-} !T Int
        data T = MkT {-# UNPACK #-} !S Int
776 777 778 779
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
780
        data T = MkS !T Int
781 782
with -funbox-strict-fields or -funbox-small-strict-fields
we need to behave as if there was an UNPACK pragma there.
783 784

But it's the *argument* type that matters. This is fine:
785
        data S = MkS S !Int
786 787 788 789 790 791 792 793 794 795 796
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
797
-}
798

Simon Peyton Jones's avatar
Simon Peyton Jones committed
799
mk_pred_strict_mark :: PredType -> HsSrcBang
800 801
mk_pred_strict_mark pred
  | isEqPred pred = HsUnpack Nothing    -- Note [Unpack equality predicates]
802
  | otherwise     = HsNoBang
803

Austin Seipp's avatar
Austin Seipp committed
804 805 806
{-
************************************************************************
*                                                                      *
Ian Lynagh's avatar
Ian Lynagh committed
807
        Wrapping and unwrapping newtypes and type families
Austin Seipp's avatar
Austin Seipp committed
808 809 810
*                                                                      *
************************************************************************
-}
811

812 813
wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
-- The wrapper for the data constructor for a newtype looks like this:
Ian Lynagh's avatar
Ian Lynagh committed
814 815 816
--      newtype T a = MkT (a,Int)
--      MkT :: forall a. (a,Int) -> T a
--      MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a)
817 818 819 820
-- where CoT is the coercion TyCon assoicated with the newtype
--
-- The call (wrapNewTypeBody T [a] e) returns the
-- body of the wrapper, namely
Ian Lynagh's avatar
Ian Lynagh committed
821
--      e `cast` (CoT [a])
822
--
823
-- If a coercion constructor is provided in the newtype, then we use
824
-- it, otherwise the wrap/unwrap are both no-ops
825
--
826
-- 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
827 828 829
-- 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).
830

831
wrapNewTypeBody tycon args result_expr
832 833
  = ASSERT( isNewTyCon tycon )
    wrapFamInstBody tycon args $
834
    mkCast result_expr (mkSymCo co)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
835
  where
836
    co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args
837

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
838 839 840 841
-- 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).
842

843 844
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon args result_expr
845
  = ASSERT( isNewTyCon tycon )
846
    mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args)
847

848 849 850 851 852 853 854 855
-- 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
856
  = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args))
857 858
  | otherwise
  = body
859

860 861
-- Same as `wrapFamInstBody`, but for type family instances, which are
-- represented by a `CoAxiom`, and not a `TyCon`
862 863
wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr
wrapTypeFamInstBody axiom ind args body
864
  = mkCast body (mkSymCo (mkAxInstCo Representational axiom ind args))
865 866 867 868

wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr
wrapTypeUnbranchedFamInstBody axiom
  = wrapTypeFamInstBody axiom 0
869

870 871 872
unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapFamInstScrut tycon args scrut
  | Just co_con <- tyConFamilyCoercion_maybe tycon
873
  = mkCast scrut (mkUnbranchedAxInstCo Representational co_con args) -- data instances only
874 875
  | otherwise
  = scrut
876

877 878
unwrapTypeFamInstScrut :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr
unwrapTypeFamInstScrut axiom ind args scrut
879
  = mkCast scrut (mkAxInstCo Representational axiom ind args)
880 881 882 883

unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr
unwrapTypeUnbranchedFamInstScrut axiom
  = unwrapTypeFamInstScrut axiom 0
884

Austin Seipp's avatar
Austin Seipp committed
885 886 887
{-
************************************************************************
*                                                                      *
888
\subsection{Primitive operations}