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