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, mkPredTy,
  48                           mkTyConApp, mkTyVarTys, mkClassPred, tcEqPred,
  49                           mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy,
  50                           isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
  51                           tcSplitFunTys, tcSplitForAllTys
  52                         )
  53 import CoreUtils        ( exprType )
  54 import CoreUnfold       ( mkTopUnfolding, mkCompulsoryUnfolding )
  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, dataConStupidTheta,
  68                           dataConSig, dataConStrictMarks, dataConExStricts,
  69                           splitProductType, isVanillaDataCon
  70                         )
  71 import Id               ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
  72                           mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
  73                           mkTemplateLocal, idName
  74                         )
  75 import IdInfo           ( IdInfo, noCafIdInfo,  setUnfoldingInfo,
  76                           setArityInfo, setSpecInfo, setCafInfo,
  77                           setAllStrictnessInfo, vanillaIdInfo,
  78                           GlobalIdDetails(..), CafInfo(..)
  79                         )
  80 import NewDemand        ( mkStrictSig, DmdResult(..),
  81                           mkTopDmdType, topDmd, evalDmd, lazyDmd, retCPR,
  82                           Demand(..), Demands(..) )
  83 import DmdAnal          ( dmdAnalTopRhs )
  84 import CoreSyn
  85 import Unique           ( mkBuiltinUnique, mkPrimOpIdUnique )
  86 import Maybes
  87 import PrelNames
  88 import Util             ( dropList, isSingleton )
  89 import Outputable
  90 import FastString
  91 import ListSetOps       ( assoc, assocMaybe )
  92 import List             ( nubBy )
  93 \end{code}
  94
  95 %************************************************************************
  96 %*                                                                      *
  97 \subsection{Wired in Ids}
  98 %*                                                                      *
  99 %************************************************************************
 100
 101 \begin{code}
 102 wiredInIds
 103   = [   -- These error-y things are wired in because we don't yet have
 104         -- a way to express in an interface file that the result type variable
 105         -- is 'open'; that is can be unified with an unboxed type
 106         --
 107         -- [The interface file format now carry such information, but there's
 108         -- no way yet of expressing at the definition site for these
 109         -- error-reporting functions that they have an 'open'
 110         -- result type. -- sof 1/99]
 111
 112     eRROR_ID,   -- This one isn't used anywhere else in the compiler
 113                 -- But we still need it in wiredInIds so that when GHC
 114                 -- compiles a program that mentions 'error' we don't
 115                 -- import its type from the interface file; we just get
 116                 -- the Id defined here.  Which has an 'open-tyvar' type.
 117
 118     rUNTIME_ERROR_ID,
 119     iRREFUT_PAT_ERROR_ID,
 120     nON_EXHAUSTIVE_GUARDS_ERROR_ID,
 121     nO_METHOD_BINDING_ERROR_ID,
 122     pAT_ERROR_ID,
 123     rEC_CON_ERROR_ID,
 124
 125     lazyId
 126     ] ++ ghcPrimIds
 127
 128 -- These Ids are exported from GHC.Prim
 129 ghcPrimIds
 130   = [   -- These can't be defined in Haskell, but they have
 131         -- perfectly reasonable unfoldings in Core
 132     realWorldPrimId,
 133     unsafeCoerceId,
 134     nullAddrId,
 135     seqId
 136     ]
 137 \end{code}
 138
 139 %************************************************************************
 140 %*                                                                      *
 141 \subsection{Data constructors}
 142 %*                                                                      *
 143 %************************************************************************
 144
 145 The wrapper for a constructor is an ordinary top-level binding that evaluates
 146 any strict args, unboxes any args that are going to be flattened, and calls
 147 the worker.
 148
 149 We're going to build a constructor that looks like:
 150
 151         data (Data a, C b) =>  T a b = T1 !a !Int b
 152
 153         T1 = /\ a b ->
 154              \d1::Data a, d2::C b ->
 155              \p q r -> case p of { p ->
 156                        case q of { q ->
 157                        Con T1 [a,b] [p,q,r]}}
 158
 159 Notice that
 160
 161 * d2 is thrown away --- a context in a data decl is used to make sure
 162   one *could* construct dictionaries at the site the constructor
 163   is used, but the dictionary isn't actually used.
 164
 165 * We have to check that we can construct Data dictionaries for
 166   the types a and Int.  Once we've done that we can throw d1 away too.
 167
 168 * We use (case p of q -> ...) to evaluate p, rather than "seq" because
 169   all that matters is that the arguments are evaluated.  "seq" is
 170   very careful to preserve evaluation order, which we don't need
 171   to be here.
 172
 173   You might think that we could simply give constructors some strictness
 174   info, like PrimOps, and let CoreToStg do the let-to-case transformation.
 175   But we don't do that because in the case of primops and functions strictness
 176   is a *property* not a *requirement*.  In the case of constructors we need to
 177   do something active to evaluate the argument.
 178
 179   Making an explicit case expression allows the simplifier to eliminate
 180   it in the (common) case where the constructor arg is already evaluated.
 181
 182
 183 \begin{code}
 184 mkDataConIds :: Name -> Name -> DataCon -> DataConIds
 185         -- Makes the *worker* for the data constructor; that is, the function
 186         -- that takes the reprsentation arguments and builds the constructor.
 187 mkDataConIds wrap_name wkr_name data_con
 188   | isNewTyCon tycon
 189   = NewDC nt_wrap_id
 190
 191   | any isMarkedStrict all_strict_marks         -- Algebraic, needs wrapper
 192   = AlgDC (Just alg_wrap_id) wrk_id
 193
 194   | otherwise                                   -- Algebraic, no wrapper
 195   = AlgDC Nothing wrk_id
 196   where
 197     (tyvars, theta, orig_arg_tys, tycon, res_tys) = dataConSig data_con
 198
 199     dict_tys    = mkPredTys theta
 200     all_arg_tys = dict_tys ++ orig_arg_tys
 201     result_ty   = mkTyConApp tycon res_tys
 202
 203     wrap_ty = mkForAllTys tyvars (mkFunTys all_arg_tys result_ty)
 204         -- We used to include the stupid theta in the wrapper's args
 205         -- but now we don't.  Instead the type checker just injects these
 206         -- extra constraints where necessary.
 207
 208         ----------- Worker (algebraic data types only) --------------
 209     wrk_id = mkGlobalId (DataConWorkId data_con) wkr_name
 210                         (dataConRepType data_con) wkr_info
 211
 212     wkr_arity = dataConRepArity data_con
 213     wkr_info  = noCafIdInfo
 214                 `setArityInfo`          wkr_arity
 215                 `setAllStrictnessInfo`  Just wkr_sig
 216                 `setUnfoldingInfo`      evaldUnfolding  -- Record that it's evaluated,
 217                                                         -- even if arity = 0
 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                         Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))]
 309
 310                 MarkedUnboxed
 311                    -> case splitProductType "do_unbox" (idType arg) of
 312                            (tycon, tycon_args, con, tys) ->
 313                                    Case (Var arg) arg result_ty
 314                                         [(DataAlt con,
 315                                           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     = mkPredTys (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                       = mkPredTys 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          -- Already sorted by data-con
 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         = ASSERT( dc_tyvars == tyvars )
 484                 -- The only non-vanilla case we allow is when we have an existential
 485                 -- context that binds no type variables, thus
 486                 --      data T a = (?v::Int) => MkT a
 487                 -- In the non-vanilla case, the pattern must bind type variables and
 488                 -- the context stuff; hence the arg_prefix binding below
 489
 490           case maybe_the_arg_id of
 491                 Nothing         -> Nothing
 492                 Just the_arg_id -> Just (mkReboxingAlt uniqs data_con (arg_prefix ++ arg_src_ids) $
 493                                          mk_result (Var the_arg_id))
 494         where
 495             (dc_tyvars, dc_theta, dc_arg_tys, _, _) = dataConSig data_con
 496             arg_src_ids = mkTemplateLocalsNum arg_base dc_arg_tys
 497             arg_base'   = arg_base + length arg_src_ids
 498             arg_prefix  | isVanillaDataCon data_con = []
 499                         | otherwise = tyvars ++ mkTemplateLocalsNum arg_base' (mkPredTys dc_theta)
 500
 501             unpack_base = arg_base' + length dc_theta
 502             uniqs = map mkBuiltinUnique [unpack_base..]
 503
 504             maybe_the_arg_id  = assocMaybe (field_lbls `zip` arg_src_ids) field_label
 505             field_lbls        = dataConFieldLabels data_con
 506
 507     error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg
 508     full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id])
 509
 510
 511 -- (mkReboxingAlt us con xs rhs) basically constructs the case
 512 -- alternative  (con, xs, rhs)
 513 -- but it does the reboxing necessary to construct the *source*
 514 -- arguments, xs, from the representation arguments ys.
 515 -- For example:
 516 --      data T = MkT !(Int,Int) Bool
 517 --
 518 -- mkReboxingAlt MkT [x,b] r
 519 --      = (DataAlt MkT, [y::Int,z::Int,b], let x = (y,z) in r)
 520 --
 521 -- mkDataAlt should really be in DataCon, but it can't because
 522 -- it manipulates CoreSyn.
 523
 524 mkReboxingAlt
 525   :: [Unique]                   -- Uniques for the new Ids
 526   -> DataCon
 527   -> [Var]                      -- Source-level args, including existential dicts
 528   -> CoreExpr                   -- RHS
 529   -> CoreAlt
 530
 531 mkReboxingAlt us con args rhs
 532   | not (any isMarkedUnboxed stricts)
 533   = (DataAlt con, args, rhs)
 534
 535   | otherwise
 536   = let
 537         (binds, args') = go args stricts us
 538     in
 539     (DataAlt con, args', mkLets binds rhs)
 540
 541   where
 542     stricts = dataConExStricts con ++ dataConStrictMarks con
 543
 544     go [] stricts us = ([], [])
 545
 546         -- Type variable case
 547     go (arg:args) stricts us
 548       | isTyVar arg
 549       = let (binds, args') = go args stricts us
 550         in  (binds, arg:args')
 551
 552         -- Term variable case
 553     go (arg:args) (str:stricts) us
 554       | isMarkedUnboxed str
 555       = let
 556           (_, tycon_args, pack_con, con_arg_tys)
 557                  = splitProductType "mkReboxingAlt" (idType arg)
 558
 559           unpacked_args  = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
 560           (binds, args') = go args stricts (dropList con_arg_tys us)
 561           con_app        = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
 562         in
 563         (NonRec arg con_app : binds, unpacked_args ++ args')
 564
 565       | otherwise
 566       = let (binds, args') = go args stricts us
 567         in  (binds, arg:args')
 568 \end{code}
 569
 570
 571 %************************************************************************
 572 %*                                                                      *
 573 \subsection{Dictionary selectors}
 574 %*                                                                      *
 575 %************************************************************************
 576
 577 Selecting a field for a dictionary.  If there is just one field, then
 578 there's nothing to do.
 579
 580 Dictionary selectors may get nested forall-types.  Thus:
 581
 582         class Foo a where
 583           op :: forall b. Ord b => a -> b -> b
 584
 585 Then the top-level type for op is
 586
 587         op :: forall a. Foo a =>
 588               forall b. Ord b =>
 589               a -> b -> b
 590
 591 This is unlike ordinary record selectors, which have all the for-alls
 592 at the outside.  When dealing with classes it's very convenient to
 593 recover the original type signature from the class op selector.
 594
 595 \begin{code}
 596 mkDictSelId :: Name -> Class -> Id
 597 mkDictSelId name clas
 598   = mkGlobalId (ClassOpId clas) name sel_ty info
 599   where
 600     sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id))
 601         -- We can't just say (exprType rhs), because that would give a type
 602         --      C a -> C a
 603         -- for a single-op class (after all, the selector is the identity)
 604         -- But it's type must expose the representation of the dictionary
 605         -- to gat (say)         C a -> (a -> a)
 606
 607     info = noCafIdInfo
 608                 `setArityInfo`          1
 609                 `setUnfoldingInfo`      mkTopUnfolding rhs
 610                 `setAllStrictnessInfo`  Just strict_sig
 611
 612         -- We no longer use 'must-inline' on record selectors.  They'll
 613         -- inline like crazy if they scrutinise a constructor
 614
 615         -- The strictness signature is of the form U(AAAVAAAA) -> T
 616         -- where the V depends on which item we are selecting
 617         -- It's worth giving one, so that absence info etc is generated
 618         -- even if the selector isn't inlined
 619     strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes)
 620     arg_dmd | isNewTyCon tycon = evalDmd
 621             | otherwise        = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
 622                                             | id <- arg_ids ])
 623
 624     tycon      = classTyCon clas
 625     [data_con] = tyConDataCons tycon
 626     tyvars     = dataConTyVars data_con
 627     arg_tys    = dataConRepArgTys data_con
 628     the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name
 629
 630     pred              = mkClassPred clas (mkTyVarTys tyvars)
 631     (dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys)
 632
 633     rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
 634                              mkNewTypeBody tycon (head arg_tys) (Var dict_id)
 635         | otherwise        = mkLams tyvars $ Lam dict_id $
 636                              Case (Var dict_id) dict_id (idType the_arg_id)
 637                                   [(DataAlt data_con, arg_ids, Var the_arg_id)]
 638
 639 mkNewTypeBody tycon result_ty result_expr
 640         -- Adds a coerce where necessary
 641         -- Used for both wrapping and unwrapping
 642   | isRecursiveTyCon tycon      -- Recursive case; use a coerce
 643   = Note (Coerce result_ty (exprType result_expr)) result_expr
 644   | otherwise                   -- Normal case
 645   = result_expr
 646 \end{code}
 647
 648
 649 %************************************************************************
 650 %*                                                                      *
 651 \subsection{Primitive operations
 652 %*                                                                      *
 653 %************************************************************************
 654
 655 \begin{code}
 656 mkPrimOpId :: PrimOp -> Id
 657 mkPrimOpId prim_op
 658   = id
 659   where
 660     (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op
 661     ty   = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
 662     name = mkWiredInName gHC_PRIM (primOpOcc prim_op)
 663                          (mkPrimOpIdUnique (primOpTag prim_op))
 664                          Nothing (AnId id) UserSyntax
 665     id   = mkGlobalId (PrimOpId prim_op) name ty info
 666
 667     info = noCafIdInfo
 668            `setSpecInfo`        rules
 669            `setArityInfo`       arity
 670            `setAllStrictnessInfo` Just strict_sig
 671
 672     rules = foldl (addRule id) emptyCoreRules (primOpRules prim_op)
 673
 674
 675 -- For each ccall we manufacture a separate CCallOpId, giving it
 676 -- a fresh unique, a type that is correct for this particular ccall,
 677 -- and a CCall structure that gives the correct details about calling
 678 -- convention etc.
 679 --
 680 -- The *name* of this Id is a local name whose OccName gives the full
 681 -- details of the ccall, type and all.  This means that the interface
 682 -- file reader can reconstruct a suitable Id
 683
 684 mkFCallId :: Unique -> ForeignCall -> Type -> Id
 685 mkFCallId uniq fcall ty
 686   = ASSERT( isEmptyVarSet (tyVarsOfType ty) )
 687         -- A CCallOpId should have no free type variables;
 688         -- when doing substitutions won't substitute over it
 689     mkGlobalId (FCallId fcall) name ty info
 690   where
 691     occ_str = showSDoc (braces (ppr fcall <+> ppr ty))
 692         -- The "occurrence name" of a ccall is the full info about the
 693         -- ccall; it is encoded, but may have embedded spaces etc!
 694
 695     name = mkFCallName uniq occ_str
 696
 697     info = noCafIdInfo
 698            `setArityInfo`               arity
 699            `setAllStrictnessInfo`       Just strict_sig
 700
 701     (_, tau)     = tcSplitForAllTys ty
 702     (arg_tys, _) = tcSplitFunTys tau
 703     arity        = length arg_tys
 704     strict_sig   = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
 705 \end{code}
 706
 707
 708 %************************************************************************
 709 %*                                                                      *
 710 \subsection{DictFuns and default methods}
 711 %*                                                                      *
 712 %************************************************************************
 713
 714 Important notes about dict funs and default methods
 715 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 716 Dict funs and default methods are *not* ImplicitIds.  Their definition
 717 involves user-written code, so we can't figure out their strictness etc
 718 based on fixed info, as we can for constructors and record selectors (say).
 719
 720 We build them as GlobalIds, but when in the module where they are
 721 bound, we turn the Id at the *binding site* into an exported LocalId.
 722 This ensures that they are taken to account by free-variable finding
 723 and dependency analysis (e.g. CoreFVs.exprFreeVars).   The simplifier
 724 will propagate the LocalId to all occurrence sites.
 725
 726 Why shouldn't they be bound as GlobalIds?  Because, in particular, if
 727 they are globals, the specialiser floats dict uses above their defns,
 728 which prevents good simplifications happening.  Also the strictness
 729 analyser treats a occurrence of a GlobalId as imported and assumes it
 730 contains strictness in its IdInfo, which isn't true if the thing is
 731 bound in the same module as the occurrence.
 732
 733 It's OK for dfuns to be LocalIds, because we form the instance-env to
 734 pass on to the next module (md_insts) in CoreTidy, afer tidying
 735 and globalising the top-level Ids.
 736
 737 BUT make sure they are *exported* LocalIds (mkExportedLocalId) so
 738 that they aren't discarded by the occurrence analyser.
 739
 740 \begin{code}
 741 mkDefaultMethodId dm_name ty = mkExportedLocalId dm_name ty
 742
 743 mkDictFunId :: Name             -- Name to use for the dict fun;
 744             -> [TyVar]
 745             -> ThetaType
 746             -> Class
 747             -> [Type]
 748             -> Id
 749
 750 mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys
 751   = mkExportedLocalId dfun_name dfun_ty
 752   where
 753     dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
 754
 755 {-  1 dec 99: disable the Mark Jones optimisation for the sake
 756     of compatibility with Hugs.
 757     See `types/InstEnv' for a discussion related to this.
 758
 759     (class_tyvars, sc_theta, _, _) = classBigSig clas
 760     not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
 761     sc_theta' = substClasses (zipTopTvSubst class_tyvars inst_tys) sc_theta
 762     dfun_theta = case inst_decl_theta of
 763                    []    -> []  -- If inst_decl_theta is empty, then we don't
 764                                 -- want to have any dict arguments, so that we can
 765                                 -- expose the constant methods.
 766
 767                    other -> nub (inst_decl_theta ++ filter not_const sc_theta')
 768                                 -- Otherwise we pass the superclass dictionaries to
 769                                 -- the dictionary function; the Mark Jones optimisation.
 770                                 --
 771                                 -- NOTE the "nub".  I got caught by this one:
 772                                 --   class Monad m => MonadT t m where ...
 773                                 --   instance Monad m => MonadT (EnvT env) m where ...
 774                                 -- Here, the inst_decl_theta has (Monad m); but so
 775                                 -- does the sc_theta'!
 776                                 --
 777                                 -- NOTE the "not_const".  I got caught by this one too:
 778                                 --   class Foo a => Baz a b where ...
 779                                 --   instance Wob b => Baz T b where..
 780                                 -- Now sc_theta' has Foo T
 781 -}
 782 \end{code}
 783
 784
 785 %************************************************************************
 786 %*                                                                      *
 787 \subsection{Un-definable}
 788 %*                                                                      *
 789 %************************************************************************
 790
 791 These Ids can't be defined in Haskell.  They could be defined in
 792 unfoldings in the wired-in GHC.Prim interface file, but we'd have to
 793 ensure that they were definitely, definitely inlined, because there is
 794 no curried identifier for them.  That's what mkCompulsoryUnfolding
 795 does.  If we had a way to get a compulsory unfolding from an interface
 796 file, we could do that, but we don't right now.
 797
 798 unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
 799 just gets expanded into a type coercion wherever it occurs.  Hence we
 800 add it as a built-in Id with an unfolding here.
 801
 802 The type variables we use here are "open" type variables: this means
 803 they can unify with both unlifted and lifted types.  Hence we provide
 804 another gun with which to shoot yourself in the foot.
 805
 806 \begin{code}
 807 mkWiredInIdName mod fs uniq id
 808  = mkWiredInName mod (mkOccFS varName fs) uniq Nothing (AnId id) UserSyntax
 809
 810 unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceIdKey  unsafeCoerceId
 811 nullAddrName     = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#")     nullAddrIdKey      nullAddrId
 812 seqName          = mkWiredInIdName gHC_PRIM FSLIT("seq")           seqIdKey           seqId
 813 realWorldName    = mkWiredInIdName gHC_PRIM FSLIT("realWorld#")    realWorldPrimIdKey realWorldPrimId
 814 lazyIdName       = mkWiredInIdName pREL_BASE FSLIT("lazy")         lazyIdKey          lazyId
 815
 816 errorName                = mkWiredInIdName pREL_ERR FSLIT("error")           errorIdKey eRROR_ID
 817 recSelErrorName          = mkWiredInIdName pREL_ERR FSLIT("recSelError")     recSelErrorIdKey rEC_SEL_ERROR_ID
 818 runtimeErrorName         = mkWiredInIdName pREL_ERR FSLIT("runtimeError")    runtimeErrorIdKey rUNTIME_ERROR_ID
 819 irrefutPatErrorName      = mkWiredInIdName pREL_ERR FSLIT("irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
 820 recConErrorName          = mkWiredInIdName pREL_ERR FSLIT("recConError")     recConErrorIdKey rEC_CON_ERROR_ID
 821 patErrorName             = mkWiredInIdName pREL_ERR FSLIT("patError")        patErrorIdKey pAT_ERROR_ID
 822 noMethodBindingErrorName = mkWiredInIdName pREL_ERR FSLIT("noMethodBindingError")
 823                                            noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
 824 nonExhaustiveGuardsErrorName
 825   = mkWiredInIdName pREL_ERR FSLIT("nonExhaustiveGuardsError")
 826                     nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
 827 \end{code}
 828
 829 \begin{code}
 830 -- unsafeCoerce# :: forall a b. a -> b
 831 unsafeCoerceId
 832   = pcMiscPrelId unsafeCoerceName ty info
 833   where
 834     info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
 835
 836
 837     ty  = mkForAllTys [openAlphaTyVar,openBetaTyVar]
 838                       (mkFunTy openAlphaTy openBetaTy)
 839     [x] = mkTemplateLocals [openAlphaTy]
 840     rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
 841           Note (Coerce openBetaTy openAlphaTy) (Var x)
 842
 843 -- nullAddr# :: Addr#
 844 -- The reason is is here is because we don't provide
 845 -- a way to write this literal in Haskell.
 846 nullAddrId
 847   = pcMiscPrelId nullAddrName addrPrimTy info
 848   where
 849     info = noCafIdInfo `setUnfoldingInfo`
 850            mkCompulsoryUnfolding (Lit nullAddrLit)
 851
 852 seqId
 853   = pcMiscPrelId seqName ty info
 854   where
 855     info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
 856
 857
 858     ty  = mkForAllTys [alphaTyVar,openBetaTyVar]
 859                       (mkFunTy alphaTy (mkFunTy openBetaTy openBetaTy))
 860     [x,y] = mkTemplateLocals [alphaTy, openBetaTy]
 861 -- gaw 2004
 862     rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x openBetaTy [(DEFAULT, [], Var y)])
 863
 864 -- lazy :: forall a?. a? -> a?   (i.e. works for unboxed types too)
 865 -- Used to lazify pseq:         pseq a b = a `seq` lazy b
 866 -- No unfolding: it gets "inlined" by the worker/wrapper pass
 867 -- Also, no strictness: by being a built-in Id, it overrides all
 868 -- the info in PrelBase.hi.  This is important, because the strictness
 869 -- analyser will spot it as strict!
 870 lazyId
 871   = pcMiscPrelId lazyIdName ty info
 872   where
 873     info = noCafIdInfo
 874     ty  = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
 875
 876 lazyIdUnfolding :: CoreExpr     -- Used to expand LazyOp after strictness anal
 877 lazyIdUnfolding = mkLams [openAlphaTyVar,x] (Var x)
 878                 where
 879                   [x] = mkTemplateLocals [openAlphaTy]
 880 \end{code}
 881
 882 @realWorld#@ used to be a magic literal, \tr{void#}.  If things get
 883 nasty as-is, change it back to a literal (@Literal@).
 884
 885 voidArgId is a Local Id used simply as an argument in functions
 886 where we just want an arg to avoid having a thunk of unlifted type.
 887 E.g.
 888         x = \ void :: State# RealWorld -> (# p, q #)
 889
 890 This comes up in strictness analysis
 891
 892 \begin{code}
 893 realWorldPrimId -- :: State# RealWorld
 894   = pcMiscPrelId realWorldName realWorldStatePrimTy
 895                  (noCafIdInfo `setUnfoldingInfo` evaldUnfolding)
 896         -- The evaldUnfolding makes it look that realWorld# is evaluated
 897         -- which in turn makes Simplify.interestingArg return True,
 898         -- which in turn makes INLINE things applied to realWorld# likely
 899         -- to be inlined
 900
 901 voidArgId       -- :: State# RealWorld
 902   = mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy
 903 \end{code}
 904
 905
 906 %************************************************************************
 907 %*                                                                      *
 908 \subsection[PrelVals-error-related]{@error@ and friends; @trace@}
 909 %*                                                                      *
 910 %************************************************************************
 911
 912 GHC randomly injects these into the code.
 913
 914 @patError@ is just a version of @error@ for pattern-matching
 915 failures.  It knows various ``codes'' which expand to longer
 916 strings---this saves space!
 917
 918 @absentErr@ is a thing we put in for ``absent'' arguments.  They jolly
 919 well shouldn't be yanked on, but if one is, then you will get a
 920 friendly message from @absentErr@ (rather than a totally random
 921 crash).
 922
 923 @parError@ is a special version of @error@ which the compiler does
 924 not know to be a bottoming Id.  It is used in the @_par_@ and @_seq_@
 925 templates, but we don't ever expect to generate code for it.
 926
 927 \begin{code}
 928 mkRuntimeErrorApp
 929         :: Id           -- Should be of type (forall a. Addr# -> a)
 930                         --      where Addr# points to a UTF8 encoded string
 931         -> Type         -- The type to instantiate 'a'
 932         -> String       -- The string to print
 933         -> CoreExpr
 934
 935 mkRuntimeErrorApp err_id res_ty err_msg
 936   = mkApps (Var err_id) [Type res_ty, err_string]
 937   where
 938     err_string = Lit (mkStringLit err_msg)
 939
 940 rEC_SEL_ERROR_ID                = mkRuntimeErrorId recSelErrorName
 941 rUNTIME_ERROR_ID                = mkRuntimeErrorId runtimeErrorName
 942 iRREFUT_PAT_ERROR_ID            = mkRuntimeErrorId irrefutPatErrorName
 943 rEC_CON_ERROR_ID                = mkRuntimeErrorId recConErrorName
 944 pAT_ERROR_ID                    = mkRuntimeErrorId patErrorName
 945 nO_METHOD_BINDING_ERROR_ID      = mkRuntimeErrorId noMethodBindingErrorName
 946 nON_EXHAUSTIVE_GUARDS_ERROR_ID  = mkRuntimeErrorId nonExhaustiveGuardsErrorName
 947
 948 -- The runtime error Ids take a UTF8-encoded string as argument
 949 mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
 950 runtimeErrorTy        = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
 951 \end{code}
 952
 953 \begin{code}
 954 eRROR_ID = pc_bottoming_Id errorName errorTy
 955
 956 errorTy  :: Type
 957 errorTy  = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
 958     -- Notice the openAlphaTyVar.  It says that "error" can be applied
 959     -- to unboxed as well as boxed types.  This is OK because it never
 960     -- returns, so the return type is irrelevant.
 961 \end{code}
 962
 963
 964 %************************************************************************
 965 %*                                                                      *
 966 \subsection{Utilities}
 967 %*                                                                      *
 968 %************************************************************************
 969
 970 \begin{code}
 971 pcMiscPrelId :: Name -> Type -> IdInfo -> Id
 972 pcMiscPrelId name ty info
 973   = mkVanillaGlobal name ty info
 974     -- We lie and say the thing is imported; otherwise, we get into
 975     -- a mess with dependency analysis; e.g., core2stg may heave in
 976     -- random calls to GHCbase.unpackPS__.  If GHCbase is the module
 977     -- being compiled, then it's just a matter of luck if the definition
 978     -- will be in "the right place" to be in scope.
 979
 980 pc_bottoming_Id name ty
 981  = pcMiscPrelId name ty bottoming_info
 982  where
 983     bottoming_info = vanillaIdInfo `setAllStrictnessInfo` Just strict_sig
 984         -- Do *not* mark them as NoCafRefs, because they can indeed have
 985         -- CAF refs.  For example, pAT_ERROR_ID calls GHC.Err.untangle,
 986         -- which has some CAFs
 987         -- In due course we may arrange that these error-y things are
 988         -- regarded by the GC as permanently live, in which case we
 989         -- can give them NoCaf info.  As it is, any function that calls
 990         -- any pc_bottoming_Id will itself have CafRefs, which bloats
 991         -- SRTs.
 992
 993     strict_sig     = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
 994         -- These "bottom" out, no matter what their arguments
 995
 996 (openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars
 997 openAlphaTy  = mkTyVarTy openAlphaTyVar
 998 openBetaTy   = mkTyVarTy openBetaTyVar
 999 \end{code}
1000