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, dataConRawArgTys
  50                         )
  51 import Id               ( idType,
  52                           mkUserLocal, mkVanillaId, mkTemplateLocals,
  53                           mkTemplateLocal, 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 $ -- Always inline constructors
 143     setArityInfo (exactArity (n_dicts + n_ex_dicts + n_id_args)) $
 144     setUnfoldingInfo unfolding $
 145     noIdInfo
 146   where
 147         unfolding = mkUnfolding con_rhs
 148
 149         (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon)
 150            = dataConSig data_con
 151         rep_arg_tys = dataConRawArgTys data_con
 152         all_tyvars   = tyvars ++ ex_tyvars
 153
 154         dict_tys     = [mkDictTy clas tys | (clas,tys) <- theta]
 155         ex_dict_tys  = [mkDictTy clas tys | (clas,tys) <- ex_theta]
 156
 157         n_dicts      = length dict_tys
 158         n_ex_dicts   = length ex_dict_tys
 159         n_id_args    = length orig_arg_tys
 160         n_rep_args   = length rep_arg_tys
 161
 162         result_ty    = mkTyConApp tycon (mkTyVarTys tyvars)
 163
 164         mkLocals i n tys   = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
 165         (dict_args, i1)    = mkLocals 1  n_dicts    dict_tys
 166         (ex_dict_args,i2)  = mkLocals i1 n_ex_dicts ex_dict_tys
 167         (id_args,i3)       = mkLocals i2 n_id_args  orig_arg_tys
 168
 169         (id_arg1:_) = id_args           -- Used for newtype only
 170         strict_marks  = dataConStrictMarks data_con
 171
 172         con_app i rep_ids
 173                 | isNewTyCon tycon
 174                 = ASSERT( length orig_arg_tys == 1 )
 175                   Note (Coerce result_ty (head orig_arg_tys)) (Var id_arg1)
 176                 | otherwise
 177                 = mkConApp data_con
 178                         (map Type (mkTyVarTys all_tyvars) ++
 179                          map Var (reverse rep_ids))
 180
 181         con_rhs = mkLams all_tyvars $ mkLams dict_args $
 182                   mkLams ex_dict_args $ mkLams id_args $
 183                   foldr mk_case con_app
 184                      (zip (ex_dict_args++id_args) strict_marks) i3 []
 185
 186         mk_case
 187            :: (Id, StrictnessMark)      -- arg, strictness
 188            -> (Int -> [Id] -> CoreExpr) -- body
 189            -> Int                       -- next rep arg id
 190            -> [Id]                      -- rep args so far
 191            -> CoreExpr
 192         mk_case (arg,strict) body i rep_args
 193           = case strict of
 194                 NotMarkedStrict -> body i (arg:rep_args)
 195                 MarkedStrict
 196                    | isUnLiftedType (idType arg) -> body i (arg:rep_args)
 197                    | otherwise ->
 198                         Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))]
 199
 200                 MarkedUnboxed con tys ->
 201                    Case (Var arg) arg [(DataCon con, con_args,
 202                                         body i' (reverse con_args++rep_args))]
 203                    where n_tys = length tys
 204                          (con_args,i') = mkLocals i (length tys) tys
 205 \end{code}
 206
 207
 208 %************************************************************************
 209 %*                                                                      *
 210 \subsection{Record selectors}
 211 %*                                                                      *
 212 %************************************************************************
 213
 214 We're going to build a record selector unfolding that looks like this:
 215
 216         data T a b c = T1 { ..., op :: a, ...}
 217                      | T2 { ..., op :: a, ...}
 218                      | T3
 219
 220         sel = /\ a b c -> \ d -> case d of
 221                                     T1 ... x ... -> x
 222                                     T2 ... x ... -> x
 223                                     other        -> error "..."
 224
 225 \begin{code}
 226 mkRecordSelId field_label selector_ty
 227   = ASSERT( null theta && isDataTyCon tycon )
 228     sel_id
 229   where
 230     sel_id = mkId (fieldLabelName field_label) selector_ty
 231                   (RecordSelId field_label) info
 232
 233     info = exactArity 1 `setArityInfo` (
 234            unfolding    `setUnfoldingInfo`
 235            noIdInfo)
 236         -- ToDo: consider adding further IdInfo
 237
 238     unfolding = mkUnfolding sel_rhs
 239
 240     (tyvars, theta, tau)  = splitSigmaTy selector_ty
 241     (data_ty,rhs_ty)      = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
 242                                         -- tau is of form (T a b c -> field-type)
 243     (tycon, _, data_cons) = splitAlgTyConApp data_ty
 244     tyvar_tys             = mkTyVarTys tyvars
 245
 246     [data_id] = mkTemplateLocals [data_ty]
 247     alts      = map mk_maybe_alt data_cons
 248     the_alts  = catMaybes alts
 249     default_alt | all isJust alts = []  -- No default needed
 250                 | otherwise       = [(DEFAULT, [], error_expr)]
 251
 252     sel_rhs   = mkLams tyvars $ Lam data_id $
 253                 Case (Var data_id) data_id (the_alts ++ default_alt)
 254
 255     mk_maybe_alt data_con
 256           = case maybe_the_arg_id of
 257                 Nothing         -> Nothing
 258                 Just the_arg_id -> Just (DataCon data_con, arg_ids, Var the_arg_id)
 259           where
 260             arg_ids          = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
 261                                     -- The first one will shadow data_id, but who cares
 262             field_lbls       = dataConFieldLabels data_con
 263             maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
 264
 265     error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type rhs_ty, mkStringLit full_msg]
 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     ty       = primOpType prim_op
 382     name    = mkWiredInIdName key pREL_GHC occ_name id
 383     id      = mkId name ty (ConstantId (PrimOp prim_op)) info
 384
 385     info = setUnfoldingInfo unfolding $
 386            setInlinePragInfo IMustBeINLINEd $
 387                 -- The pragma @IMustBeINLINEd@ says that this Id absolutely
 388                 -- must be inlined.  It's only used for primitives,
 389                 -- because we don't want to make a closure for each of them.
 390            noIdInfo
 391
 392     unfolding = mkUnfolding rhs
 393
 394     (tyvars, tau) = splitForAllTys ty
 395     (arg_tys, _)  = splitFunTys tau
 396
 397     args = mkTemplateLocals arg_tys
 398     rhs =  mkLams tyvars $ mkLams args $
 399            mkPrimApp prim_op (map Type (mkTyVarTys tyvars) ++ map Var args)
 400 \end{code}
 401
 402 \end{code}
 403
 404 \begin{code}
 405 dyadic_fun_ty  ty = mkFunTys [ty, ty] ty
 406 monadic_fun_ty ty = ty `mkFunTy` ty
 407 compare_fun_ty ty = mkFunTys [ty, ty] boolTy
 408 \end{code}
 409
 410
 411 %************************************************************************
 412 %*                                                                      *
 413 \subsection{DictFuns}
 414 %*                                                                      *
 415 %************************************************************************
 416
 417 \begin{code}
 418 mkDictFunId :: Name             -- Name to use for the dict fun;
 419             -> Class
 420             -> [TyVar]
 421             -> [Type]
 422             -> ThetaType
 423             -> Id
 424
 425 mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
 426   = mkVanillaId dfun_name dfun_ty
 427   where
 428     (class_tyvars, sc_theta, _, _, _) = classBigSig clas
 429     sc_theta' = substTopTheta (zipVarEnv class_tyvars inst_tys) sc_theta
 430
 431     dfun_theta = case inst_decl_theta of
 432                    []    -> []  -- If inst_decl_theta is empty, then we don't
 433                                 -- want to have any dict arguments, so that we can
 434                                 -- expose the constant methods.
 435
 436                    other -> nub (inst_decl_theta ++ sc_theta')
 437                                 -- Otherwise we pass the superclass dictionaries to
 438                                 -- the dictionary function; the Mark Jones optimisation.
 439                                 --
 440                                 -- NOTE the "nub".  I got caught by this one:
 441                                 --   class Monad m => MonadT t m where ...
 442                                 --   instance Monad m => MonadT (EnvT env) m where ...
 443                                 -- Here, the inst_decl_theta has (Monad m); but so
 444                                 -- does the sc_theta'!
 445
 446     dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
 447 \end{code}