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         mkSpecPragmaId, mkWorkerId,
  17
  18         mkDictFunId, mkDefaultMethodId,
  19         mkMethodSelId, mkSuperDictSelId,
  20
  21         mkDataConId,
  22         mkRecordSelId,
  23         mkPrimitiveId
  24     ) where
  25
  26 #include "HsVersions.h"
  27
  28 import {-# SOURCE #-} CoreUnfold ( mkUnfolding )
  29
  30 import TysWiredIn       ( boolTy )
  31 import Type             ( Type, ThetaType,
  32                           mkDictTy, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy,
  33                           isUnLiftedType, substFlexiTheta,
  34                           splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp,
  35                           splitFunTys, splitForAllTys
  36                         )
  37 import TyCon            ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon )
  38 import Class            ( Class, classBigSig, classTyCon )
  39 import Var              ( Id, TyVar, VarDetails(..), mkId )
  40 import VarEnv           ( zipVarEnv )
  41 import Const            ( Con(..) )
  42 import Name             ( mkCompoundName, mkWiredInIdName,
  43                           mkWorkerName, mkSuperDictSelName,
  44                           Name, NamedThing(..),
  45                         )
  46 import PrimOp           ( PrimOp, primOpType, primOpStr, primOpUniq )
  47 import DataCon          ( DataCon, dataConStrictMarks, dataConFieldLabels,
  48                           dataConArgTys, dataConSig
  49                         )
  50 import Id               ( idType,
  51                           mkUserLocal, mkVanillaId, mkTemplateLocals,
  52                           setInlinePragma
  53                         )
  54 import IdInfo           ( noIdInfo,
  55                           exactArity, setUnfoldingInfo,
  56                           setArityInfo, setInlinePragInfo,
  57                           InlinePragInfo(..), IdInfo
  58                         )
  59 import FieldLabel       ( FieldLabel, FieldLabelTag, mkFieldLabel, fieldLabelName,
  60                           firstFieldLabelTag, allFieldLabelTags
  61                         )
  62 import CoreSyn
  63 import PrelVals         ( rEC_SEL_ERROR_ID )
  64 import PrelMods         ( pREL_GHC )
  65 import Maybes
  66 import BasicTypes       ( Arity, StrictnessMark(..) )
  67 import Unique           ( Unique )
  68 import Maybe            ( isJust )
  69 import Outputable
  70 import Util             ( assoc )
  71 import List             ( nub )
  72 \end{code}
  73
  74
  75 %************************************************************************
  76 %*                                                                      *
  77 \subsection{Easy ones}
  78 %*                                                                      *
  79 %************************************************************************
  80
  81 \begin{code}
  82 mkSpecPragmaId occ uniq ty
  83   = mkUserLocal occ uniq ty `setInlinePragma` IAmASpecPragmaId
  84
  85 mkDefaultMethodId dm_name rec_c ty
  86   = mkVanillaId dm_name ty
  87
  88 mkWorkerId uniq unwrkr ty
  89   = mkVanillaId (mkCompoundName mkWorkerName uniq (getName unwrkr)) ty
  90 \end{code}
  91
  92 %************************************************************************
  93 %*                                                                      *
  94 \subsection{Data constructors}
  95 %*                                                                      *
  96 %************************************************************************
  97
  98 \begin{code}
  99 mkDataConId :: DataCon -> Id
 100 mkDataConId data_con
 101   = mkId (getName data_con)
 102          id_ty
 103          (ConstantId (DataCon data_con))
 104          (dataConInfo data_con)
 105   where
 106     (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon) = dataConSig data_con
 107     id_ty = mkSigmaTy (tyvars ++ ex_tyvars)
 108                       (theta ++ ex_theta)
 109                       (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)))
 110 \end{code}
 111
 112 We're going to build a constructor that looks like:
 113
 114         data (Data a, C b) =>  T a b = T1 !a !Int b
 115
 116         T1 = /\ a b ->
 117              \d1::Data a, d2::C b ->
 118              \p q r -> case p of { p ->
 119                        case q of { q ->
 120                        Con T1 [a,b] [p,q,r]}}
 121
 122 Notice that
 123
 124 * d2 is thrown away --- a context in a data decl is used to make sure
 125   one *could* construct dictionaries at the site the constructor
 126   is used, but the dictionary isn't actually used.
 127
 128 * We have to check that we can construct Data dictionaries for
 129   the types a and Int.  Once we've done that we can throw d1 away too.
 130
 131 * We use (case p of ...) to evaluate p, rather than "seq" because
 132   all that matters is that the arguments are evaluated.  "seq" is
 133   very careful to preserve evaluation order, which we don't need
 134   to be here.
 135
 136 \begin{code}
 137 dataConInfo :: DataCon -> IdInfo
 138
 139 dataConInfo data_con
 140   = setInlinePragInfo IMustBeINLINEd $
 141                 -- Always inline constructors; we won't create a binding for them
 142     setArityInfo (exactArity (length locals)) $
 143     setUnfoldingInfo unfolding $
 144     noIdInfo
 145   where
 146         unfolding = mkUnfolding con_rhs
 147
 148         (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon) = dataConSig data_con
 149         all_tyvars   = tyvars ++ ex_tyvars
 150
 151         dict_tys     = [mkDictTy clas tys | (clas,tys) <- theta]
 152         ex_dict_tys  = [mkDictTy clas tys | (clas,tys) <- ex_theta]
 153         n_dicts      = length dict_tys
 154         result_ty    = mkTyConApp tycon (mkTyVarTys tyvars)
 155
 156         locals        = mkTemplateLocals (dict_tys ++ ex_dict_tys ++ arg_tys)
 157         data_args     = drop n_dicts locals
 158         (data_arg1:_) = data_args               -- Used for newtype only
 159         strict_marks  = dataConStrictMarks data_con
 160         strict_args   = [arg | (arg,MarkedStrict) <- data_args `zip` strict_marks]
 161                 -- NB: we can't call mkTemplateLocals twice, because it
 162                 -- always starts from the same unique.
 163
 164         con_app | isNewTyCon tycon
 165                 = ASSERT( length arg_tys == 1)
 166                   Note (Coerce result_ty (head arg_tys)) (Var data_arg1)
 167                 | otherwise
 168                 = mkConApp data_con (map Type (mkTyVarTys all_tyvars) ++ map Var data_args)
 169
 170         con_rhs = mkLams all_tyvars $ mkLams locals $
 171                   foldr mk_case con_app strict_args
 172
 173         mk_case arg body | isUnLiftedType (idType arg)
 174                          = body                 -- "!" on unboxed arg does nothing
 175                          | otherwise
 176                          = Case (Var arg) arg [(DEFAULT,[],body)]
 177                                 -- This case shadows "arg" but that's fine
 178 \end{code}
 179
 180
 181 %************************************************************************
 182 %*                                                                      *
 183 \subsection{Record selectors}
 184 %*                                                                      *
 185 %************************************************************************
 186
 187 We're going to build a record selector unfolding that looks like this:
 188
 189         data T a b c = T1 { ..., op :: a, ...}
 190                      | T2 { ..., op :: a, ...}
 191                      | T3
 192
 193         sel = /\ a b c -> \ d -> case d of
 194                                     T1 ... x ... -> x
 195                                     T2 ... x ... -> x
 196                                     other        -> error "..."
 197
 198 \begin{code}
 199 mkRecordSelId field_label selector_ty
 200   = ASSERT( null theta && isDataTyCon tycon )
 201     sel_id
 202   where
 203     sel_id = mkId (fieldLabelName field_label) selector_ty
 204                   (RecordSelId field_label) info
 205
 206     info = exactArity 1 `setArityInfo` (
 207            unfolding    `setUnfoldingInfo`
 208            noIdInfo)
 209         -- ToDo: consider adding further IdInfo
 210
 211     unfolding = mkUnfolding sel_rhs
 212
 213     (tyvars, theta, tau)  = splitSigmaTy selector_ty
 214     (data_ty,rhs_ty)      = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
 215                                         -- tau is of form (T a b c -> field-type)
 216     (tycon, _, data_cons) = splitAlgTyConApp data_ty
 217     tyvar_tys             = mkTyVarTys tyvars
 218
 219     [data_id] = mkTemplateLocals [data_ty]
 220     alts      = map mk_maybe_alt data_cons
 221     the_alts  = catMaybes alts
 222     default_alt | all isJust alts = []  -- No default needed
 223                 | otherwise       = [(DEFAULT, [], error_expr)]
 224
 225     sel_rhs   = mkLams tyvars $ Lam data_id $
 226                 Case (Var data_id) data_id (the_alts ++ default_alt)
 227
 228     mk_maybe_alt data_con
 229           = case maybe_the_arg_id of
 230                 Nothing         -> Nothing
 231                 Just the_arg_id -> Just (DataCon data_con, arg_ids, Var the_arg_id)
 232           where
 233             arg_ids          = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
 234                                     -- The first one will shadow data_id, but who cares
 235             field_lbls       = dataConFieldLabels data_con
 236             maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
 237
 238     error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type rhs_ty, mkStringLit full_msg]
 239     full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id])
 240 \end{code}
 241
 242
 243 %************************************************************************
 244 %*                                                                      *
 245 \subsection{Dictionary selectors}
 246 %*                                                                      *
 247 %************************************************************************
 248
 249 \begin{code}
 250 mkSuperDictSelId :: Unique -> Class -> FieldLabelTag -> Type -> Id
 251         -- The FieldLabelTag says which superclass is selected
 252         -- So, for
 253         --      class (C a, C b) => Foo a b where ...
 254         -- we get superclass selectors
 255         --      Foo_sc1, Foo_sc2
 256
 257 mkSuperDictSelId uniq clas index ty
 258   = mkDictSelId name clas ty
 259   where
 260     name   = mkCompoundName (mkSuperDictSelName index) uniq (getName clas)
 261
 262         -- For method selectors the clean thing to do is
 263         -- to give the method selector the same name as the class op itself.
 264 mkMethodSelId name clas ty
 265   = mkDictSelId name clas ty
 266 \end{code}
 267
 268 Selecting a field for a dictionary.  If there is just one field, then
 269 there's nothing to do.
 270
 271 \begin{code}
 272 mkDictSelId name clas ty
 273   = sel_id
 274   where
 275     sel_id    = mkId name ty (RecordSelId field_lbl) info
 276     field_lbl = mkFieldLabel name ty tag
 277     tag       = assoc "MkId.mkDictSelId" ((sc_sel_ids ++ op_sel_ids) `zip` allFieldLabelTags) sel_id
 278
 279     info      = setInlinePragInfo IMustBeINLINEd $
 280                 setUnfoldingInfo  unfolding noIdInfo
 281         -- The always-inline thing means we don't need any other IdInfo
 282         -- We need "Must" inline because we don't create any bindigs for
 283         -- the selectors.
 284
 285     unfolding = mkUnfolding rhs
 286
 287     (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
 288
 289     tycon      = classTyCon clas
 290     [data_con] = tyConDataCons tycon
 291     tyvar_tys  = mkTyVarTys tyvars
 292     arg_tys    = dataConArgTys data_con tyvar_tys
 293     the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
 294
 295     dict_ty    = mkDictTy clas tyvar_tys
 296     (dict_id:arg_ids) = mkTemplateLocals (dict_ty : arg_tys)
 297
 298     rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
 299                              Note (Coerce (head arg_tys) dict_ty) (Var dict_id)
 300         | otherwise        = mkLams tyvars $ Lam dict_id $
 301                              Case (Var dict_id) dict_id
 302                                   [(DataCon data_con, arg_ids, Var the_arg_id)]
 303 \end{code}
 304
 305
 306 %************************************************************************
 307 %*                                                                      *
 308 \subsection{Primitive operations
 309 %*                                                                      *
 310 %************************************************************************
 311
 312
 313 \begin{code}
 314 mkPrimitiveId :: PrimOp -> Id
 315 mkPrimitiveId prim_op
 316   = id
 317   where
 318     occ_name = primOpStr  prim_op
 319     key      = primOpUniq prim_op
 320     ty       = primOpType prim_op
 321     name    = mkWiredInIdName key pREL_GHC occ_name id
 322     id      = mkId name ty (ConstantId (PrimOp prim_op)) info
 323
 324     info = setUnfoldingInfo unfolding $
 325            setInlinePragInfo IMustBeINLINEd $
 326                 -- The pragma @IMustBeINLINEd@ says that this Id absolutely
 327                 -- must be inlined.  It's only used for primitives,
 328                 -- because we don't want to make a closure for each of them.
 329            noIdInfo
 330
 331     unfolding = mkUnfolding rhs
 332
 333     (tyvars, tau) = splitForAllTys ty
 334     (arg_tys, _)  = splitFunTys tau
 335
 336     args = mkTemplateLocals arg_tys
 337     rhs =  mkLams tyvars $ mkLams args $
 338            mkPrimApp prim_op (map Type (mkTyVarTys tyvars) ++ map Var args)
 339 \end{code}
 340
 341 \end{code}
 342
 343 \begin{code}
 344 dyadic_fun_ty  ty = mkFunTys [ty, ty] ty
 345 monadic_fun_ty ty = ty `mkFunTy` ty
 346 compare_fun_ty ty = mkFunTys [ty, ty] boolTy
 347 \end{code}
 348
 349
 350 %************************************************************************
 351 %*                                                                      *
 352 \subsection{DictFuns}
 353 %*                                                                      *
 354 %************************************************************************
 355
 356 \begin{code}
 357 mkDictFunId :: Name             -- Name to use for the dict fun;
 358             -> Class
 359             -> [TyVar]
 360             -> [Type]
 361             -> ThetaType
 362             -> Id
 363
 364 mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
 365   = mkVanillaId dfun_name dfun_ty
 366   where
 367     (class_tyvars, sc_theta, _, _, _) = classBigSig clas
 368     sc_theta' = substFlexiTheta (zipVarEnv class_tyvars inst_tys) sc_theta
 369                         -- Doesn't really need to be flexi
 370
 371     dfun_theta = case inst_decl_theta of
 372                    []    -> []  -- If inst_decl_theta is empty, then we don't
 373                                 -- want to have any dict arguments, so that we can
 374                                 -- expose the constant methods.
 375
 376                    other -> nub (inst_decl_theta ++ sc_theta')
 377                                 -- Otherwise we pass the superclass dictionaries to
 378                                 -- the dictionary function; the Mark Jones optimisation.
 379                                 --
 380                                 -- NOTE the "nub".  I got caught by this one:
 381                                 --   class Monad m => MonadT t m where ...
 382                                 --   instance Monad m => MonadT (EnvT env) m where ...
 383                                 -- Here, the inst_decl_theta has (Monad m); but so
 384                                 -- does the sc_theta'!
 385
 386     dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
 387 \end{code}