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