ghc/compiler/basicTypes/MkId.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1996
   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         mkImportedId,
  17         mkUserId,
  18         mkUserLocal, mkSysLocal,
  19
  20         mkDataCon, mkTupleCon,
  21
  22         mkDictFunId,
  23         mkMethodSelId, mkSuperDictSelId, mkDefaultMethodId,
  24
  25         mkRecordSelId,
  26
  27         mkPrimitiveId,
  28         mkWorkerId
  29
  30     ) where
  31
  32 #include "HsVersions.h"
  33
  34 import {-# SOURCE #-} CoreUnfold ( mkUnfolding )
  35
  36 import Type
  37 import CoreSyn
  38 import Literal
  39 import TysWiredIn       ( tupleCon )
  40 import Name             ( mkLocalName, mkSysLocalName, mkCompoundName,
  41                           occNameString, Name, OccName, NamedThing(..)
  42                         )
  43 import Id               ( idType, fIRST_TAG,
  44                           mkTemplateLocals, mkId, mkVanillaId,
  45                           dataConStrictMarks, dataConFieldLabels, dataConArgTys,
  46                           recordSelectorFieldLabel, dataConSig,
  47                           StrictnessMark(..),
  48                           Id, IdDetails(..), GenId
  49                         )
  50 import IdInfo           ( noIdInfo,
  51                           exactArity, setUnfoldingInfo,
  52                           setArityInfo, setInlinePragInfo,
  53                           InlinePragInfo(..), IdInfo
  54                         )
  55 import Class            ( Class, classBigSig, classTyCon )
  56 import FieldLabel       ( FieldLabel, FieldLabelTag, mkFieldLabel, fieldLabelName,
  57                           firstFieldLabelTag, allFieldLabelTags
  58                         )
  59 import TyVar            ( TyVar )
  60 import TyCon            ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon )
  61 import PrelVals         ( rEC_SEL_ERROR_ID )
  62 import Maybes
  63 import SrcLoc           ( SrcLoc )
  64 import BasicTypes       ( Arity )
  65 import Unique           ( Unique )
  66 import Maybe            ( isJust )
  67 import Outputable
  68 import Util             ( assoc )
  69 \end{code}
  70
  71
  72 %************************************************************************
  73 %*                                                                      *
  74 \subsection{Easy ones}
  75 %*                                                                      *
  76 %************************************************************************
  77
  78 \begin{code}
  79 mkImportedId :: Name -> ty -> IdInfo -> GenId ty
  80 mkImportedId name ty info = mkId name ty (VanillaId True) info
  81
  82 -- SysLocal: for an Id being created by the compiler out of thin air...
  83 -- UserLocal: an Id with a name the user might recognize...
  84 mkSysLocal  :: FAST_STRING -> Unique -> (GenType flexi) -> SrcLoc -> GenId (GenType flexi)
  85 mkUserLocal :: OccName     -> Unique -> (GenType flexi) -> SrcLoc -> GenId (GenType flexi)
  86
  87 mkSysLocal str uniq ty loc
  88   = mkVanillaId (mkSysLocalName uniq str loc) ty noIdInfo
  89
  90 mkUserLocal occ uniq ty loc
  91   = mkVanillaId (mkLocalName uniq occ loc) ty noIdInfo
  92
  93 mkUserId :: Name -> GenType flexi -> GenId (GenType flexi)
  94 mkUserId name ty
  95   = mkVanillaId name ty noIdInfo
  96
  97 mkDefaultMethodId dm_name rec_c ty
  98   = mkVanillaId dm_name ty noIdInfo
  99
 100 mkDictFunId dfun_name full_ty clas itys
 101   = mkVanillaId dfun_name full_ty noIdInfo
 102
 103 mkWorkerId uniq unwrkr ty info
 104   = mkVanillaId name ty info
 105   where
 106     name            = mkCompoundName name_fn uniq (getName unwrkr)
 107     name_fn wkr_str = SLIT("$w") _APPEND_ wkr_str
 108 \end{code}
 109
 110
 111 %************************************************************************
 112 %*                                                                      *
 113 \subsection{Data constructors}
 114 %*                                                                      *
 115 %************************************************************************
 116
 117 \begin{code}
 118 mkDataCon :: Name
 119           -> [StrictnessMark] -> [FieldLabel]
 120           -> [TyVar] -> ThetaType
 121           -> [TyVar] -> ThetaType
 122           -> [TauType] -> TyCon
 123           -> Id
 124   -- can get the tag and all the pieces of the type from the Type
 125
 126 mkDataCon name stricts fields tvs ctxt con_tvs con_ctxt args_tys tycon
 127   = ASSERT(length stricts == length args_tys)
 128     data_con
 129   where
 130     -- NB: data_con self-recursion; should be OK as tags are not
 131     -- looked at until late in the game.
 132     data_con = mkId name data_con_ty details (dataConInfo data_con)
 133     details  = AlgConId data_con_tag stricts fields tvs ctxt con_tvs con_ctxt args_tys tycon
 134
 135     data_con_tag    = assoc "mkDataCon" (data_con_family `zip` [fIRST_TAG..]) data_con
 136     data_con_family = tyConDataCons tycon
 137     data_con_ty     = mkSigmaTy (tvs++con_tvs) (ctxt++con_ctxt)
 138                                 (mkFunTys args_tys (mkTyConApp tycon (mkTyVarTys tvs)))
 139
 140
 141 mkTupleCon :: Arity -> Name -> Type -> Id
 142 mkTupleCon arity name ty
 143   = con_id
 144   where
 145     con_id = mkId name ty (TupleConId arity) (dataConInfo con_id)
 146 \end{code}
 147
 148 We're going to build a constructor that looks like:
 149
 150         data (Data a, C b) =>  T a b = T1 !a !Int b
 151
 152         T1 = /\ a b ->
 153              \d1::Data a, d2::C b ->
 154              \p q r -> case p of { p ->
 155                        case q of { q ->
 156                        Con T1 [a,b] [p,q,r]}}
 157
 158 Notice that
 159
 160 * d2 is thrown away --- a context in a data decl is used to make sure
 161   one *could* construct dictionaries at the site the constructor
 162   is used, but the dictionary isn't actually used.
 163
 164 * We have to check that we can construct Data dictionaries for
 165   the types a and Int.  Once we've done that we can throw d1 away too.
 166
 167 * We use (case p of ...) to evaluate p, rather than "seq" because
 168   all that matters is that the arguments are evaluated.  "seq" is
 169   very careful to preserve evaluation order, which we don't need
 170   to be here.
 171
 172 \begin{code}
 173 dataConInfo :: Id -> IdInfo
 174
 175 dataConInfo con_id
 176   = setInlinePragInfo IWantToBeINLINEd $
 177                 -- Always inline constructors if possible
 178     setArityInfo (exactArity (length locals)) $
 179     setUnfoldingInfo unfolding $
 180     noIdInfo
 181   where
 182         unfolding = mkUnfolding con_rhs
 183
 184         (tyvars, theta, con_tyvars, con_theta, arg_tys, tycon) = dataConSig con_id
 185
 186         dict_tys     = [mkDictTy clas tys | (clas,tys) <- theta]
 187         con_dict_tys = [mkDictTy clas tys | (clas,tys) <- con_theta]
 188         n_dicts      = length dict_tys
 189         result_ty    = mkTyConApp tycon (mkTyVarTys tyvars)
 190
 191         locals        = mkTemplateLocals (dict_tys ++ con_dict_tys ++ arg_tys)
 192         data_args     = drop n_dicts locals
 193         (data_arg1:_) = data_args               -- Used for newtype only
 194         strict_marks  = dataConStrictMarks con_id
 195         strict_args   = [arg | (arg,MarkedStrict) <- data_args `zip` strict_marks]
 196                 -- NB: we can't call mkTemplateLocals twice, because it
 197                 -- always starts from the same unique.
 198
 199         con_app | isNewTyCon tycon
 200                 = ASSERT( length arg_tys == 1)
 201                   Note (Coerce result_ty (head arg_tys)) (Var data_arg1)
 202                 | otherwise
 203                 = Con con_id (map TyArg (mkTyVarTys tyvars) ++ map VarArg data_args)
 204
 205         con_rhs = mkTyLam tyvars $
 206                   mkValLam locals $
 207                   foldr mk_case con_app strict_args
 208
 209         mk_case arg body | isUnpointedType (idType arg)
 210                          = body                 -- "!" on unboxed arg does nothing
 211                          | otherwise
 212                          = Case (Var arg) (AlgAlts [] (BindDefault arg body))
 213                                 -- This case shadows "arg" but that's fine
 214 \end{code}
 215
 216
 217 %************************************************************************
 218 %*                                                                      *
 219 \subsection{Record selectors}
 220 %*                                                                      *
 221 %************************************************************************
 222
 223 We're going to build a record selector unfolding that looks like this:
 224
 225         data T a b c = T1 { ..., op :: a, ...}
 226                      | T2 { ..., op :: a, ...}
 227                      | T3
 228
 229         sel = /\ a b c -> \ d -> case d of
 230                                     T1 ... x ... -> x
 231                                     T2 ... x ... -> x
 232                                     other        -> error "..."
 233
 234 \begin{code}
 235 mkRecordSelId field_label selector_ty
 236   = ASSERT( null theta && isDataTyCon tycon )
 237     sel_id
 238   where
 239     sel_id = mkId (fieldLabelName field_label) selector_ty
 240                   (RecordSelId field_label) info
 241
 242     info = exactArity 1 `setArityInfo` (
 243            unfolding    `setUnfoldingInfo`
 244            noIdInfo)
 245         -- ToDo: consider adding further IdInfo
 246
 247     unfolding = mkUnfolding sel_rhs
 248
 249     (tyvars, theta, tau)  = splitSigmaTy selector_ty
 250     (data_ty,rhs_ty)      = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
 251                                         -- tau is of form (T a b c -> field-type)
 252     (tycon, _, data_cons) = splitAlgTyConApp data_ty
 253     tyvar_tys             = mkTyVarTys tyvars
 254
 255     [data_id] = mkTemplateLocals [data_ty]
 256     alts      = map mk_maybe_alt data_cons
 257     sel_rhs   = mkTyLam tyvars $
 258                 mkValLam [data_id] $
 259                 Case (Var data_id)
 260                          -- if any of the constructors don't have the label, ...
 261                      (if any (not . isJust) alts then
 262                            AlgAlts (catMaybes alts)
 263                                    (BindDefault data_id error_expr)
 264                       else
 265                            AlgAlts (catMaybes alts) NoDefault)
 266
 267     mk_maybe_alt data_con
 268           = case maybe_the_arg_id of
 269                 Nothing         -> Nothing
 270                 Just the_arg_id -> Just (data_con, arg_ids, Var the_arg_id)
 271           where
 272             arg_ids          = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
 273                                     -- The first one will shadow data_id, but who cares
 274             field_lbls       = dataConFieldLabels data_con
 275             maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
 276
 277     error_expr = mkApp (Var rEC_SEL_ERROR_ID) [rhs_ty] [LitArg msg_lit]
 278     full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id])
 279     msg_lit    = NoRepStr (_PK_ full_msg)
 280 \end{code}
 281
 282
 283 %************************************************************************
 284 %*                                                                      *
 285 \subsection{Dictionary selectors}
 286 %*                                                                      *
 287 %************************************************************************
 288
 289 \begin{code}
 290 mkSuperDictSelId :: Unique -> Class -> FieldLabelTag -> Type -> Id
 291         -- The FieldLabelTag says which superclass is selected
 292         -- So, for
 293         --      class (C a, C b) => Foo a b where ...
 294         -- we get superclass selectors
 295         --      Foo_sc1, Foo_sc2
 296
 297 mkSuperDictSelId uniq clas index ty
 298   = mkDictSelId name clas ty
 299   where
 300     name    = mkCompoundName name_fn uniq (getName clas)
 301     name_fn clas_str = clas_str _APPEND_ SLIT("_sc") _APPEND_ (_PK_ (show index))
 302
 303         -- For method selectors the clean thing to do is
 304         -- to give the method selector the same name as the class op itself.
 305 mkMethodSelId name clas ty
 306   = mkDictSelId name clas ty
 307 \end{code}
 308
 309 Selecting a field for a dictionary.  If there is just one field, then
 310 there's nothing to do.
 311
 312 \begin{code}
 313 mkDictSelId name clas ty
 314   = sel_id
 315   where
 316     sel_id    = mkId name ty (RecordSelId field_lbl) info
 317     field_lbl = mkFieldLabel name ty tag
 318     tag       = assoc "MkId.mkDictSelId" ((sc_sel_ids ++ op_sel_ids) `zip` allFieldLabelTags) sel_id
 319
 320     info      = setInlinePragInfo IWantToBeINLINEd $
 321                 setUnfoldingInfo  unfolding noIdInfo
 322         -- The always-inline thing means we don't need any other IdInfo
 323
 324     unfolding = mkUnfolding rhs
 325
 326     (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
 327
 328     tycon      = classTyCon clas
 329     [data_con] = tyConDataCons tycon
 330     tyvar_tys  = mkTyVarTys tyvars
 331     arg_tys    = dataConArgTys data_con tyvar_tys
 332     the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
 333
 334     dict_ty    = mkDictTy clas tyvar_tys
 335     (dict_id:arg_ids) = mkTemplateLocals (dict_ty : arg_tys)
 336
 337     rhs | isNewTyCon tycon = mkLam tyvars [dict_id] $
 338                              Note (Coerce (head arg_tys) dict_ty) (Var dict_id)
 339         | otherwise        = mkLam tyvars [dict_id] $
 340                              Case (Var dict_id) $
 341                              AlgAlts [(data_con, arg_ids, Var the_arg_id)] NoDefault
 342 \end{code}
 343
 344
 345 %************************************************************************
 346 %*                                                                      *
 347 \subsection{Primitive operations
 348 %*                                                                      *
 349 %************************************************************************
 350
 351
 352 \begin{code}
 353 mkPrimitiveId name ty prim_op
 354   = mkId name ty (PrimitiveId prim_op) info
 355   where
 356
 357     info = setUnfoldingInfo unfolding $
 358            setInlinePragInfo IMustBeINLINEd $
 359                 -- The pragma @IMustBeINLINEd@ says that this Id absolutely
 360                 -- must be inlined.  It's only used for primitives,
 361                 -- because we don't want to make a closure for each of them.
 362            noIdInfo
 363
 364     unfolding = mkUnfolding rhs
 365
 366     (tyvars, tau) = splitForAllTys ty
 367     (arg_tys, _)  = splitFunTys tau
 368
 369     args = mkTemplateLocals arg_tys
 370     rhs =  mkLam tyvars args $
 371            Prim prim_op
 372                 ([TyArg (mkTyVarTy tv) | tv <- tyvars] ++
 373                  [VarArg v | v <- args])
 374 \end{code}
 375
 376
 377 %************************************************************************
 378 %*                                                                      *
 379 \subsection{Catch-all}
 380 %*                                                                      *
 381 %************************************************************************
 382
 383 \begin{code}
 384 addStandardIdInfo id
 385   = pprTrace "addStandardIdInfo missing:" (ppr id) id
 386 \end{code}
 387