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