ghc/compiler/basicTypes/MkId.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1998
   3 %
   4 \section[StdIdInfo]{Standard unfoldings}
   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         mkDataConId, mkDataConWrapId,
  20         mkRecordSelId, rebuildConArgs,
  21         mkPrimOpId, mkFCallId,
  22
  23         -- And some particular Ids; see below for why they are wired in
  24         wiredInIds,
  25         unsafeCoerceId, realWorldPrimId,
  26         eRROR_ID, rEC_SEL_ERROR_ID, pAT_ERROR_ID, rEC_CON_ERROR_ID,
  27         rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID,
  28         nO_METHOD_BINDING_ERROR_ID, aBSENT_ERROR_ID, pAR_ERROR_ID
  29     ) where
  30
  31 #include "HsVersions.h"
  32
  33
  34 import BasicTypes       ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
  35 import TysPrim          ( openAlphaTyVars, alphaTyVar, alphaTy,
  36                           intPrimTy, realWorldStatePrimTy
  37                         )
  38 import TysWiredIn       ( charTy, mkListTy )
  39 import PrelNames        ( pREL_ERR, pREL_GHC )
  40 import PrelRules        ( primOpRule )
  41 import Rules            ( addRule )
  42 import TcType           ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
  43                           mkTyVarTys, mkClassPred, tcEqPred,
  44                           mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy,
  45                           isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
  46                           tcSplitFunTys, tcSplitForAllTys, mkPredTy
  47                         )
  48 import Module           ( Module )
  49 import CoreUtils        ( exprType, mkInlineMe )
  50 import CoreUnfold       ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
  51 import Literal          ( Literal(..) )
  52 import TyCon            ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
  53                           tyConTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
  54 import Class            ( Class, classTyCon, classTyVars, classSelIds )
  55 import Var              ( Id, TyVar )
  56 import VarSet           ( isEmptyVarSet )
  57 import Name             ( mkWiredInName, mkFCallName, Name )
  58 import OccName          ( mkVarOcc )
  59 import PrimOp           ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName )
  60 import ForeignCall      ( ForeignCall )
  61 import DataCon          ( DataCon,
  62                           dataConFieldLabels, dataConRepArity, dataConTyCon,
  63                           dataConArgTys, dataConRepType, dataConRepStrictness,
  64                           dataConInstOrigArgTys,
  65                           dataConName, dataConTheta,
  66                           dataConSig, dataConStrictMarks, dataConId,
  67                           splitProductType
  68                         )
  69 import Id               ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
  70                           mkTemplateLocals, mkTemplateLocalsNum,
  71                           mkTemplateLocal, idNewStrictness, idName
  72                         )
  73 import IdInfo           ( IdInfo, noCafNoTyGenIdInfo,
  74                           exactArity, setUnfoldingInfo, setCprInfo,
  75                           setArityInfo, setSpecInfo,  setCgInfo,
  76                           mkNewStrictnessInfo, setNewStrictnessInfo,
  77                           GlobalIdDetails(..), CafInfo(..), CprInfo(..),
  78                           CgInfo(..), setCgArity
  79                         )
  80 import NewDemand        ( mkStrictSig, strictSigResInfo, DmdResult(..),
  81                           mkTopDmdType, topDmd, evalDmd )
  82 import FieldLabel       ( mkFieldLabel, fieldLabelName,
  83                           firstFieldLabelTag, allFieldLabelTags, fieldLabelType
  84                         )
  85 import CoreSyn
  86 import Unique           ( mkBuiltinUnique )
  87 import Maybes
  88 import PrelNames
  89 import Maybe            ( isJust )
  90 import Outputable
  91 import ListSetOps       ( assoc, assocMaybe )
  92 import UnicodeUtil      ( stringToUtf8 )
  93 import Char             ( ord )
  94 \end{code}
  95
  96 %************************************************************************
  97 %*                                                                      *
  98 \subsection{Wired in Ids}
  99 %*                                                                      *
 100 %************************************************************************
 101
 102 \begin{code}
 103 wiredInIds
 104   = [   -- These error-y things are wired in because we don't yet have
 105         -- a way to express in an interface file that the result type variable
 106         -- is 'open'; that is can be unified with an unboxed type
 107         --
 108         -- [The interface file format now carry such information, but there's
 109         -- no way yet of expressing at the definition site for these
 110         -- error-reporting
 111         -- functions that they have an 'open' result type. -- sof 1/99]
 112
 113       aBSENT_ERROR_ID
 114     , eRROR_ID
 115     , iRREFUT_PAT_ERROR_ID
 116     , nON_EXHAUSTIVE_GUARDS_ERROR_ID
 117     , nO_METHOD_BINDING_ERROR_ID
 118     , pAR_ERROR_ID
 119     , pAT_ERROR_ID
 120     , rEC_CON_ERROR_ID
 121     , rEC_UPD_ERROR_ID
 122
 123         -- These three can't be defined in Haskell
 124     , realWorldPrimId
 125     , unsafeCoerceId
 126     , getTagId
 127     ]
 128 \end{code}
 129
 130 %************************************************************************
 131 %*                                                                      *
 132 \subsection{Data constructors}
 133 %*                                                                      *
 134 %************************************************************************
 135
 136 \begin{code}
 137 mkDataConId :: Name -> DataCon -> Id
 138         -- Makes the *worker* for the data constructor; that is, the function
 139         -- that takes the reprsentation arguments and builds the constructor.
 140 mkDataConId work_name data_con
 141   = id
 142   where
 143     id = mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info
 144     info = noCafNoTyGenIdInfo
 145            `setCgArity`                 arity
 146            `setArityInfo`               arity
 147            `setNewStrictnessInfo`       Just strict_sig
 148
 149     arity = dataConRepArity data_con
 150     strict_sig = mkStrictSig id arity (mkTopDmdType (dataConRepStrictness data_con) cpr_info)
 151
 152     tycon = dataConTyCon data_con
 153     cpr_info | isProductTyCon tycon &&
 154                isDataTyCon tycon    &&
 155                arity > 0            &&
 156                arity <= mAX_CPR_SIZE    = RetCPR
 157              | otherwise                = TopRes
 158         -- RetCPR is only true for products that are real data types;
 159         -- that is, not unboxed tuples or [non-recursive] newtypes
 160
 161 mAX_CPR_SIZE :: Arity
 162 mAX_CPR_SIZE = 10
 163 -- We do not treat very big tuples as CPR-ish:
 164 --      a) for a start we get into trouble because there aren't
 165 --         "enough" unboxed tuple types (a tiresome restriction,
 166 --         but hard to fix),
 167 --      b) more importantly, big unboxed tuples get returned mainly
 168 --         on the stack, and are often then allocated in the heap
 169 --         by the caller.  So doing CPR for them may in fact make
 170 --         things worse.
 171 \end{code}
 172
 173 The wrapper for a constructor is an ordinary top-level binding that evaluates
 174 any strict args, unboxes any args that are going to be flattened, and calls
 175 the worker.
 176
 177 We're going to build a constructor that looks like:
 178
 179         data (Data a, C b) =>  T a b = T1 !a !Int b
 180
 181         T1 = /\ a b ->
 182              \d1::Data a, d2::C b ->
 183              \p q r -> case p of { p ->
 184                        case q of { q ->
 185                        Con T1 [a,b] [p,q,r]}}
 186
 187 Notice that
 188
 189 * d2 is thrown away --- a context in a data decl is used to make sure
 190   one *could* construct dictionaries at the site the constructor
 191   is used, but the dictionary isn't actually used.
 192
 193 * We have to check that we can construct Data dictionaries for
 194   the types a and Int.  Once we've done that we can throw d1 away too.
 195
 196 * We use (case p of q -> ...) to evaluate p, rather than "seq" because
 197   all that matters is that the arguments are evaluated.  "seq" is
 198   very careful to preserve evaluation order, which we don't need
 199   to be here.
 200
 201   You might think that we could simply give constructors some strictness
 202   info, like PrimOps, and let CoreToStg do the let-to-case transformation.
 203   But we don't do that because in the case of primops and functions strictness
 204   is a *property* not a *requirement*.  In the case of constructors we need to
 205   do something active to evaluate the argument.
 206
 207   Making an explicit case expression allows the simplifier to eliminate
 208   it in the (common) case where the constructor arg is already evaluated.
 209
 210 \begin{code}
 211 mkDataConWrapId data_con
 212   = wrap_id
 213   where
 214     wrap_id = mkGlobalId (DataConWrapId data_con) (dataConName data_con) wrap_ty info
 215     work_id = dataConId data_con
 216
 217     info = noCafNoTyGenIdInfo
 218            `setUnfoldingInfo`   mkTopUnfolding (mkInlineMe wrap_rhs)
 219            `setCgArity`         arity
 220                 -- The NoCaf-ness is set by noCafNoTyGenIdInfo
 221            `setArityInfo`       arity
 222                 -- It's important to specify the arity, so that partial
 223                 -- applications are treated as values
 224            `setNewStrictnessInfo`       Just wrap_sig
 225
 226     wrap_ty = mkForAllTys all_tyvars $
 227               mkFunTys all_arg_tys
 228               result_ty
 229
 230     res_info = strictSigResInfo (idNewStrictness work_id)
 231     wrap_sig = mkStrictSig wrap_id arity (mkTopDmdType (replicate arity topDmd) res_info)
 232         -- The Cpr info can be important inside INLINE rhss, where the
 233         -- wrapper constructor isn't inlined
 234         -- But we are sloppy about the argument demands, because we expect
 235         -- to inline the constructor very vigorously.
 236
 237     wrap_rhs | isNewTyCon tycon
 238              = ASSERT( null ex_tyvars && null ex_dict_args && length orig_arg_tys == 1 )
 239                 -- No existentials on a newtype, but it can have a context
 240                 -- e.g.         newtype Eq a => T a = MkT (...)
 241                 mkLams tyvars $ mkLams dict_args $ Lam id_arg1 $
 242                 mkNewTypeBody tycon result_ty id_arg1
 243
 244              | null dict_args && not (any isMarkedStrict strict_marks)
 245              = Var work_id      -- The common case.  Not only is this efficient,
 246                                 -- but it also ensures that the wrapper is replaced
 247                                 -- by the worker even when there are no args.
 248                                 --              f (:) x
 249                                 -- becomes
 250                                 --              f $w: x
 251                                 -- This is really important in rule matching,
 252                                 -- (We could match on the wrappers,
 253                                 -- but that makes it less likely that rules will match
 254                                 -- when we bring bits of unfoldings together.)
 255                 --
 256                 -- NB:  because of this special case, (map (:) ys) turns into
 257                 --      (map $w: ys), and thence into (map (\x xs. $w: x xs) ys)
 258                 --      in core-to-stg.  The top-level defn for (:) is never used.
 259                 --      This is somewhat of a bore, but I'm currently leaving it
 260                 --      as is, so that there still is a top level curried (:) for
 261                 --      the interpreter to call.
 262
 263              | otherwise
 264              = mkLams all_tyvars $ mkLams dict_args $
 265                mkLams ex_dict_args $ mkLams id_args $
 266                foldr mk_case con_app
 267                      (zip (ex_dict_args++id_args) strict_marks) i3 []
 268
 269     con_app i rep_ids = mkApps (Var work_id)
 270                                (map varToCoreExpr (all_tyvars ++ reverse rep_ids))
 271
 272     (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con
 273     all_tyvars   = tyvars ++ ex_tyvars
 274
 275     dict_tys     = mkPredTys theta
 276     ex_dict_tys  = mkPredTys ex_theta
 277     all_arg_tys  = dict_tys ++ ex_dict_tys ++ orig_arg_tys
 278     result_ty    = mkTyConApp tycon (mkTyVarTys tyvars)
 279
 280     mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
 281                    where
 282                      n = length tys
 283
 284     (dict_args, i1)    = mkLocals 1  dict_tys
 285     (ex_dict_args,i2)  = mkLocals i1 ex_dict_tys
 286     (id_args,i3)       = mkLocals i2 orig_arg_tys
 287     arity              = i3-1
 288     (id_arg1:_)   = id_args             -- Used for newtype only
 289
 290     strict_marks  = dataConStrictMarks data_con
 291
 292     mk_case
 293            :: (Id, StrictnessMark)      -- Arg, strictness
 294            -> (Int -> [Id] -> CoreExpr) -- Body
 295            -> Int                       -- Next rep arg id
 296            -> [Id]                      -- Rep args so far, reversed
 297            -> CoreExpr
 298     mk_case (arg,strict) body i rep_args
 299           = case strict of
 300                 NotMarkedStrict -> body i (arg:rep_args)
 301                 MarkedStrict
 302                    | isUnLiftedType (idType arg) -> body i (arg:rep_args)
 303                    | otherwise ->
 304                         Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))]
 305
 306                 MarkedUnboxed
 307                    -> case splitProductType "do_unbox" (idType arg) of
 308                            (tycon, tycon_args, con, tys) ->
 309                                    Case (Var arg) arg [(DataAlt con, con_args,
 310                                         body i' (reverse con_args ++ rep_args))]
 311                               where
 312                                 (con_args, i') = mkLocals i tys
 313 \end{code}
 314
 315
 316 %************************************************************************
 317 %*                                                                      *
 318 \subsection{Record selectors}
 319 %*                                                                      *
 320 %************************************************************************
 321
 322 We're going to build a record selector unfolding that looks like this:
 323
 324         data T a b c = T1 { ..., op :: a, ...}
 325                      | T2 { ..., op :: a, ...}
 326                      | T3
 327
 328         sel = /\ a b c -> \ d -> case d of
 329                                     T1 ... x ... -> x
 330                                     T2 ... x ... -> x
 331                                     other        -> error "..."
 332
 333 Similarly for newtypes
 334
 335         newtype N a = MkN { unN :: a->a }
 336
 337         unN :: N a -> a -> a
 338         unN n = coerce (a->a) n
 339
 340 We need to take a little care if the field has a polymorphic type:
 341
 342         data R = R { f :: forall a. a->a }
 343
 344 Then we want
 345
 346         f :: forall a. R -> a -> a
 347         f = /\ a \ r = case r of
 348                           R f -> f a
 349
 350 (not f :: R -> forall a. a->a, which gives the type inference mechanism
 351 problems at call sites)
 352
 353 Similarly for newtypes
 354
 355         newtype N = MkN { unN :: forall a. a->a }
 356
 357         unN :: forall a. N -> a -> a
 358         unN = /\a -> \n:N -> coerce (a->a) n
 359
 360 \begin{code}
 361 mkRecordSelId tycon field_label unpack_id unpackUtf8_id
 362         -- Assumes that all fields with the same field label have the same type
 363         --
 364         -- Annoyingly, we have to pass in the unpackCString# Id, because
 365         -- we can't conjure it up out of thin air
 366   = sel_id
 367   where
 368     sel_id     = mkGlobalId (RecordSelId field_label) (fieldLabelName field_label) selector_ty info
 369     field_ty   = fieldLabelType field_label
 370     data_cons  = tyConDataCons tycon
 371     tyvars     = tyConTyVars tycon      -- These scope over the types in
 372                                         -- the FieldLabels of constructors of this type
 373     data_ty   = mkTyConApp tycon tyvar_tys
 374     tyvar_tys = mkTyVarTys tyvars
 375
 376     tycon_theta = tyConTheta tycon      -- The context on the data decl
 377                                         --   eg data (Eq a, Ord b) => T a b = ...
 378     dict_tys  = [mkPredTy pred | pred <- tycon_theta,
 379                                  needed_dict pred]
 380     needed_dict pred = or [ tcEqPred pred p
 381                           | (DataAlt dc, _, _) <- the_alts, p <- dataConTheta dc]
 382     n_dict_tys = length dict_tys
 383
 384     (field_tyvars,field_theta,field_tau) = tcSplitSigmaTy field_ty
 385     field_dict_tys                       = map mkPredTy field_theta
 386     n_field_dict_tys                     = length field_dict_tys
 387         -- If the field has a universally quantified type we have to
 388         -- be a bit careful.  Suppose we have
 389         --      data R = R { op :: forall a. Foo a => a -> a }
 390         -- Then we can't give op the type
 391         --      op :: R -> forall a. Foo a => a -> a
 392         -- because the typechecker doesn't understand foralls to the
 393         -- right of an arrow.  The "right" type to give it is
 394         --      op :: forall a. Foo a => R -> a -> a
 395         -- But then we must generate the right unfolding too:
 396         --      op = /\a -> \dfoo -> \ r ->
 397         --           case r of
 398         --              R op -> op a dfoo
 399         -- Note that this is exactly the type we'd infer from a user defn
 400         --      op (R op) = op
 401
 402         -- Very tiresomely, the selectors are (unnecessarily!) overloaded over
 403         -- just the dictionaries in the types of the constructors that contain
 404         -- the relevant field.  Urgh.
 405         -- NB: this code relies on the fact that DataCons are quantified over
 406         -- the identical type variables as their parent TyCon
 407
 408     selector_ty :: Type
 409     selector_ty  = mkForAllTys tyvars $ mkForAllTys field_tyvars $
 410                    mkFunTys dict_tys  $  mkFunTys field_dict_tys $
 411                    mkFunTy data_ty field_tau
 412
 413     arity = 1 + n_dict_tys + n_field_dict_tys
 414     info = noCafNoTyGenIdInfo
 415            `setCgInfo`          (CgInfo arity caf_info)
 416            `setArityInfo`       arity
 417            `setUnfoldingInfo`   unfolding
 418         -- ToDo: consider adding further IdInfo
 419
 420     unfolding = mkTopUnfolding sel_rhs
 421
 422         -- Allocate Ids.  We do it a funny way round because field_dict_tys is
 423         -- almost always empty.  Also note that we use length_tycon_theta
 424         -- rather than n_dict_tys, because the latter gives an infinite loop:
 425         -- n_dict tys depends on the_alts, which depens on arg_ids, which depends
 426         -- on arity, which depends on n_dict tys.  Sigh!  Mega sigh!
 427     field_dict_base    = length tycon_theta + 1
 428     dict_id_base       = field_dict_base + n_field_dict_tys
 429     field_base         = dict_id_base + 1
 430     dict_ids           = mkTemplateLocalsNum  1               dict_tys
 431     field_dict_ids     = mkTemplateLocalsNum  field_dict_base field_dict_tys
 432     data_id            = mkTemplateLocal      dict_id_base    data_ty
 433
 434     alts      = map mk_maybe_alt data_cons
 435     the_alts  = catMaybes alts
 436
 437     no_default = all isJust alts        -- No default needed
 438     default_alt | no_default = []
 439                 | otherwise  = [(DEFAULT, [], error_expr)]
 440
 441         -- the default branch may have CAF refs, because it calls recSelError etc.
 442     caf_info    | no_default = NoCafRefs
 443                 | otherwise  = MayHaveCafRefs
 444
 445     sel_rhs = mkLams tyvars   $ mkLams field_tyvars $
 446               mkLams dict_ids $ mkLams field_dict_ids $
 447               Lam data_id     $ sel_body
 448
 449     sel_body | isNewTyCon tycon = mkNewTypeBody tycon field_tau data_id
 450              | otherwise        = Case (Var data_id) data_id (default_alt ++ the_alts)
 451
 452     mk_maybe_alt data_con
 453           = case maybe_the_arg_id of
 454                 Nothing         -> Nothing
 455                 Just the_arg_id -> Just (DataAlt data_con, real_args, mkLets binds body)
 456                   where
 457                     body               = mkVarApps (mkVarApps (Var the_arg_id) field_tyvars) field_dict_ids
 458                     strict_marks       = dataConStrictMarks data_con
 459                     (binds, real_args) = rebuildConArgs arg_ids strict_marks
 460                                                         (map mkBuiltinUnique [unpack_base..])
 461         where
 462             arg_ids = mkTemplateLocalsNum field_base (dataConInstOrigArgTys data_con tyvar_tys)
 463
 464             unpack_base = field_base + length arg_ids
 465
 466                                 -- arity+1 avoids all shadowing
 467             maybe_the_arg_id  = assocMaybe (field_lbls `zip` arg_ids) field_label
 468             field_lbls        = dataConFieldLabels data_con
 469
 470     error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type field_tau, err_string]
 471     err_string
 472         | all safeChar full_msg
 473             = App (Var unpack_id) (Lit (MachStr (_PK_ full_msg)))
 474         | otherwise
 475             = App (Var unpackUtf8_id) (Lit (MachStr (_PK_ (stringToUtf8 (map ord full_msg)))))
 476         where
 477         safeChar c = c >= '\1' && c <= '\xFF'
 478         -- TODO: Putting this Unicode stuff here is ugly. Find a better
 479         -- generic place to make string literals. This logic is repeated
 480         -- in DsUtils.
 481     full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id])
 482
 483
 484 -- This rather ugly function converts the unpacked data con
 485 -- arguments back into their packed form.
 486
 487 rebuildConArgs
 488   :: [Id]                       -- Source-level args
 489   -> [StrictnessMark]           -- Strictness annotations (per-arg)
 490   -> [Unique]                   -- Uniques for the new Ids
 491   -> ([CoreBind], [Id])         -- A binding for each source-level arg, plus
 492                                 -- a list of the representation-level arguments
 493 -- e.g.   data T = MkT Int !Int
 494 --
 495 -- rebuild [x::Int, y::Int] [Not, Unbox]
 496 --  = ([ y = I# t ], [x,t])
 497
 498 rebuildConArgs []         stricts us = ([], [])
 499
 500 -- Type variable case
 501 rebuildConArgs (arg:args) stricts us
 502   | isTyVar arg
 503   = let (binds, args') = rebuildConArgs args stricts us
 504     in  (binds, arg:args')
 505
 506 -- Term variable case
 507 rebuildConArgs (arg:args) (str:stricts) us
 508   | isMarkedUnboxed str
 509   = let
 510         arg_ty  = idType arg
 511
 512         (_, tycon_args, pack_con, con_arg_tys)
 513                  = splitProductType "rebuildConArgs" arg_ty
 514
 515         unpacked_args  = zipWith (mkSysLocal SLIT("rb")) us con_arg_tys
 516         (binds, args') = rebuildConArgs args stricts (drop (length con_arg_tys) us)
 517         con_app        = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
 518     in
 519     (NonRec arg con_app : binds, unpacked_args ++ args')
 520
 521   | otherwise
 522   = let (binds, args') = rebuildConArgs args stricts us
 523     in  (binds, arg:args')
 524 \end{code}
 525
 526
 527 %************************************************************************
 528 %*                                                                      *
 529 \subsection{Dictionary selectors}
 530 %*                                                                      *
 531 %************************************************************************
 532
 533 Selecting a field for a dictionary.  If there is just one field, then
 534 there's nothing to do.
 535
 536 ToDo: unify with mkRecordSelId.
 537
 538 \begin{code}
 539 mkDictSelId :: Name -> Class -> Id
 540 mkDictSelId name clas
 541   = mkGlobalId (RecordSelId field_lbl) name sel_ty info
 542   where
 543     sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id))
 544         -- We can't just say (exprType rhs), because that would give a type
 545         --      C a -> C a
 546         -- for a single-op class (after all, the selector is the identity)
 547         -- But it's type must expose the representation of the dictionary
 548         -- to gat (say)         C a -> (a -> a)
 549
 550     field_lbl = mkFieldLabel name tycon sel_ty tag
 551     tag       = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name
 552
 553     info      = noCafNoTyGenIdInfo
 554                 `setCgArity`        1
 555                 `setArityInfo`      1
 556                 `setUnfoldingInfo`  unfolding
 557
 558         -- We no longer use 'must-inline' on record selectors.  They'll
 559         -- inline like crazy if they scrutinise a constructor
 560
 561     unfolding = mkTopUnfolding rhs
 562
 563     tyvars  = classTyVars clas
 564
 565     tycon      = classTyCon clas
 566     [data_con] = tyConDataCons tycon
 567     tyvar_tys  = mkTyVarTys tyvars
 568     arg_tys    = dataConArgTys data_con tyvar_tys
 569     the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
 570
 571     pred              = mkClassPred clas tyvar_tys
 572     (dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys)
 573
 574     rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
 575                              mkNewTypeBody tycon (head arg_tys) dict_id
 576         | otherwise        = mkLams tyvars $ Lam dict_id $
 577                              Case (Var dict_id) dict_id
 578                                   [(DataAlt data_con, arg_ids, Var the_arg_id)]
 579
 580 mkNewTypeBody tycon result_ty result_id
 581   | isRecursiveTyCon tycon      -- Recursive case; use a coerce
 582   = Note (Coerce result_ty (idType result_id)) (Var result_id)
 583   | otherwise                   -- Normal case
 584   = Var result_id
 585 \end{code}
 586
 587
 588 %************************************************************************
 589 %*                                                                      *
 590 \subsection{Primitive operations
 591 %*                                                                      *
 592 %************************************************************************
 593
 594 \begin{code}
 595 mkPrimOpId :: PrimOp -> Id
 596 mkPrimOpId prim_op
 597   = id
 598   where
 599     (tyvars,arg_tys,res_ty, arity, strict_info) = primOpSig prim_op
 600     ty   = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
 601     name = mkPrimOpIdName prim_op
 602     id   = mkGlobalId (PrimOpId prim_op) name ty info
 603
 604     info = noCafNoTyGenIdInfo
 605            `setSpecInfo`        rules
 606            `setCgArity`         arity
 607            `setArityInfo`       arity
 608            `setNewStrictnessInfo`       Just (mkNewStrictnessInfo id arity strict_info NoCPRInfo)
 609         -- Until we modify the primop generation code
 610
 611     rules = maybe emptyCoreRules (addRule emptyCoreRules id)
 612                 (primOpRule prim_op)
 613
 614
 615 -- For each ccall we manufacture a separate CCallOpId, giving it
 616 -- a fresh unique, a type that is correct for this particular ccall,
 617 -- and a CCall structure that gives the correct details about calling
 618 -- convention etc.
 619 --
 620 -- The *name* of this Id is a local name whose OccName gives the full
 621 -- details of the ccall, type and all.  This means that the interface
 622 -- file reader can reconstruct a suitable Id
 623
 624 mkFCallId :: Unique -> ForeignCall -> Type -> Id
 625 mkFCallId uniq fcall ty
 626   = ASSERT( isEmptyVarSet (tyVarsOfType ty) )
 627         -- A CCallOpId should have no free type variables;
 628         -- when doing substitutions won't substitute over it
 629     id
 630   where
 631     id = mkGlobalId (FCallId fcall) name ty info
 632     occ_str = showSDocIface (braces (ppr fcall <+> ppr ty))
 633         -- The "occurrence name" of a ccall is the full info about the
 634         -- ccall; it is encoded, but may have embedded spaces etc!
 635
 636     name = mkFCallName uniq occ_str
 637
 638     info = noCafNoTyGenIdInfo
 639            `setCgArity`                 arity
 640            `setArityInfo`               arity
 641            `setNewStrictnessInfo`       Just strict_sig
 642
 643     (_, tau)     = tcSplitForAllTys ty
 644     (arg_tys, _) = tcSplitFunTys tau
 645     arity        = length arg_tys
 646     strict_sig   = mkStrictSig id arity (mkTopDmdType (replicate arity evalDmd) TopRes)
 647 \end{code}
 648
 649
 650 %************************************************************************
 651 %*                                                                      *
 652 \subsection{DictFuns and default methods}
 653 %*                                                                      *
 654 %************************************************************************
 655
 656 \begin{code}
 657 mkDefaultMethodId dm_name ty
 658   = mkVanillaGlobal dm_name ty noCafNoTyGenIdInfo
 659
 660 mkDictFunId :: Name             -- Name to use for the dict fun;
 661             -> Class
 662             -> [TyVar]
 663             -> [Type]
 664             -> ThetaType
 665             -> Id
 666
 667 mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta
 668   = mkVanillaGlobal dfun_name dfun_ty noCafNoTyGenIdInfo
 669   where
 670     dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
 671
 672 {-  1 dec 99: disable the Mark Jones optimisation for the sake
 673     of compatibility with Hugs.
 674     See `types/InstEnv' for a discussion related to this.
 675
 676     (class_tyvars, sc_theta, _, _) = classBigSig clas
 677     not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
 678     sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
 679     dfun_theta = case inst_decl_theta of
 680                    []    -> []  -- If inst_decl_theta is empty, then we don't
 681                                 -- want to have any dict arguments, so that we can
 682                                 -- expose the constant methods.
 683
 684                    other -> nub (inst_decl_theta ++ filter not_const sc_theta')
 685                                 -- Otherwise we pass the superclass dictionaries to
 686                                 -- the dictionary function; the Mark Jones optimisation.
 687                                 --
 688                                 -- NOTE the "nub".  I got caught by this one:
 689                                 --   class Monad m => MonadT t m where ...
 690                                 --   instance Monad m => MonadT (EnvT env) m where ...
 691                                 -- Here, the inst_decl_theta has (Monad m); but so
 692                                 -- does the sc_theta'!
 693                                 --
 694                                 -- NOTE the "not_const".  I got caught by this one too:
 695                                 --   class Foo a => Baz a b where ...
 696                                 --   instance Wob b => Baz T b where..
 697                                 -- Now sc_theta' has Foo T
 698 -}
 699 \end{code}
 700
 701
 702 %************************************************************************
 703 %*                                                                      *
 704 \subsection{Un-definable}
 705 %*                                                                      *
 706 %************************************************************************
 707
 708 These two can't be defined in Haskell.
 709
 710 unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
 711 just gets expanded into a type coercion wherever it occurs.  Hence we
 712 add it as a built-in Id with an unfolding here.
 713
 714 The type variables we use here are "open" type variables: this means
 715 they can unify with both unlifted and lifted types.  Hence we provide
 716 another gun with which to shoot yourself in the foot.
 717
 718 \begin{code}
 719 unsafeCoerceId
 720   = pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info
 721   where
 722     info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
 723
 724
 725     ty  = mkForAllTys [openAlphaTyVar,openBetaTyVar]
 726                       (mkFunTy openAlphaTy openBetaTy)
 727     [x] = mkTemplateLocals [openAlphaTy]
 728     rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
 729           Note (Coerce openBetaTy openAlphaTy) (Var x)
 730 \end{code}
 731
 732
 733 @getTag#@ is another function which can't be defined in Haskell.  It needs to
 734 evaluate its argument and call the dataToTag# primitive.
 735
 736 \begin{code}
 737 getTagId
 738   = pcMiscPrelId getTagIdKey pREL_GHC SLIT("getTag#") ty info
 739   where
 740     info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
 741         -- We don't provide a defn for this; you must inline it
 742
 743     ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy intPrimTy)
 744     [x,y] = mkTemplateLocals [alphaTy,alphaTy]
 745     rhs = mkLams [alphaTyVar,x] $
 746           Case (Var x) y [ (DEFAULT, [], mkApps (Var dataToTagId) [Type alphaTy, Var y]) ]
 747
 748 dataToTagId = mkPrimOpId DataToTagOp
 749 \end{code}
 750
 751 @realWorld#@ used to be a magic literal, \tr{void#}.  If things get
 752 nasty as-is, change it back to a literal (@Literal@).
 753
 754 \begin{code}
 755 realWorldPrimId -- :: State# RealWorld
 756   = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#")
 757                  realWorldStatePrimTy
 758                  (noCafNoTyGenIdInfo `setUnfoldingInfo` mkOtherCon [])
 759         -- The mkOtherCon makes it look that realWorld# is evaluated
 760         -- which in turn makes Simplify.interestingArg return True,
 761         -- which in turn makes INLINE things applied to realWorld# likely
 762         -- to be inlined
 763 \end{code}
 764
 765
 766 %************************************************************************
 767 %*                                                                      *
 768 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
 769 %*                                                                      *
 770 %************************************************************************
 771
 772 GHC randomly injects these into the code.
 773
 774 @patError@ is just a version of @error@ for pattern-matching
 775 failures.  It knows various ``codes'' which expand to longer
 776 strings---this saves space!
 777
 778 @absentErr@ is a thing we put in for ``absent'' arguments.  They jolly
 779 well shouldn't be yanked on, but if one is, then you will get a
 780 friendly message from @absentErr@ (rather than a totally random
 781 crash).
 782
 783 @parError@ is a special version of @error@ which the compiler does
 784 not know to be a bottoming Id.  It is used in the @_par_@ and @_seq_@
 785 templates, but we don't ever expect to generate code for it.
 786
 787 \begin{code}
 788 eRROR_ID
 789   = pc_bottoming_Id errorIdKey pREL_ERR SLIT("error") errorTy
 790 pAT_ERROR_ID
 791   = generic_ERROR_ID patErrorIdKey SLIT("patError")
 792 rEC_SEL_ERROR_ID
 793   = generic_ERROR_ID recSelErrIdKey SLIT("recSelError")
 794 rEC_CON_ERROR_ID
 795   = generic_ERROR_ID recConErrorIdKey SLIT("recConError")
 796 rEC_UPD_ERROR_ID
 797   = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError")
 798 iRREFUT_PAT_ERROR_ID
 799   = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
 800 nON_EXHAUSTIVE_GUARDS_ERROR_ID
 801   = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError")
 802 nO_METHOD_BINDING_ERROR_ID
 803   = generic_ERROR_ID noMethodBindingErrorIdKey SLIT("noMethodBindingError")
 804
 805 aBSENT_ERROR_ID
 806   = pc_bottoming_Id absentErrorIdKey pREL_ERR SLIT("absentErr")
 807         (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
 808
 809 pAR_ERROR_ID
 810   = pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError")
 811     (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafNoTyGenIdInfo
 812 \end{code}
 813
 814
 815 %************************************************************************
 816 %*                                                                      *
 817 \subsection{Utilities}
 818 %*                                                                      *
 819 %************************************************************************
 820
 821 \begin{code}
 822 pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
 823 pcMiscPrelId key mod str ty info
 824   = let
 825         name = mkWiredInName mod (mkVarOcc str) key
 826         imp  = mkVanillaGlobal name ty info -- the usual case...
 827     in
 828     imp
 829     -- We lie and say the thing is imported; otherwise, we get into
 830     -- a mess with dependency analysis; e.g., core2stg may heave in
 831     -- random calls to GHCbase.unpackPS__.  If GHCbase is the module
 832     -- being compiled, then it's just a matter of luck if the definition
 833     -- will be in "the right place" to be in scope.
 834
 835 pc_bottoming_Id key mod name ty
 836  = id
 837  where
 838     id = pcMiscPrelId key mod name ty bottoming_info
 839     arity          = 1
 840     strict_sig     = mkStrictSig id arity (mkTopDmdType [evalDmd] BotRes)
 841     bottoming_info = noCafNoTyGenIdInfo `setNewStrictnessInfo` Just strict_sig
 842         -- these "bottom" out, no matter what their arguments
 843
 844 generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy
 845
 846 (openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars
 847 openAlphaTy  = mkTyVarTy openAlphaTyVar
 848 openBetaTy   = mkTyVarTy openBetaTyVar
 849
 850 errorTy  :: Type
 851 errorTy  = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy]
 852                                                    openAlphaTy)
 853     -- Notice the openAlphaTyVar.  It says that "error" can be applied
 854     -- to unboxed as well as boxed types.  This is OK because it never
 855     -- returns, so the return type is irrelevant.
 856 \end{code}
 857