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 IMustBeINLINEd $
 181                 -- Always inline constructors; we don't create a binding for them
 182                 -- (well, at least not for dict constructors, since they are
 183                 --  always applied)
 184     setArityInfo (exactArity (length locals)) $
 185     setUnfoldingInfo unfolding $
 186     noIdInfo
 187   where
 188         unfolding = mkUnfolding con_rhs
 189
 190         (tyvars, theta, con_tyvars, con_theta, arg_tys, tycon) = dataConSig con_id
 191
 192         dict_tys     = [mkDictTy clas tys | (clas,tys) <- theta]
 193         con_dict_tys = [mkDictTy clas tys | (clas,tys) <- con_theta]
 194         n_dicts      = length dict_tys
 195         result_ty    = mkTyConApp tycon (mkTyVarTys tyvars)
 196
 197         locals        = mkTemplateLocals (dict_tys ++ con_dict_tys ++ arg_tys)
 198         data_args     = drop n_dicts locals
 199         (data_arg1:_) = data_args               -- Used for newtype only
 200         strict_marks  = dataConStrictMarks con_id
 201         strict_args   = [arg | (arg,MarkedStrict) <- data_args `zip` strict_marks]
 202                 -- NB: we can't call mkTemplateLocals twice, because it
 203                 -- always starts from the same unique.
 204
 205         con_app | isNewTyCon tycon
 206                 = ASSERT( length arg_tys == 1)
 207                   Note (Coerce result_ty (head arg_tys)) (Var data_arg1)
 208                 | otherwise
 209                 = Con con_id (map TyArg (mkTyVarTys tyvars) ++ map VarArg data_args)
 210
 211         con_rhs = mkTyLam tyvars $
 212                   mkValLam locals $
 213                   foldr mk_case con_app strict_args
 214
 215         mk_case arg body | isUnpointedType (idType arg)
 216                          = body                 -- "!" on unboxed arg does nothing
 217                          | otherwise
 218                          = Case (Var arg) (AlgAlts [] (BindDefault arg body))
 219                                 -- This case shadows "arg" but that's fine
 220 \end{code}
 221
 222
 223 %************************************************************************
 224 %*                                                                      *
 225 \subsection{Record selectors}
 226 %*                                                                      *
 227 %************************************************************************
 228
 229 We're going to build a record selector unfolding that looks like this:
 230
 231         data T a b c = T1 { ..., op :: a, ...}
 232                      | T2 { ..., op :: a, ...}
 233                      | T3
 234
 235         sel = /\ a b c -> \ d -> case d of
 236                                     T1 ... x ... -> x
 237                                     T2 ... x ... -> x
 238                                     other        -> error "..."
 239
 240 \begin{code}
 241 mkRecordSelId field_label selector_ty
 242   = ASSERT( null theta && isDataTyCon tycon )
 243     sel_id
 244   where
 245     sel_id = mkId (fieldLabelName field_label) selector_ty
 246                   (RecordSelId field_label) info
 247
 248     info = exactArity 1 `setArityInfo` (
 249            unfolding    `setUnfoldingInfo`
 250            noIdInfo)
 251         -- ToDo: consider adding further IdInfo
 252
 253     unfolding = mkUnfolding sel_rhs
 254
 255     (tyvars, theta, tau)  = splitSigmaTy selector_ty
 256     (data_ty,rhs_ty)      = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
 257                                         -- tau is of form (T a b c -> field-type)
 258     (tycon, _, data_cons) = splitAlgTyConApp data_ty
 259     tyvar_tys             = mkTyVarTys tyvars
 260
 261     [data_id] = mkTemplateLocals [data_ty]
 262     alts      = map mk_maybe_alt data_cons
 263     the_alts  = catMaybes alts
 264
 265     sel_rhs   = mkTyLam tyvars $
 266                 mkValLam [data_id] $
 267                 Case (Var data_id)
 268                          -- if any of the constructors don't have the label, ...
 269                      (if any (not . isJust) alts then
 270                            AlgAlts the_alts(BindDefault data_id error_expr)
 271                       else
 272                            AlgAlts the_alts NoDefault)
 273
 274     mk_maybe_alt data_con
 275           = case maybe_the_arg_id of
 276                 Nothing         -> Nothing
 277                 Just the_arg_id -> Just (data_con, arg_ids, Var the_arg_id)
 278           where
 279             arg_ids          = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
 280                                     -- The first one will shadow data_id, but who cares
 281             field_lbls       = dataConFieldLabels data_con
 282             maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
 283
 284     error_expr = mkApp (Var rEC_SEL_ERROR_ID) [rhs_ty] [LitArg msg_lit]
 285     full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id])
 286     msg_lit    = NoRepStr (_PK_ full_msg)
 287 \end{code}
 288
 289
 290 %************************************************************************
 291 %*                                                                      *
 292 \subsection{Dictionary selectors}
 293 %*                                                                      *
 294 %************************************************************************
 295
 296 \begin{code}
 297 mkSuperDictSelId :: Unique -> Class -> FieldLabelTag -> Type -> Id
 298         -- The FieldLabelTag says which superclass is selected
 299         -- So, for
 300         --      class (C a, C b) => Foo a b where ...
 301         -- we get superclass selectors
 302         --      Foo_sc1, Foo_sc2
 303
 304 mkSuperDictSelId uniq clas index ty
 305   = mkDictSelId name clas ty
 306   where
 307     name    = mkCompoundName name_fn uniq (getName clas)
 308     name_fn clas_str = clas_str _APPEND_ SLIT("_sc") _APPEND_ (_PK_ (show index))
 309
 310         -- For method selectors the clean thing to do is
 311         -- to give the method selector the same name as the class op itself.
 312 mkMethodSelId name clas ty
 313   = mkDictSelId name clas ty
 314 \end{code}
 315
 316 Selecting a field for a dictionary.  If there is just one field, then
 317 there's nothing to do.
 318
 319 \begin{code}
 320 mkDictSelId name clas ty
 321   = sel_id
 322   where
 323     sel_id    = mkId name ty (RecordSelId field_lbl) info
 324     field_lbl = mkFieldLabel name ty tag
 325     tag       = assoc "MkId.mkDictSelId" ((sc_sel_ids ++ op_sel_ids) `zip` allFieldLabelTags) sel_id
 326
 327     info      = setInlinePragInfo IMustBeINLINEd $
 328                 setUnfoldingInfo  unfolding noIdInfo
 329         -- The always-inline thing means we don't need any other IdInfo
 330         -- We need "Must" inline because we don't create any bindigs for
 331         -- the selectors.
 332
 333     unfolding = mkUnfolding rhs
 334
 335     (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
 336
 337     tycon      = classTyCon clas
 338     [data_con] = tyConDataCons tycon
 339     tyvar_tys  = mkTyVarTys tyvars
 340     arg_tys    = dataConArgTys data_con tyvar_tys
 341     the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
 342
 343     dict_ty    = mkDictTy clas tyvar_tys
 344     (dict_id:arg_ids) = mkTemplateLocals (dict_ty : arg_tys)
 345
 346     rhs | isNewTyCon tycon = mkLam tyvars [dict_id] $
 347                              Note (Coerce (head arg_tys) dict_ty) (Var dict_id)
 348         | otherwise        = mkLam tyvars [dict_id] $
 349                              Case (Var dict_id) $
 350                              AlgAlts [(data_con, arg_ids, Var the_arg_id)] NoDefault
 351 \end{code}
 352
 353
 354 %************************************************************************
 355 %*                                                                      *
 356 \subsection{Primitive operations
 357 %*                                                                      *
 358 %************************************************************************
 359
 360
 361 \begin{code}
 362 mkPrimitiveId name ty prim_op
 363   = mkId name ty (PrimitiveId prim_op) info
 364   where
 365
 366     info = setUnfoldingInfo unfolding $
 367            setInlinePragInfo IMustBeINLINEd $
 368                 -- The pragma @IMustBeINLINEd@ says that this Id absolutely
 369                 -- must be inlined.  It's only used for primitives,
 370                 -- because we don't want to make a closure for each of them.
 371            noIdInfo
 372
 373     unfolding = mkUnfolding rhs
 374
 375     (tyvars, tau) = splitForAllTys ty
 376     (arg_tys, _)  = splitFunTys tau
 377
 378     args = mkTemplateLocals arg_tys
 379     rhs =  mkLam tyvars args $
 380            Prim prim_op
 381                 ([TyArg (mkTyVarTy tv) | tv <- tyvars] ++
 382                  [VarArg v | v <- args])
 383 \end{code}
 384
 385
 386 %************************************************************************
 387 %*                                                                      *
 388 \subsection{Catch-all}
 389 %*                                                                      *
 390 %************************************************************************
 391
 392 \begin{code}
 393 addStandardIdInfo id
 394   = pprTrace "addStandardIdInfo missing:" (ppr id) id
 395 \end{code}
 396