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