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                           mkForAllTys, isUnLiftedType, substTopTheta,
  35                           splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp, unUsgTy,
  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             ( mkDerivedName, mkWiredInIdName,
  43                           mkWorkerOcc, mkSuperDictSelOcc,
  44                           Name, NamedThing(..),
  45                         )
  46 import PrimOp           ( PrimOp, primOpSig, primOpOcc, primOpUniq )
  47 import DataCon          ( DataCon, dataConStrictMarks, dataConFieldLabels,
  48                           dataConArgTys, dataConSig, dataConRawArgTys
  49                         )
  50 import Id               ( idType,
  51                           mkUserLocal, mkVanillaId, mkTemplateLocals,
  52                           mkTemplateLocal, 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 loc
  83   = mkUserLocal occ uniq ty loc `setInlinePragma` IAmASpecPragmaId
  84         -- Maybe a SysLocal?  But then we'd lose the location
  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 $ -- Always inline constructors
 142     setArityInfo (exactArity (n_dicts + n_ex_dicts + n_id_args)) $
 143     setUnfoldingInfo unfolding $
 144     noIdInfo
 145   where
 146         unfolding = mkUnfolding con_rhs
 147
 148         (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon)
 149            = dataConSig data_con
 150         rep_arg_tys = dataConRawArgTys 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
 156         n_dicts      = length dict_tys
 157         n_ex_dicts   = length ex_dict_tys
 158         n_id_args    = length orig_arg_tys
 159         n_rep_args   = length rep_arg_tys
 160
 161         result_ty    = mkTyConApp tycon (mkTyVarTys tyvars)
 162
 163         mkLocals i n tys   = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
 164         (dict_args, i1)    = mkLocals 1  n_dicts    dict_tys
 165         (ex_dict_args,i2)  = mkLocals i1 n_ex_dicts ex_dict_tys
 166         (id_args,i3)       = mkLocals i2 n_id_args  orig_arg_tys
 167
 168         (id_arg1:_) = id_args           -- Used for newtype only
 169         strict_marks  = dataConStrictMarks data_con
 170
 171         con_app i rep_ids
 172                 | isNewTyCon tycon
 173                 = ASSERT( length orig_arg_tys == 1 )
 174                   Note (Coerce result_ty (head orig_arg_tys)) (Var id_arg1)
 175                 | otherwise
 176                 = mkConApp data_con
 177                         (map Type (mkTyVarTys all_tyvars) ++
 178                          map Var (reverse rep_ids))
 179
 180         con_rhs = mkLams all_tyvars $ mkLams dict_args $
 181                   mkLams ex_dict_args $ mkLams id_args $
 182                   foldr mk_case con_app
 183                      (zip (ex_dict_args++id_args) strict_marks) i3 []
 184
 185         mk_case
 186            :: (Id, StrictnessMark)      -- arg, strictness
 187            -> (Int -> [Id] -> CoreExpr) -- body
 188            -> Int                       -- next rep arg id
 189            -> [Id]                      -- rep args so far
 190            -> CoreExpr
 191         mk_case (arg,strict) body i rep_args
 192           = case strict of
 193                 NotMarkedStrict -> body i (arg:rep_args)
 194                 MarkedStrict
 195                    | isUnLiftedType (idType arg) -> body i (arg:rep_args)
 196                    | otherwise ->
 197                         Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))]
 198
 199                 MarkedUnboxed con tys ->
 200                    Case (Var arg) arg [(DataCon con, con_args,
 201                                         body i' (reverse con_args++rep_args))]
 202                    where n_tys = length tys
 203                          (con_args,i') = mkLocals i (length tys) tys
 204 \end{code}
 205
 206
 207 %************************************************************************
 208 %*                                                                      *
 209 \subsection{Record selectors}
 210 %*                                                                      *
 211 %************************************************************************
 212
 213 We're going to build a record selector unfolding that looks like this:
 214
 215         data T a b c = T1 { ..., op :: a, ...}
 216                      | T2 { ..., op :: a, ...}
 217                      | T3
 218
 219         sel = /\ a b c -> \ d -> case d of
 220                                     T1 ... x ... -> x
 221                                     T2 ... x ... -> x
 222                                     other        -> error "..."
 223
 224 \begin{code}
 225 mkRecordSelId field_label selector_ty
 226   = ASSERT( null theta && isDataTyCon tycon )
 227     sel_id
 228   where
 229     sel_id = mkId (fieldLabelName field_label) selector_ty
 230                   (RecordSelId field_label) info
 231
 232     info = exactArity 1 `setArityInfo` (
 233            unfolding    `setUnfoldingInfo`
 234            noIdInfo)
 235         -- ToDo: consider adding further IdInfo
 236
 237     unfolding = mkUnfolding sel_rhs
 238
 239     (tyvars, theta, tau)  = splitSigmaTy selector_ty
 240     (data_ty,rhs_ty)      = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
 241                                         -- tau is of form (T a b c -> field-type)
 242     (tycon, _, data_cons) = splitAlgTyConApp data_ty
 243     tyvar_tys             = mkTyVarTys tyvars
 244
 245     [data_id] = mkTemplateLocals [data_ty]
 246     alts      = map mk_maybe_alt data_cons
 247     the_alts  = catMaybes alts
 248     default_alt | all isJust alts = []  -- No default needed
 249                 | otherwise       = [(DEFAULT, [], error_expr)]
 250
 251     sel_rhs   = mkLams tyvars $ Lam data_id $
 252                 Case (Var data_id) data_id (the_alts ++ default_alt)
 253
 254     mk_maybe_alt data_con
 255           = case maybe_the_arg_id of
 256                 Nothing         -> Nothing
 257                 Just the_arg_id -> Just (DataCon data_con, arg_ids, Var the_arg_id)
 258           where
 259             arg_ids          = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
 260                                     -- The first one will shadow data_id, but who cares
 261             field_lbls       = dataConFieldLabels data_con
 262             maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
 263
 264     error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy rhs_ty), mkStringLit full_msg]
 265        -- preserves invariant that type args are *not* usage-annotated on top.  KSW 1999-04.
 266     full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id])
 267 \end{code}
 268
 269
 270 %************************************************************************
 271 %*                                                                      *
 272 \subsection{Newtype field selectors}
 273 %*                                                                      *
 274 %************************************************************************
 275
 276 Possibly overkill to do it this way:
 277
 278 \begin{code}
 279 mkNewTySelId field_label selector_ty = sel_id
 280   where
 281     sel_id = mkId (fieldLabelName field_label) selector_ty
 282                   (RecordSelId field_label) info
 283
 284     info = exactArity 1 `setArityInfo` (
 285            unfolding    `setUnfoldingInfo`
 286            noIdInfo)
 287         -- ToDo: consider adding further IdInfo
 288
 289     unfolding = mkUnfolding sel_rhs
 290
 291     (tyvars, theta, tau)  = splitSigmaTy selector_ty
 292     (data_ty,rhs_ty)      = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
 293                                         -- tau is of form (T a b c -> field-type)
 294     (tycon, _, data_cons) = splitAlgTyConApp data_ty
 295     tyvar_tys             = mkTyVarTys tyvars
 296
 297     [data_id] = mkTemplateLocals [data_ty]
 298     sel_rhs   = mkLams tyvars $ Lam data_id $
 299                 Note (Coerce rhs_ty data_ty) (Var data_id)
 300
 301 \end{code}
 302
 303
 304 %************************************************************************
 305 %*                                                                      *
 306 \subsection{Dictionary selectors}
 307 %*                                                                      *
 308 %************************************************************************
 309
 310 \begin{code}
 311 mkSuperDictSelId :: Unique -> Class -> FieldLabelTag -> Type -> Id
 312         -- The FieldLabelTag says which superclass is selected
 313         -- So, for
 314         --      class (C a, C b) => Foo a b where ...
 315         -- we get superclass selectors
 316         --      Foo_sc1, Foo_sc2
 317
 318 mkSuperDictSelId uniq clas index ty
 319   = mkDictSelId name clas ty
 320   where
 321     name   = mkDerivedName (mkSuperDictSelOcc index) (getName clas) uniq
 322
 323         -- For method selectors the clean thing to do is
 324         -- to give the method selector the same name as the class op itself.
 325 mkMethodSelId name clas ty
 326   = mkDictSelId name clas ty
 327 \end{code}
 328
 329 Selecting a field for a dictionary.  If there is just one field, then
 330 there's nothing to do.
 331
 332 \begin{code}
 333 mkDictSelId name clas ty
 334   = sel_id
 335   where
 336     sel_id    = mkId name ty (RecordSelId field_lbl) info
 337     field_lbl = mkFieldLabel name ty tag
 338     tag       = assoc "MkId.mkDictSelId" ((sc_sel_ids ++ op_sel_ids) `zip` allFieldLabelTags) sel_id
 339
 340     info      = setInlinePragInfo IMustBeINLINEd $
 341                 setUnfoldingInfo  unfolding noIdInfo
 342         -- The always-inline thing means we don't need any other IdInfo
 343         -- We need "Must" inline because we don't create any bindigs for
 344         -- the selectors.
 345
 346     unfolding = mkUnfolding rhs
 347
 348     (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
 349
 350     tycon      = classTyCon clas
 351     [data_con] = tyConDataCons tycon
 352     tyvar_tys  = mkTyVarTys tyvars
 353     arg_tys    = dataConArgTys data_con tyvar_tys
 354     the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
 355
 356     dict_ty    = mkDictTy clas tyvar_tys
 357     (dict_id:arg_ids) = mkTemplateLocals (dict_ty : arg_tys)
 358
 359     rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
 360                              Note (Coerce (head arg_tys) dict_ty) (Var dict_id)
 361         | otherwise        = mkLams tyvars $ Lam dict_id $
 362                              Case (Var dict_id) dict_id
 363                                   [(DataCon data_con, arg_ids, Var the_arg_id)]
 364 \end{code}
 365
 366
 367 %************************************************************************
 368 %*                                                                      *
 369 \subsection{Primitive operations
 370 %*                                                                      *
 371 %************************************************************************
 372
 373
 374 \begin{code}
 375 mkPrimitiveId :: PrimOp -> Id
 376 mkPrimitiveId prim_op
 377   = id
 378   where
 379     occ_name = primOpOcc  prim_op
 380     key      = primOpUniq prim_op
 381     (tyvars,arg_tys,res_ty) = primOpSig prim_op
 382     ty       = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
 383     name    = mkWiredInIdName key pREL_GHC occ_name id
 384     id      = mkId name ty (ConstantId (PrimOp prim_op)) info
 385
 386     info = setUnfoldingInfo unfolding $
 387            setInlinePragInfo IMustBeINLINEd $
 388                 -- The pragma @IMustBeINLINEd@ says that this Id absolutely
 389                 -- must be inlined.  It's only used for primitives,
 390                 -- because we don't want to make a closure for each of them.
 391            noIdInfo
 392
 393     unfolding = mkUnfolding rhs
 394
 395     args = mkTemplateLocals arg_tys
 396     rhs =  mkLams tyvars $ mkLams args $
 397            mkPrimApp prim_op (map Type (mkTyVarTys tyvars) ++ map Var args)
 398 \end{code}
 399
 400 \end{code}
 401
 402 \begin{code}
 403 dyadic_fun_ty  ty = mkFunTys [ty, ty] ty
 404 monadic_fun_ty ty = ty `mkFunTy` ty
 405 compare_fun_ty ty = mkFunTys [ty, ty] boolTy
 406 \end{code}
 407
 408
 409 %************************************************************************
 410 %*                                                                      *
 411 \subsection{DictFuns}
 412 %*                                                                      *
 413 %************************************************************************
 414
 415 \begin{code}
 416 mkDictFunId :: Name             -- Name to use for the dict fun;
 417             -> Class
 418             -> [TyVar]
 419             -> [Type]
 420             -> ThetaType
 421             -> Id
 422
 423 mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
 424   = mkVanillaId dfun_name dfun_ty
 425   where
 426     (class_tyvars, sc_theta, _, _, _) = classBigSig clas
 427     sc_theta' = substTopTheta (zipVarEnv class_tyvars inst_tys) sc_theta
 428
 429     dfun_theta = case inst_decl_theta of
 430                    []    -> []  -- If inst_decl_theta is empty, then we don't
 431                                 -- want to have any dict arguments, so that we can
 432                                 -- expose the constant methods.
 433
 434                    other -> nub (inst_decl_theta ++ sc_theta')
 435                                 -- Otherwise we pass the superclass dictionaries to
 436                                 -- the dictionary function; the Mark Jones optimisation.
 437                                 --
 438                                 -- NOTE the "nub".  I got caught by this one:
 439                                 --   class Monad m => MonadT t m where ...
 440                                 --   instance Monad m => MonadT (EnvT env) m where ...
 441                                 -- Here, the inst_decl_theta has (Monad m); but so
 442                                 -- does the sc_theta'!
 443
 444     dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
 445 \end{code}