MkId.lhs 49.4 KB
Newer Older
Thomas Schilling's avatar
Thomas Schilling committed
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The AQUA Project, Glasgow University, 1998
4 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
13 14

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
15 16 17 18 19 20 21
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

22
module MkId (
23
        mkDictFunId, mkDictFunTy, mkDictSelId,
24

25
        mkPrimOpId, mkFCallId,
26

27
        wrapNewTypeBody, unwrapNewTypeBody,
28
        wrapFamInstBody, unwrapFamInstScrut,
29 30
        wrapTypeFamInstBody, wrapTypeUnbranchedFamInstBody, unwrapTypeFamInstScrut,
        unwrapTypeUnbranchedFamInstScrut,
31 32

        DataConBoxer(..), mkDataConRep, mkDataConWorkId,
33

Ian Lynagh's avatar
Ian Lynagh committed
34 35
        -- And some particular Ids; see below for why they are wired in
        wiredInIds, ghcPrimIds,
36
        unsafeCoerceName, unsafeCoerceId, realWorldPrimId, 
37
        voidArgId, nullAddrId, seqId, lazyId, lazyIdKey,
38
        coercionTokenId, magicSingIId,
39 40 41

	-- Re-export error Ids
	module PrelRules
42 43 44 45
    ) where

#include "HsVersions.h"

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

import Data.Maybe       ( maybeToList )
84
\end{code}
85

86
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
87
%*                                                                      *
88
\subsection{Wired in Ids}
Ian Lynagh's avatar
Ian Lynagh committed
89
%*                                                                      *
90 91
%************************************************************************

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

124
\begin{code}
125
wiredInIds :: [Id]
126
wiredInIds
127 128 129
  =  [lazyId]
  ++ errorIds		-- Defined in MkCore
  ++ 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 137 138
    realWorldPrimId,
    unsafeCoerceId,
    nullAddrId,
139 140
    seqId,
    magicSingIId
141 142 143
    ]
\end{code}

144
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
145
%*                                                                      *
146
\subsection{Data constructors}
Ian Lynagh's avatar
Ian Lynagh committed
147
%*                                                                      *
148 149
%************************************************************************

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

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

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

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

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.

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

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

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

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

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

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

The wrapper and worker of MapPair get the types
206

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

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

214
This coercion is conditionally applied by wrapFamInstBody.
215

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

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

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

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

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

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

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

245 246

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
247
%*                                                                      *
248
\subsection{Dictionary selectors}
Ian Lynagh's avatar
Ian Lynagh committed
249
%*                                                                      *
250 251
%************************************************************************

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

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

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

260
Then the top-level type for op is
261

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

266 267 268
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.
269

270
\begin{code}
271 272
mkDictSelId :: DynFlags
            -> Bool	     -- True <=> don't include the unfolding
273 274 275 276 277
			     -- Little point on imports without -O, because the
			     -- dictionary itself won't be visible
 	    -> Name	     -- Name of one of the *value* selectors 
	       		     -- (dictionary superclass or method)
            -> Class -> Id
278
mkDictSelId dflags no_unf name clas
279 280 281 282 283 284 285 286
  = mkGlobalId (ClassOpId clas) name sel_ty info
  where
    sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id))
        -- We can't just say (exprType rhs), because that would give a type
        --      C a -> C a
        -- for a single-op class (after all, the selector is the identity)
        -- But it's type must expose the representation of the dictionary
        -- to get (say)         C a -> (a -> a)
287

288
    base_info = noCafIdInfo
289 290 291 292
                `setArityInfo`         1
                `setStrictnessInfo`    strict_sig
                `setUnfoldingInfo`     (if no_unf then noUnfolding
	                                else mkImplicitUnfolding dflags rhs)
293 294
		   -- In module where class op is defined, we must add
		   -- the unfolding, even though it'll never be inlined
Gabor Greif's avatar
typos  
Gabor Greif committed
295
		   -- because we use that to generate a top-level binding
296 297
		   -- for the ClassOp

298
    info | new_tycon = base_info `setInlinePragInfo` alwaysInlinePragma
Simon Peyton Jones's avatar
Simon Peyton Jones committed
299 300
    	   	   -- See Note [Single-method classes] in TcInstDcls
		   -- for why alwaysInlinePragma
301 302 303 304 305
         | otherwise = base_info  `setSpecInfo`       mkSpecInfo [rule]
		       		  `setInlinePragInfo` neverInlinePragma
		   -- Add a magic BuiltinRule, and never inline it
		   -- so that the rule is always available to fire.
		   -- See Note [ClassOp/DFun selection] in TcInstDcls
306

307 308 309 310 311 312 313 314
    n_ty_args = length tyvars

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

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

    strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] topRes)
323
    arg_dmd | new_tycon = evalDmd
324 325
            | otherwise = mkManyUsedDmd $
                          mkProdDmd [ if the_arg_id == id then evalDmd else absDmd
326 327
                                    | id <- arg_ids ]

328 329 330 331 332
    tycon      	   = classTyCon clas
    new_tycon  	   = isNewTyCon tycon
    [data_con] 	   = tyConDataCons tycon
    tyvars     	   = dataConUnivTyVars data_con
    arg_tys    	   = dataConRepArgTys data_con	-- Includes the dictionary superclasses
333

334 335 336
    -- 'index' is a 0-index into the *value* arguments of the dictionary
    val_index      = assoc "MkId.mkDictSelId" sel_index_prs name
    sel_index_prs  = map idName (classAllSelIds clas) `zip` [0..]
337

338
    the_arg_id     = getNth arg_ids val_index
339
    pred       	   = mkClassPred clas (mkTyVarTys tyvars)
batterseapower's avatar
batterseapower committed
340
    dict_id    	   = mkTemplateLocal 1 pred
341
    arg_ids    	   = mkTemplateLocalsNum 2 arg_tys
342

343
    rhs = mkLams tyvars  (Lam dict_id   rhs_body)
344 345
    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
346 347 348
                                [(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)]
				-- 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
\end{code}
363 364


365 366 367 368 369
%************************************************************************
%*                                                                      *
        Boxing and unboxing
%*                                                                      *
%************************************************************************
370

371 372 373 374 375 376 377 378 379

\begin{code}
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

380
  where
381 382 383 384 385 386 387
    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
388
                `setStrictnessInfo`  wkr_sig
389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424
                `setUnfoldingInfo`   evaldUnfolding  -- Record that it's evaluated,
                                                     -- even if arity = 0

    wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) (dataConCPR data_con))
        --      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.
        --
        -- When the simplifer sees a pattern 
        --      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  )
			      -- Note [Newtype datacons]
                   mkCompulsoryUnfolding $ 
                   mkLams nt_tvs $ Lam id_arg1 $ 
                   wrapNewTypeBody tycon res_ty_args (Var id_arg1)
425

426 427
dataConCPR :: DataCon -> DmdResult
dataConCPR con
428 429 430
  | isDataTyCon tycon     -- Real data types only; that is, 
                          -- not unboxed tuples or newtypes
  , isVanillaDataCon con  -- No existentials 
431 432
  , wkr_arity > 0
  , wkr_arity <= mAX_CPR_SIZE
433 434
  = if is_prod then cprProdRes 
               else cprSumRes (dataConTag con)
435
  | otherwise
436
  = topRes
437
  where
438
    is_prod = isProductTyCon tycon
439 440 441 442 443 444 445 446 447 448 449 450 451 452
    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:
    --      a) for a start we get into trouble because there aren't 
    --         "enough" unboxed tuple types (a tiresome restriction, 
    --         but hard to fix), 
    --      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.
\end{code}
453

454 455 456 457 458 459 460 461 462
-------------------------------------------------
--         Data constructor representation
-- 
-- This is where we decide how to wrap/unwrap the 
-- constructor fields
--
--------------------------------------------------


463
\begin{code}
464 465 466 467 468 469 470 471 472 473 474 475
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
476 477
  | not wrapper_reqd
  = return NoDataConRep
478

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

       ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info
             wrap_info = noCafIdInfo
                    	 `setArityInfo`         wrap_arity
                    	     -- It's important to specify the arity, so that partial
                    	     -- applications are treated as values
		    	 `setInlinePragInfo`    alwaysInlinePragma
                    	 `setUnfoldingInfo`     wrap_unf
491
                    	 `setStrictnessInfo`    wrap_sig
492 493 494 495 496 497 498
                    	     -- 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 = mkStrictSig (mkTopDmdType wrap_arg_dmds (dataConCPR data_con))
    	     wrap_arg_dmds = map mk_dmd (dropList eq_spec wrap_bangs)
    	     mk_dmd str | isBanged str = evalDmd
499
    	                | otherwise    = topDmd
500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520
    	         -- 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
             wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
    	     wrap_rhs = mkLams wrap_tvs $ 
    	                mkLams wrap_args $
    	                wrapFamInstBody tycon res_ty_args $
                        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 }) }
521

522
  where
523 524 525 526 527 528 529 530 531 532 533 534 535 536
    (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
    orig_bangs   = map mk_pred_strict_mark ev_tys ++ dataConStrictMarks data_con

    wrap_arg_tys = theta ++ orig_arg_tys
    wrap_arity   = length wrap_arg_tys
    	     -- 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
    (wrap_bangs, rep_tys_w_strs, wrappers)
       = unzip3 (zipWith (dataConArgRep dflags fam_envs) all_arg_tys orig_bangs)
    (unboxers, boxers) = unzip wrappers
540 541 542 543 544 545 546 547 548 549
    (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
    	              `mkVarApps` ex_tvs                 
550
    	              `mkCoApps`  map (mkReflCo Nominal . snd) eq_spec
551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588
    	                -- Dont box the eq_spec coercions since they are
    	                -- marked as HsUnpack by mk_dict_strict_mark

    mk_boxer :: [Boxer] -> DataConBoxer
    mk_boxer boxers = DCB (\ ty_args src_vars -> 
                      do { let ex_vars = takeList ex_tvs src_vars
                               subst1 = mkTopTvSubst (univ_tvs `zip` ty_args)
                               subst2 = extendTvSubstList subst1 ex_tvs 
                                                          (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
    mk_rep_app [] con_app 
      = return con_app
    mk_rep_app ((wrap_arg, unboxer) : prs) con_app 
      = 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
newLocal ty = do { uniq <- getUniqueUs 
                 ; return (mkSysLocal (fsLit "dt") uniq ty) }

-------------------------
dataConArgRep
   :: DynFlags 
589
   -> FamInstEnvs
590 591 592
   -> Type -> HsBang
   -> ( HsBang   -- Like input but with HsUnpackFailed if necy
      , [(Type, StrictnessMark)]   -- Rep types
593 594 595 596 597
      , (Unboxer, Boxer) )

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

598 599 600 601 602
dataConArgRep _ _ arg_ty (HsUserBang _ False)  -- No '!'
  = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))

dataConArgRep dflags fam_envs arg_ty 
    (HsUserBang unpk_prag True)  -- {-# UNPACK #-} !
603
  | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
604 605
          -- Don't unpack if we aren't optimising; rather arbitrarily, 
          -- we use -fomit-iface-pragmas as the indication
606
  , let mb_co   = topNormaliseType 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 613 614 615
  , case unpk_prag of
      Nothing -> gopt Opt_UnboxStrictFields dflags
              || (gopt Opt_UnboxSmallStrictFields dflags 
                   && 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

635
strict_but_not_unpacked :: Type -> (HsBang, [(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 648 649 650 651 652 653 654 655 656 657
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) }
    boxer = Boxer $ \ subst -> 
            do { (rep_ids, rep_expr) 
                    <- 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 677 678
  , Just con <- tyConSingleAlgDataCon_maybe tc
      -- NB: check for an *algebraic* data type
      -- A recursive newtype might mean that 
      -- 'arg_ty' is a newtype
679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699
  , 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
-- True if we can unpack the UNPACK fields of the constructor
-- without involving the NameSet tycons
700 701 702 703
-- 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!
704 705
isUnpackableType fam_envs ty
  | Just (tc, _) <- splitTyConApp_maybe ty
706
  , Just con <- tyConSingleAlgDataCon_maybe tc
707 708 709 710
  , isVanillaDataCon con
  = ok_con_args (unitNameSet (getName tc)) con
  | otherwise
  = False
711
  where
712
    ok_arg tcs (ty, bang) = not (attempt_unpack bang) || ok_ty tcs norm_ty
713 714 715 716 717 718 719 720
        where
          norm_ty = case topNormaliseType fam_envs ty of
                      Just (_, ty) -> ty
                      Nothing      -> ty
    ok_ty tcs ty
      | Just (tc, _) <- splitTyConApp_maybe ty
      , let tc_name = getName tc
      =  not (tc_name `elemNameSet` tcs)
721
      && case tyConSingleAlgDataCon_maybe tc of
722 723 724 725 726 727 728 729
            Just con | isVanillaDataCon con
                    -> ok_con_args (tcs `addOneToNameSet` getName tc) con
            _ -> True
      | otherwise 
      = True

    ok_con_args tcs con
       = all (ok_arg tcs) (dataConOrigArgTys con `zip` dataConStrictMarks con)
730 731
         -- NB: dataConStrictMarks gives the *user* request; 
         -- We'd get a black hole if we used dataConRepBangs
732

733 734 735
    attempt_unpack (HsUnpack {})              = True
    attempt_unpack (HsUserBang (Just unpk) _) = unpk
    attempt_unpack _                          = False
736 737
\end{code}

738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790
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
G which should have two Int#s.  

However 

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

Here we can represent T with an Int#.

Note [Recursive unboxing]
~~~~~~~~~~~~~~~~~~~~~~~~~
Be careful not to try to unbox this!
	data T = MkT {-# UNPACK #-} !T Int
Reason: consider
  data R = MkR {-# UNPACK #-} !S Int
  data S = MkS {-# UNPACK #-} !Int
The representation arguments of MkR are the *representation* arguments
of S (plus Int); the rep args of MkS are Int#.  This is obviously no
good for T, because then we'd get an infinite number of arguments.

But it's the *argument* type that matters. This is fine:
	data S = MkS S !Int
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!


\begin{code}
mk_pred_strict_mark :: PredType -> HsBang
mk_pred_strict_mark pred 
791
  | isEqPred pred = HsUnpack Nothing	-- Note [Unpack equality predicates]
792 793
  | otherwise     = HsNoBang
\end{code}
794

795
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
796 797 798
%*                                                                      *
        Wrapping and unwrapping newtypes and type families
%*                                                                      *
799 800 801
%************************************************************************

\begin{code}
802 803
wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
-- The wrapper for the data constructor for a newtype looks like this:
Ian Lynagh's avatar
Ian Lynagh committed
804 805 806
--      newtype T a = MkT (a,Int)
--      MkT :: forall a. (a,Int) -> T a
--      MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a)
807 808 809 810
-- 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
811
--      e `cast` (CoT [a])
812
--
813
-- If a coercion constructor is provided in the newtype, then we use
814
-- it, otherwise the wrap/unwrap are both no-ops 
815
--
816
-- 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
817 818 819
-- 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).
820

821
wrapNewTypeBody tycon args result_expr
822 823
  = ASSERT( isNewTyCon tycon )
    wrapFamInstBody tycon args $
824
    mkCast result_expr (mkSymCo co)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
825
  where
826
    co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args
827

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
828 829 830 831
-- 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).
832

833 834
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon args result_expr
835
  = ASSERT( isNewTyCon tycon )
836
    mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args)
837

838 839 840 841 842 843 844 845
-- 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
846
  = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args))
847 848
  | otherwise
  = body
849

850 851
-- Same as `wrapFamInstBody`, but for type family instances, which are
-- represented by a `CoAxiom`, and not a `TyCon`
852 853
wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr
wrapTypeFamInstBody axiom ind args body
854
  = mkCast body (mkSymCo (mkAxInstCo Representational axiom ind args))
855 856 857 858

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

860 861 862
unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapFamInstScrut tycon args scrut
  | Just co_con <- tyConFamilyCoercion_maybe tycon
863
  = mkCast scrut (mkUnbranchedAxInstCo Representational co_con args) -- data instances only
864 865
  | otherwise
  = scrut
866

867 868
unwrapTypeFamInstScrut :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr
unwrapTypeFamInstScrut axiom ind args scrut
869
  = mkCast scrut (mkAxInstCo Representational axiom ind args)
870 871 872 873

unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr
unwrapTypeUnbranchedFamInstScrut axiom
  = unwrapTypeFamInstScrut axiom 0
874 875 876 877
\end{code}


%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
878
%*                                                                      *
879
\subsection{Primitive operations}
Ian Lynagh's avatar
Ian Lynagh committed
880
%*                                                                      *
881 882 883
%************************************************************************

\begin{code}
884 885
mkPrimOpId :: PrimOp -> Id
mkPrimOpId prim_op 
886
  = id
887
  where
888
    (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op
889
    ty   = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
890
    name = mkWiredInName gHC_PRIM (primOpOcc prim_op) 
Ian Lynagh's avatar
Ian Lynagh committed
891 892
                         (mkPrimOpIdUnique (primOpTag prim_op))
                         (AnId id) UserSyntax
893
    id   = mkGlobalId (PrimOpId prim_op) name ty info
Ian Lynagh's avatar
Ian Lynagh committed
894
                
895
    info = noCafIdInfo
896 897 898 899
           `setSpecInfo`          mkSpecInfo (maybeToList $ primOpRules name prim_op)
           `setArityInfo`         arity
           `setStrictnessInfo`    strict_sig
           `setInlinePragInfo`    neverInlinePragma
900 901 902 903
               -- We give PrimOps a NOINLINE pragma so that we don't
               -- get silly warnings from Desugar.dsRule (the inline_shadows_rule 
               -- test) about a RULE conflicting with a possible inlining
               -- cf Trac #7287
904

905 906 907 908 909 910 911 912 913
-- For each ccall we manufacture a separate CCallOpId, giving it
-- a fresh unique, a type that is correct for this particular ccall,
-- and a CCall structure that gives the correct details about calling
-- convention etc.  
--
-- The *name* of this Id is a local name whose OccName gives the full
-- details of the ccall, type and all.  This means that the interface 
-- file reader can reconstruct a suitable Id

Ian Lynagh's avatar
Ian Lynagh committed
914 915
mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id
mkFCallId dflags uniq fcall ty
916
  = ASSERT( isEmptyVarSet (tyVarsOfType ty) )
Ian Lynagh's avatar
Ian Lynagh committed
917 918
    -- A CCallOpId should have no free type variables; 
    -- when doing substitutions won't substitute over it
919
    mkGlobalId (FCallId fcall) name ty info
920
  where
Ian Lynagh's avatar
Ian Lynagh committed
921
    occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty))
Ian Lynagh's avatar
Ian Lynagh committed
922 923
    -- The "occurrence name" of a ccall is the full info about the
    -- ccall; it is encoded, but may have embedded spaces etc!
924

925
    name = mkFCallName uniq occ_str
926

927
    info = noCafIdInfo
Ian Lynagh's avatar
Ian Lynagh committed
928
           `setArityInfo`         arity
929
           `setStrictnessInfo`    strict_sig
930

931 932 933 934
    (_, tau)        = tcSplitForAllTys ty
    (arg_tys, _)    = tcSplitFunTys tau
    arity           = length arg_tys
    strict_sig      = mkStrictSig (mkTopDmdType (replicate arity evalDmd) topRes)
935 936
\end{code}

937 938

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
939
%*                                                                      *
940
\subsection{DictFuns and default methods}
Ian Lynagh's avatar
Ian Lynagh committed
941
%*                                                                      *
942 943
%************************************************************************

944 945 946 947 948 949
Important notes about dict funs and default methods
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dict funs and default methods are *not* ImplicitIds.  Their definition
involves user-written code, so we can't figure out their strictness etc
based on fixed info, as we can for constructors and record selectors (say).

950 951 952
We build them as LocalIds, but with External Names.  This ensures that
they are taken to account by free-variable finding and dependency
analysis (e.g. CoreFVs.exprFreeVars).
953 954 955 956 957 958 959 960 961 962 963 964

Why shouldn't they be bound as GlobalIds?  Because, in particular, if
they are globals, the specialiser floats dict uses above their defns,
which prevents good simplifications happening.  Also the strictness
analyser treats a occurrence of a GlobalId as imported and assumes it
contains strictness in its IdInfo, which isn't true if the thing is
bound in the same module as the occurrence.

It's OK for dfuns to be LocalIds, because we form the instance-env to
pass on to the next module (md_insts) in CoreTidy, afer tidying
and globalising the top-level Ids.

965
BUT make sure they are *exported* LocalIds (mkExportedLocalId) so 
966 967
that they aren't discarded by the occurrence analyser.

968
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
969 970 971 972 973 974
mkDictFunId :: Name      -- Name to use for the dict fun;
            -> [TyVar]
            -> ThetaType
            -> Class 
            -> [Type]
            -> Id
975
-- Implements the DFun Superclass Invariant (see TcInstDcls)
976

977
mkDictFunId dfun_name tvs theta clas tys
978
  = mkExportedLocalVar (DFunId n_silent is_nt)
979 980 981
                       dfun_name
                       dfun_ty
                       vanillaIdInfo
982
  where
983
    is_nt = isNewTyCon (classTyCon clas)
984
    (n_silent, dfun_ty) = mkDictFunTy tvs theta clas tys
985

986
mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> (Int, Type)
987
mkDictFunTy tvs theta clas tys
988 989 990 991 992 993 994 995 996 997 998 999 1000
  = (length silent_theta, dfun_ty)
  where
    dfun_ty = mkSigmaTy tvs (silent_theta ++ theta) (mkClassPred clas tys)
    silent_theta 
      | null tvs, null theta 
      = []
      | otherwise
      = filterOut discard $
        substTheta (zipTopTvSubst (classTyVars clas) tys)
                   (classSCTheta clas)
                   -- See Note [Silent Superclass Arguments]
    discard pred = any (`eqPred` pred) theta
                 -- See the DFun Superclass Invariant in TcInstDcls
1001
\end{code}
1002 1003 1004


%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
1005
%*                                                                      *
1006
\subsection{Un-definable}
Ian Lynagh's avatar
Ian Lynagh committed
1007
%*                                                                      *
1008 1009
%************************************************************************

1010 1011 1012 1013 1014 1015
These Ids can't be defined in Haskell.  They could be defined in
unfoldings in the wired-in GHC.Prim interface file, but we'd have to
ensure that they were definitely, definitely inlined, because there is
no curried identifier for them.  That's what mkCompulsoryUnfolding
does.  If we had a way to get a compulsory unfolding from an interface
file, we could do that, but we don't right now.
1016 1017 1018 1019 1020 1021 1022 1023 1024

unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
just gets expanded into a type coercion wherever it occurs.  Hence we
add it as a built-in Id with an unfolding here.

The type variables we use here are "open" type variables: this means
they can unify with both unlifted and lifted types.  Hence we provide
another gun with which to shoot yourself in the foot.

1025
\begin{code}
1026
lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName, coercionTokenName, magicSingIName :: Name
1027 1028 1029 1030
unsafeCoerceName  = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey  unsafeCoerceId
nullAddrName      = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#")     nullAddrIdKey      nullAddrId
seqName           = mkWiredInIdName gHC_PRIM (fsLit "seq")           seqIdKey           seqId
realWorldName     = mkWiredInIdName gHC_PRIM (fsLit "realWorld#")    realWorldPrimIdKey realWorldPrimId
1031
lazyIdName        = mkWiredInIdName gHC_MAGIC (fsLit "lazy")         lazyIdKey           lazyId
1032
coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId
1033
magicSingIName    = mkWiredInIdName gHC_PRIM (fsLit "magicSingI")    magicSingIKey magicSingIId
1034 1035
\end{code}

1036
\begin{code}
1037
------------------------------------------------
1038
-- unsafeCoerce# :: forall a b. a -> b
1039
unsafeCoerceId :: Id
1040
unsafeCoerceId
1041
  = pcMiscPrelId unsafeCoerceName ty info
1042
  where
1043 1044
    info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
                       `setUnfoldingInfo`  mkCompulsoryUnfolding rhs
Ian Lynagh's avatar
Ian Lynagh committed
1045
           
1046