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         mkSpecPragmaId, mkWorkerId,
  17
  18         mkDictFunId, mkDefaultMethodId,
  19         mkDictSelId,
  20
  21         mkDataConId,
  22         mkRecordSelId,
  23         mkNewTySelId,
  24         mkPrimitiveId,
  25
  26         -- And some particular Ids; see below for why they are wired in
  27         wiredInIds,
  28         unsafeCoerceId, realWorldPrimId,
  29         eRROR_ID, rEC_SEL_ERROR_ID, pAT_ERROR_ID, rEC_CON_ERROR_ID,
  30         rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID,
  31         nO_METHOD_BINDING_ERROR_ID, aBSENT_ERROR_ID, pAR_ERROR_ID
  32     ) where
  33
  34 #include "HsVersions.h"
  35
  36
  37 import TysPrim          ( openAlphaTyVars, alphaTyVar, alphaTy,
  38                           intPrimTy, realWorldStatePrimTy
  39                         )
  40 import TysWiredIn       ( boolTy, charTy, mkListTy )
  41 import PrelMods         ( pREL_ERR, pREL_GHC )
  42 import PrelRules        ( primOpRule )
  43 import Rules            ( addRule )
  44 import Type             ( Type, ClassContext, mkDictTy, mkTyConApp, mkTyVarTys,
  45                           mkFunTys, mkFunTy, mkSigmaTy, classesToPreds,
  46                           isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfTypes,
  47                           splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp,
  48                           splitFunTys, splitForAllTys, unUsgTy,
  49                           mkUsgTy, UsageAnn(..)
  50                         )
  51 import Module           ( Module )
  52 import CoreUnfold       ( mkTopUnfolding, mkCompulsoryUnfolding )
  53 import Subst            ( mkTopTyVarSubst, substClasses )
  54 import TyCon            ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon )
  55 import Class            ( Class, classBigSig, classTyCon, classTyVars, classSelIds )
  56 import Var              ( Id, TyVar )
  57 import VarSet           ( isEmptyVarSet )
  58 import Const            ( Con(..) )
  59 import Name             ( mkDerivedName, mkWiredInIdName, mkLocalName,
  60                           mkWorkerOcc, mkSuperDictSelOcc,
  61                           Name, NamedThing(..),
  62                         )
  63 import OccName          ( mkSrcVarOcc )
  64 import PrimOp           ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName, primOpArity, primOpStrictness )
  65 import Demand           ( wwStrict )
  66 import DataCon          ( DataCon, StrictnessMark(..), dataConStrictMarks, dataConFieldLabels,
  67                           dataConArgTys, dataConSig, dataConRawArgTys
  68                         )
  69 import Id               ( idType, mkId,
  70                           mkVanillaId, mkTemplateLocals,
  71                           mkTemplateLocal, setInlinePragma
  72                         )
  73 import IdInfo           ( vanillaIdInfo, mkIdInfo,
  74                           exactArity, setUnfoldingInfo, setCafInfo,
  75                           setArityInfo, setInlinePragInfo, setSpecInfo,
  76                           mkStrictnessInfo, setStrictnessInfo,
  77                           IdFlavour(..), InlinePragInfo(..), CafInfo(..), IdInfo
  78                         )
  79 import FieldLabel       ( FieldLabel, FieldLabelTag, mkFieldLabel, fieldLabelName,
  80                           firstFieldLabelTag, allFieldLabelTags
  81                         )
  82 import CoreSyn
  83 import Maybes
  84 import BasicTypes       ( Arity )
  85 import Unique
  86 import Maybe            ( isJust )
  87 import Outputable
  88 import Util             ( assoc )
  89 import List             ( nub )
  90 \end{code}
  91
  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 error-reporting
 107         --  functions that they have an 'open' result type. -- sof 1/99]
 108
 109       aBSENT_ERROR_ID
 110     , eRROR_ID
 111     , iRREFUT_PAT_ERROR_ID
 112     , nON_EXHAUSTIVE_GUARDS_ERROR_ID
 113     , nO_METHOD_BINDING_ERROR_ID
 114     , pAR_ERROR_ID
 115     , pAT_ERROR_ID
 116     , rEC_CON_ERROR_ID
 117     , rEC_UPD_ERROR_ID
 118
 119         -- These two can't be defined in Haskell
 120     , realWorldPrimId
 121     , unsafeCoerceId
 122     , getTagId
 123     ]
 124 \end{code}
 125
 126 %************************************************************************
 127 %*                                                                      *
 128 \subsection{Easy ones}
 129 %*                                                                      *
 130 %************************************************************************
 131
 132 \begin{code}
 133 mkSpecPragmaId occ uniq ty loc
 134   = mkId (mkLocalName uniq occ loc) ty (mkIdInfo SpecPragmaId)
 135         -- Maybe a SysLocal?  But then we'd lose the location
 136
 137 mkDefaultMethodId dm_name rec_c ty
 138   = mkVanillaId dm_name ty
 139
 140 mkWorkerId uniq unwrkr ty
 141   = mkVanillaId (mkDerivedName mkWorkerOcc (getName unwrkr) uniq) ty
 142 \end{code}
 143
 144 %************************************************************************
 145 %*                                                                      *
 146 \subsection{Data constructors}
 147 %*                                                                      *
 148 %************************************************************************
 149
 150 \begin{code}
 151 mkDataConId :: DataCon -> Id
 152 mkDataConId data_con
 153   = mkId (getName data_con)
 154          id_ty
 155          (dataConInfo data_con)
 156   where
 157     (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon) = dataConSig data_con
 158     id_ty = mkSigmaTy (tyvars ++ ex_tyvars)
 159                       (classesToPreds (theta ++ ex_theta))
 160                       (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)))
 161 \end{code}
 162
 163 We're going to build a constructor that looks like:
 164
 165         data (Data a, C b) =>  T a b = T1 !a !Int b
 166
 167         T1 = /\ a b ->
 168              \d1::Data a, d2::C b ->
 169              \p q r -> case p of { p ->
 170                        case q of { q ->
 171                        Con T1 [a,b] [p,q,r]}}
 172
 173 Notice that
 174
 175 * d2 is thrown away --- a context in a data decl is used to make sure
 176   one *could* construct dictionaries at the site the constructor
 177   is used, but the dictionary isn't actually used.
 178
 179 * We have to check that we can construct Data dictionaries for
 180   the types a and Int.  Once we've done that we can throw d1 away too.
 181
 182 * We use (case p of q -> ...) to evaluate p, rather than "seq" because
 183   all that matters is that the arguments are evaluated.  "seq" is
 184   very careful to preserve evaluation order, which we don't need
 185   to be here.
 186
 187   You might think that we could simply give constructors some strictness
 188   info, like PrimOps, and let CoreToStg do the let-to-case transformation.
 189   But we don't do that because in the case of primops and functions strictness
 190   is a *property* not a *requirement*.  In the case of constructors we need to
 191   do something active to evaluate the argument.
 192
 193   Making an explicit case expression allows the simplifier to eliminate
 194   it in the (common) case where the constructor arg is already evaluated.
 195
 196 \begin{code}
 197 dataConInfo :: DataCon -> IdInfo
 198
 199 dataConInfo data_con
 200   = mkIdInfo (ConstantId (DataCon data_con))
 201     `setArityInfo` exactArity (n_dicts + n_ex_dicts + n_id_args)
 202     `setUnfoldingInfo` unfolding
 203   where
 204         unfolding = mkTopUnfolding (Note InlineMe con_rhs)
 205         -- The dictionary constructors of a class don't get a binding,
 206         -- but they are always saturated, so they should always be inlined.
 207
 208         (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon)
 209            = dataConSig data_con
 210         rep_arg_tys = dataConRawArgTys data_con
 211         all_tyvars   = tyvars ++ ex_tyvars
 212
 213         dict_tys     = [mkDictTy clas tys | (clas,tys) <- theta]
 214         ex_dict_tys  = [mkDictTy clas tys | (clas,tys) <- ex_theta]
 215
 216         n_dicts      = length dict_tys
 217         n_ex_dicts   = length ex_dict_tys
 218         n_id_args    = length orig_arg_tys
 219         n_rep_args   = length rep_arg_tys
 220
 221         result_ty    = mkTyConApp tycon (mkTyVarTys tyvars)
 222
 223         mkLocals i n tys   = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
 224         (dict_args, i1)    = mkLocals 1  n_dicts    dict_tys
 225         (ex_dict_args,i2)  = mkLocals i1 n_ex_dicts ex_dict_tys
 226         (id_args,i3)       = mkLocals i2 n_id_args  orig_arg_tys
 227
 228         (id_arg1:_) = id_args           -- Used for newtype only
 229         strict_marks  = dataConStrictMarks data_con
 230
 231         con_app i rep_ids
 232                 | isNewTyCon tycon
 233                 = ASSERT( length orig_arg_tys == 1 )
 234                   Note (Coerce result_ty (head orig_arg_tys)) (Var id_arg1)
 235                 | otherwise
 236                 = mkConApp data_con
 237                         (map Type (mkTyVarTys all_tyvars) ++
 238                          map Var (reverse rep_ids))
 239
 240         con_rhs = mkLams all_tyvars $ mkLams dict_args $
 241                   mkLams ex_dict_args $ mkLams id_args $
 242                   foldr mk_case con_app
 243                      (zip (ex_dict_args++id_args) strict_marks) i3 []
 244
 245         mk_case
 246            :: (Id, StrictnessMark)      -- arg, strictness
 247            -> (Int -> [Id] -> CoreExpr) -- body
 248            -> Int                       -- next rep arg id
 249            -> [Id]                      -- rep args so far
 250            -> CoreExpr
 251         mk_case (arg,strict) body i rep_args
 252           = case strict of
 253                 NotMarkedStrict -> body i (arg:rep_args)
 254                 MarkedStrict
 255                    | isUnLiftedType (idType arg) -> body i (arg:rep_args)
 256                    | otherwise ->
 257                         Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))]
 258
 259                 MarkedUnboxed con tys ->
 260                    Case (Var arg) arg [(DataCon con, con_args,
 261                                         body i' (reverse con_args++rep_args))]
 262                    where n_tys = length tys
 263                          (con_args,i') = mkLocals i (length tys) tys
 264 \end{code}
 265
 266
 267 %************************************************************************
 268 %*                                                                      *
 269 \subsection{Record selectors}
 270 %*                                                                      *
 271 %************************************************************************
 272
 273 We're going to build a record selector unfolding that looks like this:
 274
 275         data T a b c = T1 { ..., op :: a, ...}
 276                      | T2 { ..., op :: a, ...}
 277                      | T3
 278
 279         sel = /\ a b c -> \ d -> case d of
 280                                     T1 ... x ... -> x
 281                                     T2 ... x ... -> x
 282                                     other        -> error "..."
 283
 284 \begin{code}
 285 mkRecordSelId field_label selector_ty
 286   = ASSERT( null theta && isDataTyCon tycon )
 287     sel_id
 288   where
 289     sel_id = mkId (fieldLabelName field_label) selector_ty info
 290
 291     info = mkIdInfo (RecordSelId field_label)
 292            `setArityInfo`       exactArity 1
 293            `setUnfoldingInfo`   unfolding
 294
 295         -- ToDo: consider adding further IdInfo
 296
 297     unfolding = mkTopUnfolding sel_rhs
 298
 299     (tyvars, theta, tau)  = splitSigmaTy selector_ty
 300     (data_ty,rhs_ty)      = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
 301                                         -- tau is of form (T a b c -> field-type)
 302     (tycon, _, data_cons) = splitAlgTyConApp data_ty
 303     tyvar_tys             = mkTyVarTys tyvars
 304
 305     [data_id] = mkTemplateLocals [data_ty]
 306     alts      = map mk_maybe_alt data_cons
 307     the_alts  = catMaybes alts
 308     default_alt | all isJust alts = []  -- No default needed
 309                 | otherwise       = [(DEFAULT, [], error_expr)]
 310
 311     sel_rhs   = mkLams tyvars $ Lam data_id $
 312                 Case (Var data_id) data_id (the_alts ++ default_alt)
 313
 314     mk_maybe_alt data_con
 315           = case maybe_the_arg_id of
 316                 Nothing         -> Nothing
 317                 Just the_arg_id -> Just (DataCon data_con, arg_ids, Var the_arg_id)
 318           where
 319             arg_ids          = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
 320                                     -- The first one will shadow data_id, but who cares
 321             field_lbls       = dataConFieldLabels data_con
 322             maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
 323
 324     error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy rhs_ty), mkStringLit full_msg]
 325        -- preserves invariant that type args are *not* usage-annotated on top.  KSW 1999-04.
 326     full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id])
 327 \end{code}
 328
 329
 330 %************************************************************************
 331 %*                                                                      *
 332 \subsection{Newtype field selectors}
 333 %*                                                                      *
 334 %************************************************************************
 335
 336 Possibly overkill to do it this way:
 337
 338 \begin{code}
 339 mkNewTySelId field_label selector_ty = sel_id
 340   where
 341     sel_id = mkId (fieldLabelName field_label) selector_ty info
 342
 343
 344     info = mkIdInfo (RecordSelId field_label)
 345            `setArityInfo`       exactArity 1
 346            `setUnfoldingInfo`   unfolding
 347
 348         -- ToDo: consider adding further IdInfo
 349
 350     unfolding = mkTopUnfolding sel_rhs
 351
 352     (tyvars, theta, tau)  = splitSigmaTy selector_ty
 353     (data_ty,rhs_ty)      = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
 354                                         -- tau is of form (T a b c -> field-type)
 355     (tycon, _, data_cons) = splitAlgTyConApp data_ty
 356     tyvar_tys             = mkTyVarTys tyvars
 357
 358     [data_id] = mkTemplateLocals [data_ty]
 359     sel_rhs   = mkLams tyvars $ Lam data_id $
 360                 Note (Coerce (unUsgTy rhs_ty) (unUsgTy data_ty)) (Var data_id)
 361 \end{code}
 362
 363
 364 %************************************************************************
 365 %*                                                                      *
 366 \subsection{Dictionary selectors}
 367 %*                                                                      *
 368 %************************************************************************
 369
 370 Selecting a field for a dictionary.  If there is just one field, then
 371 there's nothing to do.
 372
 373 \begin{code}
 374 mkDictSelId name clas ty
 375   = sel_id
 376   where
 377     sel_id    = mkId name ty info
 378     field_lbl = mkFieldLabel name ty tag
 379     tag       = assoc "MkId.mkDictSelId" (classSelIds clas `zip` allFieldLabelTags) sel_id
 380
 381     info      = mkIdInfo (RecordSelId field_lbl)
 382                 `setUnfoldingInfo`  unfolding
 383
 384         -- We no longer use 'must-inline' on record selectors.  They'll
 385         -- inline like crazy if they scrutinise a constructor
 386
 387     unfolding = mkTopUnfolding rhs
 388
 389     tyvars  = classTyVars clas
 390
 391     tycon      = classTyCon clas
 392     [data_con] = tyConDataCons tycon
 393     tyvar_tys  = mkTyVarTys tyvars
 394     arg_tys    = dataConArgTys data_con tyvar_tys
 395     the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
 396
 397     dict_ty    = mkDictTy clas tyvar_tys
 398     (dict_id:arg_ids) = mkTemplateLocals (dict_ty : arg_tys)
 399
 400     rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
 401                              Note (Coerce (head arg_tys) dict_ty) (Var dict_id)
 402         | otherwise        = mkLams tyvars $ Lam dict_id $
 403                              Case (Var dict_id) dict_id
 404                                   [(DataCon data_con, arg_ids, Var the_arg_id)]
 405 \end{code}
 406
 407
 408 %************************************************************************
 409 %*                                                                      *
 410 \subsection{Primitive operations
 411 %*                                                                      *
 412 %************************************************************************
 413
 414 \begin{code}
 415 mkPrimitiveId :: PrimOp -> Id
 416 mkPrimitiveId prim_op
 417   = id
 418   where
 419     (tyvars,arg_tys,res_ty) = primOpSig prim_op
 420     ty   = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
 421     name = mkPrimOpIdName prim_op id
 422     id   = mkId name ty info
 423
 424     info = mkIdInfo (ConstantId (PrimOp prim_op))
 425            `setUnfoldingInfo`   unfolding
 426
 427 -- Not yet...
 428 --         `setSpecInfo`        rules
 429 --         `setArityInfo`       exactArity arity
 430 --         `setStrictnessInfo`  strict_info
 431
 432     arity               = primOpArity prim_op
 433     (dmds, result_bot)  = primOpStrictness prim_op
 434     strict_info         = mkStrictnessInfo (take arity dmds, result_bot)
 435         -- primOpStrictness can return an infinite list of demands
 436         -- (cheap hack) but Ids mustn't have such things.
 437         -- What a mess.
 438
 439     rules = addRule id emptyCoreRules (primOpRule prim_op)
 440
 441     unfolding = mkCompulsoryUnfolding rhs
 442                 -- The mkCompulsoryUnfolding says that this Id absolutely
 443                 -- must be inlined.  It's only used for primitives,
 444                 -- because we don't want to make a closure for each of them.
 445
 446     args = mkTemplateLocals arg_tys
 447     rhs =  mkLams tyvars $ mkLams args $
 448            mkPrimApp prim_op (map Type (mkTyVarTys tyvars) ++ map Var args)
 449 \end{code}
 450
 451
 452 %************************************************************************
 453 %*                                                                      *
 454 \subsection{DictFuns}
 455 %*                                                                      *
 456 %************************************************************************
 457
 458 \begin{code}
 459 mkDictFunId :: Name             -- Name to use for the dict fun;
 460             -> Class
 461             -> [TyVar]
 462             -> [Type]
 463             -> ClassContext
 464             -> Id
 465
 466 mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
 467   = mkVanillaId dfun_name dfun_ty
 468   where
 469     (class_tyvars, sc_theta, _, _) = classBigSig clas
 470     sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
 471
 472     dfun_theta = classesToPreds inst_decl_theta
 473
 474 {-  1 dec 99: disable the Mark Jones optimisation for the sake
 475     of compatibility with Hugs.
 476     See `types/InstEnv' for a discussion related to this.
 477
 478     dfun_theta = case inst_decl_theta of
 479                    []    -> []  -- If inst_decl_theta is empty, then we don't
 480                                 -- want to have any dict arguments, so that we can
 481                                 -- expose the constant methods.
 482
 483                    other -> nub (inst_decl_theta ++ filter not_const sc_theta')
 484                                 -- Otherwise we pass the superclass dictionaries to
 485                                 -- the dictionary function; the Mark Jones optimisation.
 486                                 --
 487                                 -- NOTE the "nub".  I got caught by this one:
 488                                 --   class Monad m => MonadT t m where ...
 489                                 --   instance Monad m => MonadT (EnvT env) m where ...
 490                                 -- Here, the inst_decl_theta has (Monad m); but so
 491                                 -- does the sc_theta'!
 492                                 --
 493                                 -- NOTE the "not_const".  I got caught by this one too:
 494                                 --   class Foo a => Baz a b where ...
 495                                 --   instance Wob b => Baz T b where..
 496                                 -- Now sc_theta' has Foo T
 497 -}
 498     dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
 499
 500     not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
 501 \end{code}
 502
 503
 504 %************************************************************************
 505 %*                                                                      *
 506 \subsection{Un-definable}
 507 %*                                                                      *
 508 %************************************************************************
 509
 510 These two can't be defined in Haskell.
 511
 512 unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
 513 just gets expanded into a type coercion wherever it occurs.  Hence we
 514 add it as a built-in Id with an unfolding here.
 515
 516 The type variables we use here are "open" type variables: this means
 517 they can unify with both unlifted and lifted types.  Hence we provide
 518 another gun with which to shoot yourself in the foot.
 519
 520 \begin{code}
 521 unsafeCoerceId
 522   = pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info
 523   where
 524     info = vanillaIdInfo
 525            `setUnfoldingInfo` mkCompulsoryUnfolding rhs
 526
 527
 528     ty  = mkForAllTys [openAlphaTyVar,openBetaTyVar]
 529                       (mkFunTy openAlphaTy openBetaTy)
 530     [x] = mkTemplateLocals [openAlphaTy]
 531     rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
 532           Note (Coerce openBetaTy openAlphaTy) (Var x)
 533 \end{code}
 534
 535
 536 @getTag#@ is another function which can't be defined in Haskell.  It needs to
 537 evaluate its argument and call the dataToTag# primitive.
 538
 539 \begin{code}
 540 getTagId
 541   = pcMiscPrelId getTagIdKey pREL_GHC SLIT("getTag#") ty info
 542   where
 543     info = vanillaIdInfo
 544            `setUnfoldingInfo`   mkCompulsoryUnfolding rhs
 545         -- We don't provide a defn for this; you must inline it
 546
 547     ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy intPrimTy)
 548     [x,y] = mkTemplateLocals [alphaTy,alphaTy]
 549     rhs = mkLams [alphaTyVar,x] $
 550           Case (Var x) y [ (DEFAULT, [],
 551                    Con (PrimOp DataToTagOp) [Type alphaTy, Var y]) ]
 552 \end{code}
 553
 554 @realWorld#@ used to be a magic literal, \tr{void#}.  If things get
 555 nasty as-is, change it back to a literal (@Literal@).
 556
 557 \begin{code}
 558 realWorldPrimId -- :: State# RealWorld
 559   = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#")
 560                  realWorldStatePrimTy
 561                  noCafIdInfo
 562 \end{code}
 563
 564
 565 %************************************************************************
 566 %*                                                                      *
 567 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
 568 %*                                                                      *
 569 %************************************************************************
 570
 571 GHC randomly injects these into the code.
 572
 573 @patError@ is just a version of @error@ for pattern-matching
 574 failures.  It knows various ``codes'' which expand to longer
 575 strings---this saves space!
 576
 577 @absentErr@ is a thing we put in for ``absent'' arguments.  They jolly
 578 well shouldn't be yanked on, but if one is, then you will get a
 579 friendly message from @absentErr@ (rather than a totally random
 580 crash).
 581
 582 @parError@ is a special version of @error@ which the compiler does
 583 not know to be a bottoming Id.  It is used in the @_par_@ and @_seq_@
 584 templates, but we don't ever expect to generate code for it.
 585
 586 \begin{code}
 587 eRROR_ID
 588   = pc_bottoming_Id errorIdKey pREL_ERR SLIT("error") errorTy
 589 rEC_SEL_ERROR_ID
 590   = generic_ERROR_ID recSelErrIdKey SLIT("patError")
 591 pAT_ERROR_ID
 592   = generic_ERROR_ID patErrorIdKey SLIT("patError")
 593 rEC_CON_ERROR_ID
 594   = generic_ERROR_ID recConErrorIdKey SLIT("recConError")
 595 rEC_UPD_ERROR_ID
 596   = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError")
 597 iRREFUT_PAT_ERROR_ID
 598   = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
 599 nON_EXHAUSTIVE_GUARDS_ERROR_ID
 600   = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError")
 601 nO_METHOD_BINDING_ERROR_ID
 602   = generic_ERROR_ID noMethodBindingErrorIdKey SLIT("noMethodBindingError")
 603
 604 aBSENT_ERROR_ID
 605   = pc_bottoming_Id absentErrorIdKey pREL_ERR SLIT("absentErr")
 606         (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
 607
 608 pAR_ERROR_ID
 609   = pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError")
 610     (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafIdInfo
 611
 612 \end{code}
 613
 614
 615 %************************************************************************
 616 %*                                                                      *
 617 \subsection{Utilities}
 618 %*                                                                      *
 619 %************************************************************************
 620
 621 \begin{code}
 622 pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
 623 pcMiscPrelId key mod str ty info
 624   = let
 625         name = mkWiredInIdName key mod (mkSrcVarOcc str) imp
 626         imp  = mkId name ty info -- the usual case...
 627     in
 628     imp
 629     -- We lie and say the thing is imported; otherwise, we get into
 630     -- a mess with dependency analysis; e.g., core2stg may heave in
 631     -- random calls to GHCbase.unpackPS__.  If GHCbase is the module
 632     -- being compiled, then it's just a matter of luck if the definition
 633     -- will be in "the right place" to be in scope.
 634
 635 pc_bottoming_Id key mod name ty
 636  = pcMiscPrelId key mod name ty bottoming_info
 637  where
 638     bottoming_info = noCafIdInfo
 639                      `setStrictnessInfo` mkStrictnessInfo ([wwStrict], True)
 640
 641         -- these "bottom" out, no matter what their arguments
 642
 643 generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy
 644
 645 -- Very useful...
 646 noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs
 647
 648 (openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars
 649 openAlphaTy  = mkTyVarTy openAlphaTyVar
 650 openBetaTy   = mkTyVarTy openBetaTyVar
 651
 652 errorTy  :: Type
 653 errorTy  = mkUsgTy UsMany $
 654            mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkUsgTy UsOnce (mkListTy charTy)]
 655                                                    (mkUsgTy UsMany openAlphaTy))
 656     -- Notice the openAlphaTyVar.  It says that "error" can be applied
 657     -- to unboxed as well as boxed types.  This is OK because it never
 658     -- returns, so the return type is irrelevant.
 659 \end{code}
 660