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 (zip 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 rhs_ty, mkStringLit full_msg]
 265     full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id])
 266 \end{code}
 267
 268
 269 %************************************************************************
 270 %*                                                                      *
 271 \subsection{Newtype field selectors}
 272 %*                                                                      *
 273 %************************************************************************
 274
 275 Possibly overkill to do it this way:
 276
 277 \begin{code}
 278 mkNewTySelId field_label selector_ty = sel_id
 279   where
 280     sel_id = mkId (fieldLabelName field_label) selector_ty
 281                   (RecordSelId field_label) info
 282
 283     info = exactArity 1 `setArityInfo` (
 284            unfolding    `setUnfoldingInfo`
 285            noIdInfo)
 286         -- ToDo: consider adding further IdInfo
 287
 288     unfolding = mkUnfolding sel_rhs
 289
 290     (tyvars, theta, tau)  = splitSigmaTy selector_ty
 291     (data_ty,rhs_ty)      = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
 292                                         -- tau is of form (T a b c -> field-type)
 293     (tycon, _, data_cons) = splitAlgTyConApp data_ty
 294     tyvar_tys             = mkTyVarTys tyvars
 295
 296     [data_id] = mkTemplateLocals [data_ty]
 297     sel_rhs   = mkLams tyvars $ Lam data_id $
 298                 Note (Coerce rhs_ty data_ty) (Var data_id)
 299
 300 \end{code}
 301
 302
 303 %************************************************************************
 304 %*                                                                      *
 305 \subsection{Dictionary selectors}
 306 %*                                                                      *
 307 %************************************************************************
 308
 309 \begin{code}
 310 mkSuperDictSelId :: Unique -> Class -> FieldLabelTag -> Type -> Id
 311         -- The FieldLabelTag says which superclass is selected
 312         -- So, for
 313         --      class (C a, C b) => Foo a b where ...
 314         -- we get superclass selectors
 315         --      Foo_sc1, Foo_sc2
 316
 317 mkSuperDictSelId uniq clas index ty
 318   = mkDictSelId name clas ty
 319   where
 320     name   = mkDerivedName (mkSuperDictSelOcc index) (getName clas) uniq
 321
 322         -- For method selectors the clean thing to do is
 323         -- to give the method selector the same name as the class op itself.
 324 mkMethodSelId name clas ty
 325   = mkDictSelId name clas ty
 326 \end{code}
 327
 328 Selecting a field for a dictionary.  If there is just one field, then
 329 there's nothing to do.
 330
 331 \begin{code}
 332 mkDictSelId name clas ty
 333   = sel_id
 334   where
 335     sel_id    = mkId name ty (RecordSelId field_lbl) info
 336     field_lbl = mkFieldLabel name ty tag
 337     tag       = assoc "MkId.mkDictSelId" ((sc_sel_ids ++ op_sel_ids) `zip` allFieldLabelTags) sel_id
 338
 339     info      = setInlinePragInfo IMustBeINLINEd $
 340                 setUnfoldingInfo  unfolding noIdInfo
 341         -- The always-inline thing means we don't need any other IdInfo
 342         -- We need "Must" inline because we don't create any bindigs for
 343         -- the selectors.
 344
 345     unfolding = mkUnfolding rhs
 346
 347     (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
 348
 349     tycon      = classTyCon clas
 350     [data_con] = tyConDataCons tycon
 351     tyvar_tys  = mkTyVarTys tyvars
 352     arg_tys    = dataConArgTys data_con tyvar_tys
 353     the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
 354
 355     dict_ty    = mkDictTy clas tyvar_tys
 356     (dict_id:arg_ids) = mkTemplateLocals (dict_ty : arg_tys)
 357
 358     rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
 359                              Note (Coerce (head arg_tys) dict_ty) (Var dict_id)
 360         | otherwise        = mkLams tyvars $ Lam dict_id $
 361                              Case (Var dict_id) dict_id
 362                                   [(DataCon data_con, arg_ids, Var the_arg_id)]
 363 \end{code}
 364
 365
 366 %************************************************************************
 367 %*                                                                      *
 368 \subsection{Primitive operations
 369 %*                                                                      *
 370 %************************************************************************
 371
 372
 373 \begin{code}
 374 mkPrimitiveId :: PrimOp -> Id
 375 mkPrimitiveId prim_op
 376   = id
 377   where
 378     occ_name = primOpOcc  prim_op
 379     key      = primOpUniq prim_op
 380     ty       = primOpType prim_op
 381     name    = mkWiredInIdName key pREL_GHC occ_name id
 382     id      = mkId name ty (ConstantId (PrimOp prim_op)) info
 383
 384     info = setUnfoldingInfo unfolding $
 385            setInlinePragInfo IMustBeINLINEd $
 386                 -- The pragma @IMustBeINLINEd@ says that this Id absolutely
 387                 -- must be inlined.  It's only used for primitives,
 388                 -- because we don't want to make a closure for each of them.
 389            noIdInfo
 390
 391     unfolding = mkUnfolding rhs
 392
 393     (tyvars, tau) = splitForAllTys ty
 394     (arg_tys, _)  = splitFunTys tau
 395
 396     args = mkTemplateLocals arg_tys
 397     rhs =  mkLams tyvars $ mkLams args $
 398            mkPrimApp prim_op (map Type (mkTyVarTys tyvars) ++ map Var args)
 399 \end{code}
 400
 401 \end{code}
 402
 403 \begin{code}
 404 dyadic_fun_ty  ty = mkFunTys [ty, ty] ty
 405 monadic_fun_ty ty = ty `mkFunTy` ty
 406 compare_fun_ty ty = mkFunTys [ty, ty] boolTy
 407 \end{code}
 408
 409
 410 %************************************************************************
 411 %*                                                                      *
 412 \subsection{DictFuns}
 413 %*                                                                      *
 414 %************************************************************************
 415
 416 \begin{code}
 417 mkDictFunId :: Name             -- Name to use for the dict fun;
 418             -> Class
 419             -> [TyVar]
 420             -> [Type]
 421             -> ThetaType
 422             -> Id
 423
 424 mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
 425   = mkVanillaId dfun_name dfun_ty
 426   where
 427     (class_tyvars, sc_theta, _, _, _) = classBigSig clas
 428     sc_theta' = substTopTheta (zipVarEnv class_tyvars inst_tys) sc_theta
 429
 430     dfun_theta = case inst_decl_theta of
 431                    []    -> []  -- If inst_decl_theta is empty, then we don't
 432                                 -- want to have any dict arguments, so that we can
 433                                 -- expose the constant methods.
 434
 435                    other -> nub (inst_decl_theta ++ sc_theta')
 436                                 -- Otherwise we pass the superclass dictionaries to
 437                                 -- the dictionary function; the Mark Jones optimisation.
 438                                 --
 439                                 -- NOTE the "nub".  I got caught by this one:
 440                                 --   class Monad m => MonadT t m where ...
 441                                 --   instance Monad m => MonadT (EnvT env) m where ...
 442                                 -- Here, the inst_decl_theta has (Monad m); but so
 443                                 -- does the sc_theta'!
 444
 445     dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
 446 \end{code}