ghc/compiler/basicTypes/MkId.lhs

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