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