compiler/basicTypes/MkId.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The AQUA Project, Glasgow University, 1998
   4 %
   5
   6 This module contains definitions for the IdInfo for things that
   7 have a standard form, namely:
   8
   9         * data constructors
  10         * record selectors
  11         * method and superclass selectors
  12         * primitive operations
  13
  14 \begin{code}
  15 module MkId (
  16         mkDictFunId, mkDefaultMethodId,
  17         mkDictSelId,
  18
  19         mkDataConIds,
  20         mkRecordSelId,
  21         mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
  22
  23         mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
  24         wrapFamInstBody, unwrapFamInstScrut,
  25         mkUnpackCase, mkProductBox,
  26
  27         -- And some particular Ids; see below for why they are wired in
  28         wiredInIds, ghcPrimIds,
  29         unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId,
  30         lazyId, lazyIdUnfolding, lazyIdKey,
  31
  32         mkRuntimeErrorApp,
  33         rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
  34         nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
  35         pAT_ERROR_ID, eRROR_ID,
  36
  37         unsafeCoerceName
  38     ) where
  39
  40 #include "HsVersions.h"
  41
  42 import Rules
  43 import TysPrim
  44 import TysWiredIn
  45 import PrelRules
  46 import Type
  47 import TypeRep
  48 import TcGadt
  49 import Coercion
  50 import TcType
  51 import CoreUtils
  52 import CoreUnfold
  53 import Literal
  54 import TyCon
  55 import Class
  56 import VarSet
  57 import Name
  58 import OccName
  59 import PrimOp
  60 import ForeignCall
  61 import DataCon
  62 import Id
  63 import Var              ( Var, TyVar, mkCoVar)
  64 import IdInfo
  65 import NewDemand
  66 import DmdAnal
  67 import CoreSyn
  68 import Unique
  69 import Maybes
  70 import PrelNames
  71 import BasicTypes       hiding ( SuccessFlag(..) )
  72 import Util
  73 import Outputable
  74 import FastString
  75 import ListSetOps
  76 import Module
  77 \end{code}
  78
  79 %************************************************************************
  80 %*                                                                      *
  81 \subsection{Wired in Ids}
  82 %*                                                                      *
  83 %************************************************************************
  84
  85 \begin{code}
  86 wiredInIds
  87   = [   -- These error-y things are wired in because we don't yet have
  88         -- a way to express in an interface file that the result type variable
  89         -- is 'open'; that is can be unified with an unboxed type
  90         --
  91         -- [The interface file format now carry such information, but there's
  92         -- no way yet of expressing at the definition site for these
  93         -- error-reporting functions that they have an 'open'
  94         -- result type. -- sof 1/99]
  95
  96     eRROR_ID,   -- This one isn't used anywhere else in the compiler
  97                 -- But we still need it in wiredInIds so that when GHC
  98                 -- compiles a program that mentions 'error' we don't
  99                 -- import its type from the interface file; we just get
 100                 -- the Id defined here.  Which has an 'open-tyvar' type.
 101
 102     rUNTIME_ERROR_ID,
 103     iRREFUT_PAT_ERROR_ID,
 104     nON_EXHAUSTIVE_GUARDS_ERROR_ID,
 105     nO_METHOD_BINDING_ERROR_ID,
 106     pAT_ERROR_ID,
 107     rEC_CON_ERROR_ID,
 108
 109     lazyId
 110     ] ++ ghcPrimIds
 111
 112 -- These Ids are exported from GHC.Prim
 113 ghcPrimIds
 114   = [   -- These can't be defined in Haskell, but they have
 115         -- perfectly reasonable unfoldings in Core
 116     realWorldPrimId,
 117     unsafeCoerceId,
 118     nullAddrId,
 119     seqId
 120     ]
 121 \end{code}
 122
 123 %************************************************************************
 124 %*                                                                      *
 125 \subsection{Data constructors}
 126 %*                                                                      *
 127 %************************************************************************
 128
 129 The wrapper for a constructor is an ordinary top-level binding that evaluates
 130 any strict args, unboxes any args that are going to be flattened, and calls
 131 the worker.
 132
 133 We're going to build a constructor that looks like:
 134
 135         data (Data a, C b) =>  T a b = T1 !a !Int b
 136
 137         T1 = /\ a b ->
 138              \d1::Data a, d2::C b ->
 139              \p q r -> case p of { p ->
 140                        case q of { q ->
 141                        Con T1 [a,b] [p,q,r]}}
 142
 143 Notice that
 144
 145 * d2 is thrown away --- a context in a data decl is used to make sure
 146   one *could* construct dictionaries at the site the constructor
 147   is used, but the dictionary isn't actually used.
 148
 149 * We have to check that we can construct Data dictionaries for
 150   the types a and Int.  Once we've done that we can throw d1 away too.
 151
 152 * We use (case p of q -> ...) to evaluate p, rather than "seq" because
 153   all that matters is that the arguments are evaluated.  "seq" is
 154   very careful to preserve evaluation order, which we don't need
 155   to be here.
 156
 157   You might think that we could simply give constructors some strictness
 158   info, like PrimOps, and let CoreToStg do the let-to-case transformation.
 159   But we don't do that because in the case of primops and functions strictness
 160   is a *property* not a *requirement*.  In the case of constructors we need to
 161   do something active to evaluate the argument.
 162
 163   Making an explicit case expression allows the simplifier to eliminate
 164   it in the (common) case where the constructor arg is already evaluated.
 165
 166 Note [Wrappers for data instance tycons]
 167 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 168 In the case of data instances, the wrapper also applies the coercion turning
 169 the representation type into the family instance type to cast the result of
 170 the wrapper.  For example, consider the declarations
 171
 172   data family Map k :: * -> *
 173   data instance Map (a, b) v = MapPair (Map a (Pair b v))
 174
 175 The tycon to which the datacon MapPair belongs gets a unique internal
 176 name of the form :R123Map, and we call it the representation tycon.
 177 In contrast, Map is the family tycon (accessible via
 178 tyConFamInst_maybe). A coercion allows you to move between
 179 representation and family type.  It is accessible from :R123Map via
 180 tyConFamilyCoercion_maybe and has kind
 181
 182   Co123Map a b v :: {Map (a, b) v :=: :R123Map a b v}
 183
 184 The wrapper and worker of MapPair get the types
 185
 186         -- Wrapper
 187   $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v
 188   $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v)
 189
 190         -- Worker
 191   MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v
 192
 193 This coercion is conditionally applied by wrapFamInstBody.
 194
 195 It's a bit more complicated if the data instance is a GADT as well!
 196
 197    data instance T [a] where
 198         T1 :: forall b. b -> T [Maybe b]
 199 Hence
 200    Co7T a :: T [a] ~ :R7T a
 201
 202 Now we want
 203
 204         -- Wrapper
 205   $WT1 :: forall b. b -> T [Maybe b]
 206   $WT1 b v = T1 (Maybe b) b (Maybe b) v
 207                         `cast` sym (Co7T (Maybe b))
 208
 209         -- Worker
 210   T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c
 211
 212 \begin{code}
 213 mkDataConIds :: Name -> Name -> DataCon -> DataConIds
 214 mkDataConIds wrap_name wkr_name data_con
 215   | isNewTyCon tycon                    -- Newtype, only has a worker
 216   = DCIds Nothing nt_work_id
 217
 218   | any isMarkedStrict all_strict_marks      -- Algebraic, needs wrapper
 219     || not (null eq_spec)                    -- NB: LoadIface.ifaceDeclSubBndrs
 220     || isFamInstTyCon tycon                  --     depends on this test
 221   = DCIds (Just alg_wrap_id) wrk_id
 222
 223   | otherwise                                -- Algebraic, no wrapper
 224   = DCIds Nothing wrk_id
 225   where
 226     (univ_tvs, ex_tvs, eq_spec,
 227      eq_theta, dict_theta, orig_arg_tys, res_ty) = dataConFullSig data_con
 228     tycon = dataConTyCon data_con       -- The representation TyCon (not family)
 229
 230         ----------- Worker (algebraic data types only) --------------
 231         -- The *worker* for the data constructor is the function that
 232         -- takes the representation arguments and builds the constructor.
 233     wrk_id = mkGlobalId (DataConWorkId data_con) wkr_name
 234                         (dataConRepType data_con) wkr_info
 235
 236     wkr_arity = dataConRepArity data_con
 237     wkr_info  = noCafIdInfo
 238                 `setArityInfo`          wkr_arity
 239                 `setAllStrictnessInfo`  Just wkr_sig
 240                 `setUnfoldingInfo`      evaldUnfolding  -- Record that it's evaluated,
 241                                                         -- even if arity = 0
 242
 243     wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
 244         --      Note [Data-con worker strictness]
 245         -- Notice that we do *not* say the worker is strict
 246         -- even if the data constructor is declared strict
 247         --      e.g.    data T = MkT !(Int,Int)
 248         -- Why?  Because the *wrapper* is strict (and its unfolding has case
 249         -- expresssions that do the evals) but the *worker* itself is not.
 250         -- If we pretend it is strict then when we see
 251         --      case x of y -> $wMkT y
 252         -- the simplifier thinks that y is "sure to be evaluated" (because
 253         --  $wMkT is strict) and drops the case.  No, $wMkT is not strict.
 254         --
 255         -- When the simplifer sees a pattern
 256         --      case e of MkT x -> ...
 257         -- it uses the dataConRepStrictness of MkT to mark x as evaluated;
 258         -- but that's fine... dataConRepStrictness comes from the data con
 259         -- not from the worker Id.
 260
 261     cpr_info | isProductTyCon tycon &&
 262                isDataTyCon tycon    &&
 263                wkr_arity > 0        &&
 264                wkr_arity <= mAX_CPR_SIZE        = retCPR
 265              | otherwise                        = TopRes
 266         -- RetCPR is only true for products that are real data types;
 267         -- that is, not unboxed tuples or [non-recursive] newtypes
 268
 269         ----------- Workers for newtypes --------------
 270     nt_work_id   = mkGlobalId (DataConWrapId data_con) wkr_name wrap_ty nt_work_info
 271     nt_work_info = noCafIdInfo          -- The NoCaf-ness is set by noCafIdInfo
 272                   `setArityInfo` 1      -- Arity 1
 273                   `setUnfoldingInfo`     newtype_unf
 274     newtype_unf  = -- The assertion below is no longer correct:
 275                    --   there may be a dict theta rather than a singleton orig_arg_ty
 276                    -- ASSERT( isVanillaDataCon data_con &&
 277                    --      isSingleton orig_arg_tys )
 278                    --
 279                    -- No existentials on a newtype, but it can have a context
 280                    -- e.g.      newtype Eq a => T a = MkT (...)
 281                    mkCompulsoryUnfolding $
 282                    mkLams wrap_tvs $ Lam id_arg1 $
 283                    wrapNewTypeBody tycon res_ty_args
 284                        (Var id_arg1)
 285
 286     id_arg1 = mkTemplateLocal 1
 287                 (if null orig_arg_tys
 288                     then ASSERT(not (null $ dataConDictTheta data_con)) mkPredTy $ head (dataConDictTheta data_con)
 289                     else head orig_arg_tys
 290                 )
 291
 292         ----------- Wrapper --------------
 293         -- We used to include the stupid theta in the wrapper's args
 294         -- but now we don't.  Instead the type checker just injects these
 295         -- extra constraints where necessary.
 296     wrap_tvs    = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
 297     res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs
 298     eq_tys   = mkPredTys eq_theta
 299     dict_tys = mkPredTys dict_theta
 300     wrap_ty  = mkForAllTys wrap_tvs $ mkFunTys eq_tys $ mkFunTys dict_tys $
 301                mkFunTys orig_arg_tys $ res_ty
 302         -- NB: watch out here if you allow user-written equality
 303         --     constraints in data constructor signatures
 304
 305         ----------- Wrappers for algebraic data types --------------
 306     alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info
 307     alg_wrap_info = noCafIdInfo         -- The NoCaf-ness is set by noCafIdInfo
 308                     `setArityInfo`         wrap_arity
 309                         -- It's important to specify the arity, so that partial
 310                         -- applications are treated as values
 311                     `setUnfoldingInfo`     wrap_unf
 312                     `setAllStrictnessInfo` Just wrap_sig
 313
 314     all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con
 315     wrap_sig = mkStrictSig (mkTopDmdType arg_dmds cpr_info)
 316     arg_dmds = map mk_dmd all_strict_marks
 317     mk_dmd str | isMarkedStrict str = evalDmd
 318                | otherwise          = lazyDmd
 319         -- The Cpr info can be important inside INLINE rhss, where the
 320         -- wrapper constructor isn't inlined.
 321         -- And the argument strictness can be important too; we
 322         -- may not inline a contructor when it is partially applied.
 323         -- For example:
 324         --      data W = C !Int !Int !Int
 325         --      ...(let w = C x in ...(w p q)...)...
 326         -- we want to see that w is strict in its two arguments
 327
 328     wrap_unf = mkTopUnfolding $ Note InlineMe $
 329               mkLams wrap_tvs $
 330               mkLams eq_args $
 331               mkLams dict_args $ mkLams id_args $
 332               foldr mk_case con_app
 333                     (zip (dict_args ++ id_args) all_strict_marks)
 334                     i3 []
 335
 336     con_app _ rep_ids = wrapFamInstBody tycon res_ty_args $
 337                           Var wrk_id `mkTyApps`  res_ty_args
 338                                      `mkVarApps` ex_tvs
 339                                      `mkTyApps`  map snd eq_spec        -- Equality evidence
 340                                      `mkVarApps` eq_args
 341                                      `mkVarApps` reverse rep_ids
 342
 343     (dict_args,i2) = mkLocals 1  dict_tys
 344     (id_args,i3)   = mkLocals i2 orig_arg_tys
 345     wrap_arity     = i3-1
 346     (eq_args,_)    = mkCoVarLocals i3 eq_tys
 347
 348     mkCoVarLocals i []     = ([],i)
 349     mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs
 350                                  y      = mkCoVar (mkSysTvName (mkBuiltinUnique i) FSLIT("dc_co")) x
 351                              in (y:ys,j)
 352
 353     mk_case
 354            :: (Id, StrictnessMark)      -- Arg, strictness
 355            -> (Int -> [Id] -> CoreExpr) -- Body
 356            -> Int                       -- Next rep arg id
 357            -> [Id]                      -- Rep args so far, reversed
 358            -> CoreExpr
 359     mk_case (arg,strict) body i rep_args
 360           = case strict of
 361                 NotMarkedStrict -> body i (arg:rep_args)
 362                 MarkedStrict
 363                    | isUnLiftedType (idType arg) -> body i (arg:rep_args)
 364                    | otherwise ->
 365                         Case (Var arg) arg res_ty [(DEFAULT,[], body i (arg:rep_args))]
 366
 367                 MarkedUnboxed
 368                    -> unboxProduct i (Var arg) (idType arg) the_body
 369                       where
 370                         the_body i con_args = body i (reverse con_args ++ rep_args)
 371
 372 mAX_CPR_SIZE :: Arity
 373 mAX_CPR_SIZE = 10
 374 -- We do not treat very big tuples as CPR-ish:
 375 --      a) for a start we get into trouble because there aren't
 376 --         "enough" unboxed tuple types (a tiresome restriction,
 377 --         but hard to fix),
 378 --      b) more importantly, big unboxed tuples get returned mainly
 379 --         on the stack, and are often then allocated in the heap
 380 --         by the caller.  So doing CPR for them may in fact make
 381 --         things worse.
 382
 383 mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
 384                where
 385                  n = length tys
 386 \end{code}
 387
 388
 389 %************************************************************************
 390 %*                                                                      *
 391 \subsection{Record selectors}
 392 %*                                                                      *
 393 %************************************************************************
 394
 395 We're going to build a record selector unfolding that looks like this:
 396
 397         data T a b c = T1 { ..., op :: a, ...}
 398                      | T2 { ..., op :: a, ...}
 399                      | T3
 400
 401         sel = /\ a b c -> \ d -> case d of
 402                                     T1 ... x ... -> x
 403                                     T2 ... x ... -> x
 404                                     other        -> error "..."
 405
 406 Similarly for newtypes
 407
 408         newtype N a = MkN { unN :: a->a }
 409
 410         unN :: N a -> a -> a
 411         unN n = coerce (a->a) n
 412
 413 We need to take a little care if the field has a polymorphic type:
 414
 415         data R = R { f :: forall a. a->a }
 416
 417 Then we want
 418
 419         f :: forall a. R -> a -> a
 420         f = /\ a \ r = case r of
 421                           R f -> f a
 422
 423 (not f :: R -> forall a. a->a, which gives the type inference mechanism
 424 problems at call sites)
 425
 426 Similarly for (recursive) newtypes
 427
 428         newtype N = MkN { unN :: forall a. a->a }
 429
 430         unN :: forall b. N -> b -> b
 431         unN = /\b -> \n:N -> (coerce (forall a. a->a) n)
 432
 433
 434 Note [Naughty record selectors]
 435 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 436 A "naughty" field is one for which we can't define a record
 437 selector, because an existential type variable would escape.  For example:
 438         data T = forall a. MkT { x,y::a }
 439 We obviously can't define
 440         x (MkT v _) = v
 441 Nevertheless we *do* put a RecordSelId into the type environment
 442 so that if the user tries to use 'x' as a selector we can bleat
 443 helpfully, rather than saying unhelpfully that 'x' is not in scope.
 444 Hence the sel_naughty flag, to identify record selectors that don't really exist.
 445
 446 In general, a field is naughty if its type mentions a type variable that
 447 isn't in the result type of the constructor.
 448
 449 Note [GADT record selectors]
 450 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 451 For GADTs, we require that all constructors with a common field 'f' have the same
 452 result type (modulo alpha conversion).  [Checked in TcTyClsDecls.checkValidTyCon]
 453 E.g.
 454         data T where
 455           T1 { f :: a } :: T [a]
 456           T2 { f :: a, y :: b  } :: T [a]
 457 and now the selector takes that type as its argument:
 458         f :: forall a. T [a] -> a
 459         f t = case t of
 460                 T1 { f = v } -> v
 461                 T2 { f = v } -> v
 462 Note the forall'd tyvars of the selector are just the free tyvars
 463 of the result type; there may be other tyvars in the constructor's
 464 type (e.g. 'b' in T2).
 465
 466 Note [Selector running example]
 467 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 468 It's OK to combine GADTs and type families.  Here's a running example:
 469
 470         data instance T [a] where
 471           T1 { fld :: b } :: T [Maybe b]
 472
 473 The representation type looks like this
 474         data :R7T a where
 475           T1 { fld :: b } :: :R7T (Maybe b)
 476
 477 and there's coercion from the family type to the representation type
 478         :CoR7T a :: T [a] ~ :R7T a
 479
 480 The selector we want for fld looks like this:
 481
 482         fld :: forall b. T [Maybe b] -> b
 483         fld = /\b. \(d::T [Maybe b]).
 484               case d `cast` :CoR7T (Maybe b) of
 485                 T1 (x::b) -> x
 486
 487 The scrutinee of the case has type :R7T (Maybe b), which can be
 488 gotten by appying the eq_spec to the univ_tvs of the data con.
 489
 490 \begin{code}
 491 mkRecordSelId :: TyCon -> FieldLabel -> Id
 492 mkRecordSelId tycon field_label
 493         -- Assumes that all fields with the same field label have the same type
 494   | is_naughty = naughty_id
 495   | otherwise  = sel_id
 496   where
 497     is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tv_set)
 498     sel_id_details = RecordSelId { sel_tycon = tycon, sel_label = field_label, sel_naughty = is_naughty }
 499         -- For a data type family, the tycon is the *instance* TyCon
 500
 501     -- Escapist case here for naughty constructors
 502     -- We give it no IdInfo, and a type of forall a.a (never looked at)
 503     naughty_id = mkGlobalId sel_id_details field_label forall_a_a noCafIdInfo
 504     forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
 505
 506     -- Normal case starts here
 507     sel_id = mkGlobalId sel_id_details field_label selector_ty info
 508     data_cons         = tyConDataCons tycon
 509     data_cons_w_field = filter has_field data_cons      -- Can't be empty!
 510     has_field con     = field_label `elem` dataConFieldLabels con
 511
 512     con1        = ASSERT( not (null data_cons_w_field) ) head data_cons_w_field
 513     (univ_tvs, _, eq_spec, _, _, _, data_ty) = dataConFullSig con1
 514         -- For a data type family, the data_ty (and hence selector_ty) mentions
 515         -- only the family TyCon, not the instance TyCon
 516     data_tv_set = tyVarsOfType data_ty
 517     data_tvs    = varSetElems data_tv_set
 518     field_ty    = dataConFieldType con1 field_label
 519
 520         -- *Very* tiresomely, the selectors are (unnecessarily!) overloaded over
 521         -- just the dictionaries in the types of the constructors that contain
 522         -- the relevant field.  [The Report says that pattern matching on a
 523         -- constructor gives the same constraints as applying it.]  Urgh.
 524         --
 525         -- However, not all data cons have all constraints (because of
 526         -- BuildTyCl.mkDataConStupidTheta).  So we need to find all the data cons
 527         -- involved in the pattern match and take the union of their constraints.
 528     stupid_dict_tys = mkPredTys (dataConsStupidTheta data_cons_w_field)
 529     n_stupid_dicts  = length stupid_dict_tys
 530
 531     (field_tyvars,pre_field_theta,field_tau) = tcSplitSigmaTy field_ty
 532     field_theta       = filter (not . isEqPred) pre_field_theta
 533     field_dict_tys    = mkPredTys field_theta
 534     n_field_dict_tys  = length field_dict_tys
 535         -- If the field has a universally quantified type we have to
 536         -- be a bit careful.  Suppose we have
 537         --      data R = R { op :: forall a. Foo a => a -> a }
 538         -- Then we can't give op the type
 539         --      op :: R -> forall a. Foo a => a -> a
 540         -- because the typechecker doesn't understand foralls to the
 541         -- right of an arrow.  The "right" type to give it is
 542         --      op :: forall a. Foo a => R -> a -> a
 543         -- But then we must generate the right unfolding too:
 544         --      op = /\a -> \dfoo -> \ r ->
 545         --           case r of
 546         --              R op -> op a dfoo
 547         -- Note that this is exactly the type we'd infer from a user defn
 548         --      op (R op) = op
 549
 550     selector_ty :: Type
 551     selector_ty  = mkForAllTys data_tvs $ mkForAllTys field_tyvars $
 552                    mkFunTys stupid_dict_tys  $  mkFunTys field_dict_tys $
 553                    mkFunTy data_ty field_tau
 554
 555     arity = 1 + n_stupid_dicts + n_field_dict_tys
 556
 557     (strict_sig, rhs_w_str) = dmdAnalTopRhs sel_rhs
 558         -- Use the demand analyser to work out strictness.
 559         -- With all this unpackery it's not easy!
 560
 561     info = noCafIdInfo
 562            `setCafInfo`           caf_info
 563            `setArityInfo`         arity
 564            `setUnfoldingInfo`     mkTopUnfolding rhs_w_str
 565            `setAllStrictnessInfo` Just strict_sig
 566
 567         -- Allocate Ids.  We do it a funny way round because field_dict_tys is
 568         -- almost always empty.  Also note that we use max_dict_tys
 569         -- rather than n_dict_tys, because the latter gives an infinite loop:
 570         -- n_dict tys depends on the_alts, which depens on arg_ids, which depends
 571         -- on arity, which depends on n_dict tys.  Sigh!  Mega sigh!
 572     stupid_dict_ids  = mkTemplateLocalsNum 1 stupid_dict_tys
 573     max_stupid_dicts = length (tyConStupidTheta tycon)
 574     field_dict_base  = max_stupid_dicts + 1
 575     field_dict_ids   = mkTemplateLocalsNum field_dict_base field_dict_tys
 576     dict_id_base     = field_dict_base + n_field_dict_tys
 577     data_id          = mkTemplateLocal dict_id_base data_ty
 578     scrut_id         = mkTemplateLocal (dict_id_base+1) scrut_ty
 579     arg_base         = dict_id_base + 2
 580
 581     the_alts :: [CoreAlt]
 582     the_alts   = map mk_alt data_cons_w_field   -- Already sorted by data-con
 583     no_default = length data_cons == length data_cons_w_field   -- No default needed
 584
 585     default_alt | no_default = []
 586                 | otherwise  = [(DEFAULT, [], error_expr)]
 587
 588         -- The default branch may have CAF refs, because it calls recSelError etc.
 589     caf_info    | no_default = NoCafRefs
 590                 | otherwise  = MayHaveCafRefs
 591
 592     sel_rhs = mkLams data_tvs $ mkLams field_tyvars $
 593               mkLams stupid_dict_ids $ mkLams field_dict_ids $
 594               Lam data_id $ mk_result sel_body
 595
 596     scrut_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs
 597     scrut_ty      = mkTyConApp tycon scrut_ty_args
 598     scrut = unwrapFamInstScrut tycon scrut_ty_args (Var data_id)
 599         -- First coerce from the type family to the representation type
 600
 601         -- NB: A newtype always has a vanilla DataCon; no existentials etc
 602         --     data_tys will simply be the dataConUnivTyVars
 603     sel_body | isNewTyCon tycon = unwrapNewTypeBody tycon scrut_ty_args scrut
 604              | otherwise        = Case scrut scrut_id field_ty (default_alt ++ the_alts)
 605
 606     mk_result poly_result = mkVarApps (mkVarApps poly_result field_tyvars) field_dict_ids
 607         -- We pull the field lambdas to the top, so we need to
 608         -- apply them in the body.  For example:
 609         --      data T = MkT { foo :: forall a. a->a }
 610         --
 611         --      foo :: forall a. T -> a -> a
 612         --      foo = /\a. \t:T. case t of { MkT f -> f a }
 613
 614     mk_alt data_con
 615       =   ASSERT2( data_ty `tcEqType` field_ty, ppr data_con $$ ppr data_ty $$ ppr field_ty )
 616           mkReboxingAlt rebox_uniqs data_con (ex_tvs ++ co_tvs ++ arg_vs) rhs
 617       where
 618            -- get pattern binders with types appropriately instantiated
 619         arg_uniqs = map mkBuiltinUnique [arg_base..]
 620         (ex_tvs, co_tvs, arg_vs) = dataConOrigInstPat arg_uniqs data_con scrut_ty_args
 621
 622         rebox_base  = arg_base + length ex_tvs + length co_tvs + length arg_vs
 623         rebox_uniqs = map mkBuiltinUnique [rebox_base..]
 624
 625         -- data T :: *->* where T1 { fld :: Maybe b } -> T [b]
 626         --      Hence T1 :: forall a b. (a=[b]) => b -> T a
 627         -- fld :: forall b. T [b] -> Maybe b
 628         -- fld = /\b.\(t:T[b]). case t of
 629         --              T1 b' (c : [b]=[b']) (x:Maybe b')
 630         --                      -> x `cast` Maybe (sym (right c))
 631
 632
 633                 -- Generate the refinement for b'=b,
 634                 -- and apply to (Maybe b'), to get (Maybe b)
 635         Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
 636         the_arg_id_ty = idType the_arg_id
 637         (rhs, data_ty) = case refineType refinement the_arg_id_ty of
 638                           Just (co, data_ty) -> (Cast (Var the_arg_id) co, data_ty)
 639                           Nothing            -> (Var the_arg_id, the_arg_id_ty)
 640
 641         field_vs    = filter (not . isPredTy . idType) arg_vs
 642         the_arg_id  = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` field_vs) field_label
 643         field_lbls  = dataConFieldLabels data_con
 644
 645     error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_ty full_msg
 646     full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id])
 647
 648 -- unbox a product type...
 649 -- we will recurse into newtypes, casting along the way, and unbox at the
 650 -- first product data constructor we find. e.g.
 651 --
 652 --   data PairInt = PairInt Int Int
 653 --   newtype S = MkS PairInt
 654 --   newtype T = MkT S
 655 --
 656 -- If we have e = MkT (MkS (PairInt 0 1)) and some body expecting a list of
 657 -- ids, we get (modulo int passing)
 658 --
 659 --   case (e `cast` CoT) `cast` CoS of
 660 --     PairInt a b -> body [a,b]
 661 --
 662 -- The Ints passed around are just for creating fresh locals
 663 unboxProduct :: Int -> CoreExpr -> Type -> (Int -> [Id] -> CoreExpr) -> CoreExpr
 664 unboxProduct i arg arg_ty body
 665   = result
 666   where
 667     result = mkUnpackCase the_id arg con_args boxing_con rhs
 668     (_tycon, _tycon_args, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty
 669     ([the_id], i') = mkLocals i [arg_ty]
 670     (con_args, i'') = mkLocals i' tys
 671     rhs = body i'' con_args
 672
 673 mkUnpackCase ::  Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr
 674 -- (mkUnpackCase x e args Con body)
 675 --      returns
 676 -- case (e `cast` ...) of bndr { Con args -> body }
 677 --
 678 -- the type of the bndr passed in is irrelevent
 679 mkUnpackCase bndr arg unpk_args boxing_con body
 680   = Case cast_arg (setIdType bndr bndr_ty) (exprType body) [(DataAlt boxing_con, unpk_args, body)]
 681   where
 682   (cast_arg, bndr_ty) = go (idType bndr) arg
 683   go ty arg
 684     | (tycon, tycon_args, _, _)  <- splitProductType "mkUnpackCase" ty
 685     , isNewTyCon tycon && not (isRecursiveTyCon tycon)
 686     = go (newTyConInstRhs tycon tycon_args)
 687          (unwrapNewTypeBody tycon tycon_args arg)
 688     | otherwise = (arg, ty)
 689
 690 -- ...and the dual
 691 reboxProduct :: [Unique]     -- uniques to create new local binders
 692              -> Type         -- type of product to box
 693              -> ([Unique],   -- remaining uniques
 694                  CoreExpr,   -- boxed product
 695                  [Id])       -- Ids being boxed into product
 696 reboxProduct us ty
 697   = let
 698         (_tycon, _tycon_args, _pack_con, con_arg_tys) = deepSplitProductType "reboxProduct" ty
 699
 700         us' = dropList con_arg_tys us
 701
 702         arg_ids  = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
 703
 704         bind_rhs = mkProductBox arg_ids ty
 705
 706     in
 707       (us', bind_rhs, arg_ids)
 708
 709 mkProductBox :: [Id] -> Type -> CoreExpr
 710 mkProductBox arg_ids ty
 711   = result_expr
 712   where
 713     (tycon, tycon_args, pack_con, _con_arg_tys) = splitProductType "mkProductBox" ty
 714
 715     result_expr
 716       | isNewTyCon tycon && not (isRecursiveTyCon tycon)
 717       = wrap (mkProductBox arg_ids (newTyConInstRhs tycon tycon_args))
 718       | otherwise = mkConApp pack_con (map Type tycon_args ++ map Var arg_ids)
 719
 720     wrap expr = wrapNewTypeBody tycon tycon_args expr
 721
 722
 723 -- (mkReboxingAlt us con xs rhs) basically constructs the case
 724 -- alternative  (con, xs, rhs)
 725 -- but it does the reboxing necessary to construct the *source*
 726 -- arguments, xs, from the representation arguments ys.
 727 -- For example:
 728 --      data T = MkT !(Int,Int) Bool
 729 --
 730 -- mkReboxingAlt MkT [x,b] r
 731 --      = (DataAlt MkT, [y::Int,z::Int,b], let x = (y,z) in r)
 732 --
 733 -- mkDataAlt should really be in DataCon, but it can't because
 734 -- it manipulates CoreSyn.
 735
 736 mkReboxingAlt
 737   :: [Unique]           -- Uniques for the new Ids
 738   -> DataCon
 739   -> [Var]              -- Source-level args, including existential dicts
 740   -> CoreExpr           -- RHS
 741   -> CoreAlt
 742
 743 mkReboxingAlt us con args rhs
 744   | not (any isMarkedUnboxed stricts)
 745   = (DataAlt con, args, rhs)
 746
 747   | otherwise
 748   = let
 749         (binds, args') = go args stricts us
 750     in
 751     (DataAlt con, args', mkLets binds rhs)
 752
 753   where
 754     stricts = dataConExStricts con ++ dataConStrictMarks con
 755
 756     go [] _stricts _us = ([], [])
 757
 758         -- Type variable case
 759     go (arg:args) stricts us
 760       | isTyVar arg
 761       = let (binds, args') = go args stricts us
 762         in  (binds, arg:args')
 763
 764         -- Term variable case
 765     go (arg:args) (str:stricts) us
 766       | isMarkedUnboxed str
 767       =
 768         let (binds, unpacked_args')        = go args stricts us'
 769             (us', bind_rhs, unpacked_args) = reboxProduct us (idType arg)
 770         in
 771             (NonRec arg bind_rhs : binds, unpacked_args ++ unpacked_args')
 772       | otherwise
 773       = let (binds, args') = go args stricts us
 774         in  (binds, arg:args')
 775 \end{code}
 776
 777
 778 %************************************************************************
 779 %*                                                                      *
 780 \subsection{Dictionary selectors}
 781 %*                                                                      *
 782 %************************************************************************
 783
 784 Selecting a field for a dictionary.  If there is just one field, then
 785 there's nothing to do.
 786
 787 Dictionary selectors may get nested forall-types.  Thus:
 788
 789         class Foo a where
 790           op :: forall b. Ord b => a -> b -> b
 791
 792 Then the top-level type for op is
 793
 794         op :: forall a. Foo a =>
 795               forall b. Ord b =>
 796               a -> b -> b
 797
 798 This is unlike ordinary record selectors, which have all the for-alls
 799 at the outside.  When dealing with classes it's very convenient to
 800 recover the original type signature from the class op selector.
 801
 802 \begin{code}
 803 mkDictSelId :: Name -> Class -> Id
 804 mkDictSelId name clas
 805   = mkGlobalId (ClassOpId clas) name sel_ty info
 806   where
 807     sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id))
 808         -- We can't just say (exprType rhs), because that would give a type
 809         --      C a -> C a
 810         -- for a single-op class (after all, the selector is the identity)
 811         -- But it's type must expose the representation of the dictionary
 812         -- to get (say)         C a -> (a -> a)
 813
 814     info = noCafIdInfo
 815                 `setArityInfo`          1
 816                 `setUnfoldingInfo`      mkTopUnfolding rhs
 817                 `setAllStrictnessInfo`  Just strict_sig
 818
 819         -- We no longer use 'must-inline' on record selectors.  They'll
 820         -- inline like crazy if they scrutinise a constructor
 821
 822         -- The strictness signature is of the form U(AAAVAAAA) -> T
 823         -- where the V depends on which item we are selecting
 824         -- It's worth giving one, so that absence info etc is generated
 825         -- even if the selector isn't inlined
 826     strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes)
 827     arg_dmd | isNewTyCon tycon = evalDmd
 828             | otherwise        = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
 829                                             | id <- arg_ids ])
 830
 831     tycon      = classTyCon clas
 832     [data_con] = tyConDataCons tycon
 833     tyvars     = dataConUnivTyVars data_con
 834     arg_tys    = {- ASSERT( isVanillaDataCon data_con ) -} dataConRepArgTys data_con
 835     eq_theta   = dataConEqTheta data_con
 836     the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name
 837
 838     pred       = mkClassPred clas (mkTyVarTys tyvars)
 839     dict_id    = mkTemplateLocal     1 $ mkPredTy pred
 840     (eq_ids,n) = mkCoVarLocals 2 $ mkPredTys eq_theta
 841     arg_ids    = mkTemplateLocalsNum n arg_tys
 842
 843     mkCoVarLocals i []     = ([],i)
 844     mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs
 845                                  y      = mkCoVar (mkSysTvName (mkBuiltinUnique i) FSLIT("dc_co")) x
 846                              in (y:ys,j)
 847
 848     rhs = mkLams tyvars  (Lam dict_id   rhs_body)
 849     rhs_body | isNewTyCon tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
 850              | otherwise        = Case (Var dict_id) dict_id (idType the_arg_id)
 851                                        [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)]
 852 \end{code}
 853
 854
 855 %************************************************************************
 856 %*                                                                      *
 857         Wrapping and unwrapping newtypes and type families
 858 %*                                                                      *
 859 %************************************************************************
 860
 861 \begin{code}
 862 wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 863 -- The wrapper for the data constructor for a newtype looks like this:
 864 --      newtype T a = MkT (a,Int)
 865 --      MkT :: forall a. (a,Int) -> T a
 866 --      MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a)
 867 -- where CoT is the coercion TyCon assoicated with the newtype
 868 --
 869 -- The call (wrapNewTypeBody T [a] e) returns the
 870 -- body of the wrapper, namely
 871 --      e `cast` (CoT [a])
 872 --
 873 -- If a coercion constructor is provided in the newtype, then we use
 874 -- it, otherwise the wrap/unwrap are both no-ops
 875 --
 876 -- If the we are dealing with a newtype *instance*, we have a second coercion
 877 -- identifying the family instance with the constructor of the newtype
 878 -- instance.  This coercion is applied in any case (ie, composed with the
 879 -- coercion constructor of the newtype or applied by itself).
 880
 881 wrapNewTypeBody tycon args result_expr
 882   = wrapFamInstBody tycon args inner
 883   where
 884     inner
 885       | Just co_con <- newTyConCo_maybe tycon
 886       = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
 887       | otherwise
 888       = result_expr
 889
 890 -- When unwrapping, we do *not* apply any family coercion, because this will
 891 -- be done via a CoPat by the type checker.  We have to do it this way as
 892 -- computing the right type arguments for the coercion requires more than just
 893 -- a spliting operation (cf, TcPat.tcConPat).
 894
 895 unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 896 unwrapNewTypeBody tycon args result_expr
 897   | Just co_con <- newTyConCo_maybe tycon
 898   = mkCoerce (mkTyConApp co_con args) result_expr
 899   | otherwise
 900   = result_expr
 901
 902 -- If the type constructor is a representation type of a data instance, wrap
 903 -- the expression into a cast adjusting the expression type, which is an
 904 -- instance of the representation type, to the corresponding instance of the
 905 -- family instance type.
 906 -- See Note [Wrappers for data instance tycons]
 907 wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 908 wrapFamInstBody tycon args body
 909   | Just co_con <- tyConFamilyCoercion_maybe tycon
 910   = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) body
 911   | otherwise
 912   = body
 913
 914 unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 915 unwrapFamInstScrut tycon args scrut
 916   | Just co_con <- tyConFamilyCoercion_maybe tycon
 917   = mkCoerce (mkTyConApp co_con args) scrut
 918   | otherwise
 919   = scrut
 920 \end{code}
 921
 922
 923 %************************************************************************
 924 %*                                                                      *
 925 \subsection{Primitive operations
 926 %*                                                                      *
 927 %************************************************************************
 928
 929 \begin{code}
 930 mkPrimOpId :: PrimOp -> Id
 931 mkPrimOpId prim_op
 932   = id
 933   where
 934     (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op
 935     ty   = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
 936     name = mkWiredInName gHC_PRIM (primOpOcc prim_op)
 937                          (mkPrimOpIdUnique (primOpTag prim_op))
 938                          (AnId id) UserSyntax
 939     id   = mkGlobalId (PrimOpId prim_op) name ty info
 940
 941     info = noCafIdInfo
 942            `setSpecInfo`          mkSpecInfo (primOpRules prim_op name)
 943            `setArityInfo`         arity
 944            `setAllStrictnessInfo` Just strict_sig
 945
 946 -- For each ccall we manufacture a separate CCallOpId, giving it
 947 -- a fresh unique, a type that is correct for this particular ccall,
 948 -- and a CCall structure that gives the correct details about calling
 949 -- convention etc.
 950 --
 951 -- The *name* of this Id is a local name whose OccName gives the full
 952 -- details of the ccall, type and all.  This means that the interface
 953 -- file reader can reconstruct a suitable Id
 954
 955 mkFCallId :: Unique -> ForeignCall -> Type -> Id
 956 mkFCallId uniq fcall ty
 957   = ASSERT( isEmptyVarSet (tyVarsOfType ty) )
 958         -- A CCallOpId should have no free type variables;
 959         -- when doing substitutions won't substitute over it
 960     mkGlobalId (FCallId fcall) name ty info
 961   where
 962     occ_str = showSDoc (braces (ppr fcall <+> ppr ty))
 963         -- The "occurrence name" of a ccall is the full info about the
 964         -- ccall; it is encoded, but may have embedded spaces etc!
 965
 966     name = mkFCallName uniq occ_str
 967
 968     info = noCafIdInfo
 969            `setArityInfo`               arity
 970            `setAllStrictnessInfo`       Just strict_sig
 971
 972     (_, tau)     = tcSplitForAllTys ty
 973     (arg_tys, _) = tcSplitFunTys tau
 974     arity        = length arg_tys
 975     strict_sig   = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
 976
 977 -- Tick boxes and breakpoints are both represented as TickBoxOpIds,
 978 -- except for the type:
 979 --
 980 --    a plain HPC tick box has type (State# RealWorld)
 981 --    a breakpoint Id has type forall a.a
 982 --
 983 -- The breakpoint Id will be applied to a list of arbitrary free variables,
 984 -- which is why it needs a polymorphic type.
 985
 986 mkTickBoxOpId :: Unique -> Module -> TickBoxId -> Id
 987 mkTickBoxOpId uniq mod ix = mkTickBox' uniq mod ix realWorldStatePrimTy
 988
 989 mkBreakPointOpId :: Unique -> Module -> TickBoxId -> Id
 990 mkBreakPointOpId uniq mod ix = mkTickBox' uniq mod ix ty
 991  where ty = mkSigmaTy [openAlphaTyVar] [] openAlphaTy
 992
 993 mkTickBox' uniq mod ix ty = mkGlobalId (TickBoxOpId tickbox) name ty info
 994   where
 995     tickbox = TickBox mod ix
 996     occ_str = showSDoc (braces (ppr tickbox))
 997     name    = mkTickBoxOpName uniq occ_str
 998     info    = noCafIdInfo
 999 \end{code}
1000
1001
1002 %************************************************************************
1003 %*                                                                      *
1004 \subsection{DictFuns and default methods}
1005 %*                                                                      *
1006 %************************************************************************
1007
1008 Important notes about dict funs and default methods
1009 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1010 Dict funs and default methods are *not* ImplicitIds.  Their definition
1011 involves user-written code, so we can't figure out their strictness etc
1012 based on fixed info, as we can for constructors and record selectors (say).
1013
1014 We build them as LocalIds, but with External Names.  This ensures that
1015 they are taken to account by free-variable finding and dependency
1016 analysis (e.g. CoreFVs.exprFreeVars).
1017
1018 Why shouldn't they be bound as GlobalIds?  Because, in particular, if
1019 they are globals, the specialiser floats dict uses above their defns,
1020 which prevents good simplifications happening.  Also the strictness
1021 analyser treats a occurrence of a GlobalId as imported and assumes it
1022 contains strictness in its IdInfo, which isn't true if the thing is
1023 bound in the same module as the occurrence.
1024
1025 It's OK for dfuns to be LocalIds, because we form the instance-env to
1026 pass on to the next module (md_insts) in CoreTidy, afer tidying
1027 and globalising the top-level Ids.
1028
1029 BUT make sure they are *exported* LocalIds (mkExportedLocalId) so
1030 that they aren't discarded by the occurrence analyser.
1031
1032 \begin{code}
1033 mkDefaultMethodId dm_name ty = mkExportedLocalId dm_name ty
1034
1035 mkDictFunId :: Name             -- Name to use for the dict fun;
1036             -> [TyVar]
1037             -> ThetaType
1038             -> Class
1039             -> [Type]
1040             -> Id
1041
1042 mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys
1043   = mkExportedLocalId dfun_name dfun_ty
1044   where
1045     dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
1046
1047 {-  1 dec 99: disable the Mark Jones optimisation for the sake
1048     of compatibility with Hugs.
1049     See `types/InstEnv' for a discussion related to this.
1050
1051     (class_tyvars, sc_theta, _, _) = classBigSig clas
1052     not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
1053     sc_theta' = substClasses (zipTopTvSubst class_tyvars inst_tys) sc_theta
1054     dfun_theta = case inst_decl_theta of
1055                    []    -> []  -- If inst_decl_theta is empty, then we don't
1056                                 -- want to have any dict arguments, so that we can
1057                                 -- expose the constant methods.
1058
1059                    other -> nub (inst_decl_theta ++ filter not_const sc_theta')
1060                                 -- Otherwise we pass the superclass dictionaries to
1061                                 -- the dictionary function; the Mark Jones optimisation.
1062                                 --
1063                                 -- NOTE the "nub".  I got caught by this one:
1064                                 --   class Monad m => MonadT t m where ...
1065                                 --   instance Monad m => MonadT (EnvT env) m where ...
1066                                 -- Here, the inst_decl_theta has (Monad m); but so
1067                                 -- does the sc_theta'!
1068                                 --
1069                                 -- NOTE the "not_const".  I got caught by this one too:
1070                                 --   class Foo a => Baz a b where ...
1071                                 --   instance Wob b => Baz T b where..
1072                                 -- Now sc_theta' has Foo T
1073 -}
1074 \end{code}
1075
1076
1077 %************************************************************************
1078 %*                                                                      *
1079 \subsection{Un-definable}
1080 %*                                                                      *
1081 %************************************************************************
1082
1083 These Ids can't be defined in Haskell.  They could be defined in
1084 unfoldings in the wired-in GHC.Prim interface file, but we'd have to
1085 ensure that they were definitely, definitely inlined, because there is
1086 no curried identifier for them.  That's what mkCompulsoryUnfolding
1087 does.  If we had a way to get a compulsory unfolding from an interface
1088 file, we could do that, but we don't right now.
1089
1090 unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
1091 just gets expanded into a type coercion wherever it occurs.  Hence we
1092 add it as a built-in Id with an unfolding here.
1093
1094 The type variables we use here are "open" type variables: this means
1095 they can unify with both unlifted and lifted types.  Hence we provide
1096 another gun with which to shoot yourself in the foot.
1097
1098 \begin{code}
1099 mkWiredInIdName mod fs uniq id
1100  = mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax
1101
1102 unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceIdKey  unsafeCoerceId
1103 nullAddrName     = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#")     nullAddrIdKey      nullAddrId
1104 seqName          = mkWiredInIdName gHC_PRIM FSLIT("seq")           seqIdKey           seqId
1105 realWorldName    = mkWiredInIdName gHC_PRIM FSLIT("realWorld#")    realWorldPrimIdKey realWorldPrimId
1106 lazyIdName       = mkWiredInIdName gHC_BASE FSLIT("lazy")         lazyIdKey           lazyId
1107
1108 errorName                = mkWiredInIdName gHC_ERR FSLIT("error")            errorIdKey eRROR_ID
1109 recSelErrorName          = mkWiredInIdName gHC_ERR FSLIT("recSelError")     recSelErrorIdKey rEC_SEL_ERROR_ID
1110 runtimeErrorName         = mkWiredInIdName gHC_ERR FSLIT("runtimeError")    runtimeErrorIdKey rUNTIME_ERROR_ID
1111 irrefutPatErrorName      = mkWiredInIdName gHC_ERR FSLIT("irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
1112 recConErrorName          = mkWiredInIdName gHC_ERR FSLIT("recConError")     recConErrorIdKey rEC_CON_ERROR_ID
1113 patErrorName             = mkWiredInIdName gHC_ERR FSLIT("patError")         patErrorIdKey pAT_ERROR_ID
1114 noMethodBindingErrorName = mkWiredInIdName gHC_ERR FSLIT("noMethodBindingError")
1115                                            noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
1116 nonExhaustiveGuardsErrorName
1117   = mkWiredInIdName gHC_ERR FSLIT("nonExhaustiveGuardsError")
1118                     nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
1119 \end{code}
1120
1121 \begin{code}
1122 -- unsafeCoerce# :: forall a b. a -> b
1123 unsafeCoerceId
1124   = pcMiscPrelId unsafeCoerceName ty info
1125   where
1126     info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
1127
1128
1129     ty  = mkForAllTys [openAlphaTyVar,openBetaTyVar]
1130                       (mkFunTy openAlphaTy openBetaTy)
1131     [x] = mkTemplateLocals [openAlphaTy]
1132     rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
1133           Cast (Var x) (mkUnsafeCoercion openAlphaTy openBetaTy)
1134
1135 -- nullAddr# :: Addr#
1136 -- The reason is is here is because we don't provide
1137 -- a way to write this literal in Haskell.
1138 nullAddrId
1139   = pcMiscPrelId nullAddrName addrPrimTy info
1140   where
1141     info = noCafIdInfo `setUnfoldingInfo`
1142            mkCompulsoryUnfolding (Lit nullAddrLit)
1143
1144 seqId
1145   = pcMiscPrelId seqName ty info
1146   where
1147     info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
1148
1149
1150     ty  = mkForAllTys [alphaTyVar,openBetaTyVar]
1151                       (mkFunTy alphaTy (mkFunTy openBetaTy openBetaTy))
1152     [x,y] = mkTemplateLocals [alphaTy, openBetaTy]
1153     rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x openBetaTy [(DEFAULT, [], Var y)])
1154
1155 -- lazy :: forall a?. a? -> a?   (i.e. works for unboxed types too)
1156 -- Used to lazify pseq:         pseq a b = a `seq` lazy b
1157 --
1158 -- Also, no strictness: by being a built-in Id, all the info about lazyId comes from here,
1159 -- not from GHC.Base.hi.   This is important, because the strictness
1160 -- analyser will spot it as strict!
1161 --
1162 -- Also no unfolding in lazyId: it gets "inlined" by a HACK in the worker/wrapperpass
1163 --      (see WorkWrap.wwExpr)
1164 -- We could use inline phases to do this, but that would be vulnerable to changes in
1165 -- phase numbering....we must inline precisely after strictness analysis.
1166 lazyId
1167   = pcMiscPrelId lazyIdName ty info
1168   where
1169     info = noCafIdInfo
1170     ty  = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
1171
1172 lazyIdUnfolding :: CoreExpr     -- Used to expand 'lazyId' after strictness anal
1173 lazyIdUnfolding = mkLams [openAlphaTyVar,x] (Var x)
1174                 where
1175                   [x] = mkTemplateLocals [openAlphaTy]
1176 \end{code}
1177
1178 @realWorld#@ used to be a magic literal, \tr{void#}.  If things get
1179 nasty as-is, change it back to a literal (@Literal@).
1180
1181 voidArgId is a Local Id used simply as an argument in functions
1182 where we just want an arg to avoid having a thunk of unlifted type.
1183 E.g.
1184         x = \ void :: State# RealWorld -> (# p, q #)
1185
1186 This comes up in strictness analysis
1187
1188 \begin{code}
1189 realWorldPrimId -- :: State# RealWorld
1190   = pcMiscPrelId realWorldName realWorldStatePrimTy
1191                  (noCafIdInfo `setUnfoldingInfo` evaldUnfolding)
1192         -- The evaldUnfolding makes it look that realWorld# is evaluated
1193         -- which in turn makes Simplify.interestingArg return True,
1194         -- which in turn makes INLINE things applied to realWorld# likely
1195         -- to be inlined
1196
1197 voidArgId       -- :: State# RealWorld
1198   = mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy
1199 \end{code}
1200
1201
1202 %************************************************************************
1203 %*                                                                      *
1204 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
1205 %*                                                                      *
1206 %************************************************************************
1207
1208 GHC randomly injects these into the code.
1209
1210 @patError@ is just a version of @error@ for pattern-matching
1211 failures.  It knows various ``codes'' which expand to longer
1212 strings---this saves space!
1213
1214 @absentErr@ is a thing we put in for ``absent'' arguments.  They jolly
1215 well shouldn't be yanked on, but if one is, then you will get a
1216 friendly message from @absentErr@ (rather than a totally random
1217 crash).
1218
1219 @parError@ is a special version of @error@ which the compiler does
1220 not know to be a bottoming Id.  It is used in the @_par_@ and @_seq_@
1221 templates, but we don't ever expect to generate code for it.
1222
1223 \begin{code}
1224 mkRuntimeErrorApp
1225         :: Id           -- Should be of type (forall a. Addr# -> a)
1226                         --      where Addr# points to a UTF8 encoded string
1227         -> Type         -- The type to instantiate 'a'
1228         -> String       -- The string to print
1229         -> CoreExpr
1230
1231 mkRuntimeErrorApp err_id res_ty err_msg
1232   = mkApps (Var err_id) [Type res_ty, err_string]
1233   where
1234     err_string = Lit (mkStringLit err_msg)
1235
1236 rEC_SEL_ERROR_ID                = mkRuntimeErrorId recSelErrorName
1237 rUNTIME_ERROR_ID                = mkRuntimeErrorId runtimeErrorName
1238 iRREFUT_PAT_ERROR_ID            = mkRuntimeErrorId irrefutPatErrorName
1239 rEC_CON_ERROR_ID                = mkRuntimeErrorId recConErrorName
1240 pAT_ERROR_ID                    = mkRuntimeErrorId patErrorName
1241 nO_METHOD_BINDING_ERROR_ID      = mkRuntimeErrorId noMethodBindingErrorName
1242 nON_EXHAUSTIVE_GUARDS_ERROR_ID  = mkRuntimeErrorId nonExhaustiveGuardsErrorName
1243
1244 -- The runtime error Ids take a UTF8-encoded string as argument
1245 mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
1246 runtimeErrorTy        = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
1247 \end{code}
1248
1249 \begin{code}
1250 eRROR_ID = pc_bottoming_Id errorName errorTy
1251
1252 errorTy  :: Type
1253 errorTy  = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
1254     -- Notice the openAlphaTyVar.  It says that "error" can be applied
1255     -- to unboxed as well as boxed types.  This is OK because it never
1256     -- returns, so the return type is irrelevant.
1257 \end{code}
1258
1259
1260 %************************************************************************
1261 %*                                                                      *
1262 \subsection{Utilities}
1263 %*                                                                      *
1264 %************************************************************************
1265
1266 \begin{code}
1267 pcMiscPrelId :: Name -> Type -> IdInfo -> Id
1268 pcMiscPrelId name ty info
1269   = mkVanillaGlobal name ty info
1270     -- We lie and say the thing is imported; otherwise, we get into
1271     -- a mess with dependency analysis; e.g., core2stg may heave in
1272     -- random calls to GHCbase.unpackPS__.  If GHCbase is the module
1273     -- being compiled, then it's just a matter of luck if the definition
1274     -- will be in "the right place" to be in scope.
1275
1276 pc_bottoming_Id name ty
1277  = pcMiscPrelId name ty bottoming_info
1278  where
1279     bottoming_info = vanillaIdInfo `setAllStrictnessInfo` Just strict_sig
1280         -- Do *not* mark them as NoCafRefs, because they can indeed have
1281         -- CAF refs.  For example, pAT_ERROR_ID calls GHC.Err.untangle,
1282         -- which has some CAFs
1283         -- In due course we may arrange that these error-y things are
1284         -- regarded by the GC as permanently live, in which case we
1285         -- can give them NoCaf info.  As it is, any function that calls
1286         -- any pc_bottoming_Id will itself have CafRefs, which bloats
1287         -- SRTs.
1288
1289     strict_sig     = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
1290         -- These "bottom" out, no matter what their arguments
1291 \end{code}
1292