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     the_alts  = catMaybes alts
 262
 263     sel_rhs   = mkTyLam tyvars $
 264                 mkValLam [data_id] $
 265                 Case (Var data_id)
 266                          -- if any of the constructors don't have the label, ...
 267                      (if any (not . isJust) alts then
 268                            AlgAlts the_alts(BindDefault data_id error_expr)
 269                       else
 270                            AlgAlts the_alts NoDefault)
 271
 272     mk_maybe_alt data_con
 273           = case maybe_the_arg_id of
 274                 Nothing         -> Nothing
 275                 Just the_arg_id -> Just (data_con, arg_ids, Var the_arg_id)
 276           where
 277             arg_ids          = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
 278                                     -- The first one will shadow data_id, but who cares
 279             field_lbls       = dataConFieldLabels data_con
 280             maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
 281
 282     error_expr = mkApp (Var rEC_SEL_ERROR_ID) [rhs_ty] [LitArg msg_lit]
 283     full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id])
 284     msg_lit    = NoRepStr (_PK_ full_msg)
 285 \end{code}
 286
 287
 288 %************************************************************************
 289 %*                                                                      *
 290 \subsection{Dictionary selectors}
 291 %*                                                                      *
 292 %************************************************************************
 293
 294 \begin{code}
 295 mkSuperDictSelId :: Unique -> Class -> FieldLabelTag -> Type -> Id
 296         -- The FieldLabelTag says which superclass is selected
 297         -- So, for
 298         --      class (C a, C b) => Foo a b where ...
 299         -- we get superclass selectors
 300         --      Foo_sc1, Foo_sc2
 301
 302 mkSuperDictSelId uniq clas index ty
 303   = mkDictSelId name clas ty
 304   where
 305     name    = mkCompoundName name_fn uniq (getName clas)
 306     name_fn clas_str = clas_str _APPEND_ SLIT("_sc") _APPEND_ (_PK_ (show index))
 307
 308         -- For method selectors the clean thing to do is
 309         -- to give the method selector the same name as the class op itself.
 310 mkMethodSelId name clas ty
 311   = mkDictSelId name clas ty
 312 \end{code}
 313
 314 Selecting a field for a dictionary.  If there is just one field, then
 315 there's nothing to do.
 316
 317 \begin{code}
 318 mkDictSelId name clas ty
 319   = sel_id
 320   where
 321     sel_id    = mkId name ty (RecordSelId field_lbl) info
 322     field_lbl = mkFieldLabel name ty tag
 323     tag       = assoc "MkId.mkDictSelId" ((sc_sel_ids ++ op_sel_ids) `zip` allFieldLabelTags) sel_id
 324
 325     info      = setInlinePragInfo IMustBeINLINEd $
 326                 setUnfoldingInfo  unfolding noIdInfo
 327         -- The always-inline thing means we don't need any other IdInfo
 328         -- We need "Must" inline because we don't create any bindigs for
 329         -- the selectors.
 330
 331     unfolding = mkUnfolding rhs
 332
 333     (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
 334
 335     tycon      = classTyCon clas
 336     [data_con] = tyConDataCons tycon
 337     tyvar_tys  = mkTyVarTys tyvars
 338     arg_tys    = dataConArgTys data_con tyvar_tys
 339     the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
 340
 341     dict_ty    = mkDictTy clas tyvar_tys
 342     (dict_id:arg_ids) = mkTemplateLocals (dict_ty : arg_tys)
 343
 344     rhs | isNewTyCon tycon = mkLam tyvars [dict_id] $
 345                              Note (Coerce (head arg_tys) dict_ty) (Var dict_id)
 346         | otherwise        = mkLam tyvars [dict_id] $
 347                              Case (Var dict_id) $
 348                              AlgAlts [(data_con, arg_ids, Var the_arg_id)] NoDefault
 349 \end{code}
 350
 351
 352 %************************************************************************
 353 %*                                                                      *
 354 \subsection{Primitive operations
 355 %*                                                                      *
 356 %************************************************************************
 357
 358
 359 \begin{code}
 360 mkPrimitiveId name ty prim_op
 361   = mkId name ty (PrimitiveId prim_op) info
 362   where
 363
 364     info = setUnfoldingInfo unfolding $
 365            setInlinePragInfo IMustBeINLINEd $
 366                 -- The pragma @IMustBeINLINEd@ says that this Id absolutely
 367                 -- must be inlined.  It's only used for primitives,
 368                 -- because we don't want to make a closure for each of them.
 369            noIdInfo
 370
 371     unfolding = mkUnfolding rhs
 372
 373     (tyvars, tau) = splitForAllTys ty
 374     (arg_tys, _)  = splitFunTys tau
 375
 376     args = mkTemplateLocals arg_tys
 377     rhs =  mkLam tyvars args $
 378            Prim prim_op
 379                 ([TyArg (mkTyVarTy tv) | tv <- tyvars] ++
 380                  [VarArg v | v <- args])
 381 \end{code}
 382
 383
 384 %************************************************************************
 385 %*                                                                      *
 386 \subsection{Catch-all}
 387 %*                                                                      *
 388 %************************************************************************
 389
 390 \begin{code}
 391 addStandardIdInfo id
 392   = pprTrace "addStandardIdInfo missing:" (ppr id) id
 393 \end{code}
 394