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