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