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