ghc/compiler/prelude/StdIdInfo.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 #include "HsVersions.h"
  16
  17 module StdIdInfo (
  18         addStandardIdInfo
  19     ) where
  20
  21 IMP_Ubiq()
  22
  23 import Type
  24 import TyVar            ( alphaTyVar )
  25 import CmdLineOpts      ( opt_PprUserLength )
  26 import CoreSyn
  27 import Literal
  28 import CoreUnfold       ( mkUnfolding, PragmaInfo(..) )
  29 import TysWiredIn       ( tupleCon )
  30 import Id               ( GenId, mkTemplateLocals, idType,
  31                           dataConStrictMarks, dataConFieldLabels, dataConArgTys,
  32                           recordSelectorFieldLabel, dataConSig,
  33                           StrictnessMark(..),
  34                           isAlgCon, isMethodSelId_maybe, isSuperDictSelId_maybe,
  35                           isRecordSelector, isPrimitiveId_maybe,
  36                           addIdUnfolding, addIdArity,
  37                           SYN_IE(Id)
  38                         )
  39 import IdInfo           ( ArityInfo, exactArity )
  40 import Class            ( GenClass, classBigSig, classDictArgTys )
  41 import TyCon            ( isNewTyCon, isDataTyCon, isAlgTyCon )
  42 import FieldLabel       ( FieldLabel )
  43 import PrelVals         ( pAT_ERROR_ID )
  44 import Maybes
  45 import Outputable       ( PprStyle(..), Outputable(..) )
  46 import Pretty
  47 import Util             ( assertPanic, pprTrace,
  48                           assoc
  49                         )
  50 \end{code}
  51
  52
  53 %************************************************************************
  54 %*                                                                      *
  55 \subsection{Data constructors}
  56 %*                                                                      *
  57 %************************************************************************
  58
  59 We're going to build a constructor that looks like:
  60
  61         data (Data a, C b) =>  T a b = T1 !a !Int b
  62
  63         T1 = /\ a b ->
  64              \d1::Data a, d2::C b ->
  65              \p q r -> case p of { p ->
  66                        case q of { q ->
  67                        Con T1 [a,b] [p,q,r]}}
  68
  69 Notice that
  70
  71 * d2 is thrown away --- a context in a data decl is used to make sure
  72   one *could* construct dictionaries at the site the constructor
  73   is used, but the dictionary isn't actually used.
  74
  75 * We have to check that we can construct Data dictionaries for
  76   the types a and Int.  Once we've done that we can throw d1 away too.
  77
  78 * We use (case p of ...) to evaluate p, rather than "seq" because
  79   all that matters is that the arguments are evaluated.  "seq" is
  80   very careful to preserve evaluation order, which we don't need
  81   to be here.
  82
  83 \begin{code}
  84 addStandardIdInfo :: Id -> Id
  85
  86 addStandardIdInfo con_id
  87
  88   | isAlgCon con_id
  89   = con_id `addIdUnfolding` unfolding
  90            `addIdArity` exactArity (length locals)
  91   where
  92         unfolding = mkUnfolding IWantToBeINLINEd {- Always inline constructors -} con_rhs
  93
  94         (tyvars, theta, con_tyvars, con_theta, arg_tys, tycon) = dataConSig con_id
  95
  96         dict_tys     = [mkDictTy clas ty | (clas,ty) <- theta]
  97         con_dict_tys = [mkDictTy clas ty | (clas,ty) <- con_theta]
  98         n_dicts      = length dict_tys
  99         result_ty    = applyTyCon tycon (mkTyVarTys tyvars)
 100
 101         locals        = mkTemplateLocals (dict_tys ++ con_dict_tys ++ arg_tys)
 102         data_args     = drop n_dicts locals
 103         (data_arg1:_) = data_args               -- Used for newtype only
 104         strict_marks  = dataConStrictMarks con_id
 105         strict_args   = [arg | (arg,MarkedStrict) <- data_args `zip` strict_marks]
 106                 -- NB: we can't call mkTemplateLocals twice, because it
 107                 -- always starts from the same unique.
 108
 109         con_app | isNewTyCon tycon
 110                 = ASSERT( length arg_tys == 1)
 111                   Coerce (CoerceIn con_id) result_ty (Var data_arg1)
 112                 | otherwise
 113                 = Con con_id (map TyArg (mkTyVarTys tyvars) ++ map VarArg data_args)
 114
 115         con_rhs = mkTyLam tyvars $
 116                   mkValLam locals $
 117                   foldr mk_case con_app strict_args
 118
 119         mk_case arg body | isUnboxedType (idType arg)
 120                          = body                 -- "!" on unboxed arg does nothing
 121                          | otherwise
 122                          = Case (Var arg) (AlgAlts [] (BindDefault arg body))
 123                                 -- This case shadows "arg" but that's fine
 124 \end{code}
 125
 126
 127 %************************************************************************
 128 %*                                                                      *
 129 \subsection{Record selectors}
 130 %*                                                                      *
 131 %************************************************************************
 132
 133 We're going to build a record selector that looks like this:
 134
 135         data T a b c = T1 { ..., op :: a, ...}
 136                      | T2 { ..., op :: a, ...}
 137                      | T3
 138
 139         sel = /\ a b c -> \ d -> case d of
 140                                     T1 ... x ... -> x
 141                                     T2 ... x ... -> x
 142                                     other        -> error "..."
 143
 144 \begin{code}
 145 addStandardIdInfo sel_id
 146   | isRecordSelector sel_id
 147   = ASSERT( null theta && isDataTyCon tycon )
 148     sel_id `addIdUnfolding` unfolding
 149            `addIdArity` exactArity 1
 150         -- ToDo: consider adding further IdInfo
 151   where
 152         unfolding = mkUnfolding NoPragmaInfo {- Don't inline every selector -} sel_rhs
 153
 154         (tyvars, theta, tau)  = splitSigmaTy (idType sel_id)
 155         field_lbl             = recordSelectorFieldLabel sel_id
 156         (data_ty,rhs_ty)      = expectJust "StdIdInfoRec" (getFunTy_maybe tau)
 157                                         -- tau is of form (T a b c -> field-type)
 158         (tycon, _, data_cons) = getAppDataTyCon data_ty
 159         tyvar_tys             = mkTyVarTys tyvars
 160
 161         [data_id] = mkTemplateLocals [data_ty]
 162         sel_rhs = mkTyLam tyvars $
 163                   mkValLam [data_id] $
 164                   Case (Var data_id) (AlgAlts (catMaybes (map mk_maybe_alt data_cons))
 165                                               (BindDefault data_id error_expr))
 166         mk_maybe_alt data_con
 167           = case maybe_the_arg_id of
 168                 Nothing         -> Nothing
 169                 Just the_arg_id -> Just (data_con, arg_ids, Var the_arg_id)
 170           where
 171             arg_ids          = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
 172                                     -- The first one will shadow data_id, but who cares
 173             field_lbls       = dataConFieldLabels data_con
 174             maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_lbl
 175
 176         error_expr = mkApp (Var pAT_ERROR_ID) [] [rhs_ty] [LitArg msg_lit]
 177         full_msg   = show (sep [text "No match in record selector", ppr (PprForUser opt_PprUserLength) sel_id])
 178         msg_lit    = NoRepStr (_PK_ full_msg)
 179 \end{code}
 180
 181
 182 %************************************************************************
 183 %*                                                                      *
 184 \subsection{Super selectors}
 185 %*                                                                      *
 186 %************************************************************************
 187
 188 \begin{code}
 189 addStandardIdInfo sel_id
 190   | maybeToBool maybe_sc_sel_id
 191   = sel_id `addIdUnfolding` (mk_selector_unfolding cls sel_id)
 192   where
 193     maybe_sc_sel_id    = isSuperDictSelId_maybe sel_id
 194     Just (cls, _) = maybe_sc_sel_id
 195
 196 addStandardIdInfo sel_id
 197   | maybeToBool maybe_meth_sel_id
 198   = sel_id `addIdUnfolding` (mk_selector_unfolding cls sel_id)
 199   where
 200     maybe_meth_sel_id  = isMethodSelId_maybe sel_id
 201     Just cls = maybe_meth_sel_id
 202 \end{code}
 203
 204
 205 %************************************************************************
 206 %*                                                                      *
 207 \subsection{Primitive operations
 208 %*                                                                      *
 209 %************************************************************************
 210
 211
 212 \begin{code}
 213 addStandardIdInfo prim_id
 214   | maybeToBool maybe_prim_id
 215   = prim_id `addIdUnfolding` unfolding
 216   where
 217     maybe_prim_id = isPrimitiveId_maybe prim_id
 218     Just prim_op  = maybe_prim_id
 219
 220     unfolding = mkUnfolding IWantToBeINLINEd {- Always inline PrimOps -} rhs
 221
 222     (tyvars, tau) = splitForAllTy (idType prim_id)
 223     (arg_tys, _)  = splitFunTy tau
 224
 225     args = mkTemplateLocals arg_tys
 226     rhs =  mkLam tyvars args $
 227            Prim prim_op
 228                 ([TyArg (mkTyVarTy tv) | tv <- tyvars] ++
 229                  [VarArg v | v <- args])
 230 \end{code}
 231
 232
 233 %************************************************************************
 234 %*                                                                      *
 235 \subsection{Catch-all}
 236 %*                                                                      *
 237 %************************************************************************
 238
 239 \begin{code}
 240 addStandardIdInfo id
 241   = pprTrace "addStandardIdInfo missing:" (ppr PprDebug id) id
 242 \end{code}
 243
 244
 245 %************************************************************************
 246 %*                                                                      *
 247 \subsection{Dictionary selector help function
 248 %*                                                                      *
 249 %************************************************************************
 250
 251 Selecting a field for a dictionary.  If there is just one field, then
 252 there's nothing to do.
 253
 254 \begin{code}
 255 mk_selector_unfolding clas sel_id
 256   = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs
 257         -- The always-inline thing means we don't need any other IdInfo
 258   where
 259     rhs        = mk_dict_selector [alphaTyVar] dict_id arg_ids the_arg_id
 260     tyvar_ty   = mkTyVarTy alphaTyVar
 261     [dict_id]  = mkTemplateLocals [mkDictTy clas tyvar_ty]
 262     arg_tys    = classDictArgTys clas tyvar_ty
 263     arg_ids    = mkTemplateLocals arg_tys
 264     the_arg_id = assoc "StdIdInfo:mk_sel" ((sc_sel_ids ++ op_sel_ids) `zip` arg_ids) sel_id
 265
 266     (_, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
 267
 268 mk_dict_selector tyvars dict_id [arg_id] the_arg_id
 269   = mkLam tyvars [dict_id] (Var dict_id)
 270
 271 mk_dict_selector tyvars dict_id arg_ids the_arg_id
 272   = mkLam tyvars [dict_id] $
 273     Case (Var dict_id) (AlgAlts [(tup_con, arg_ids, Var the_arg_id)] NoDefault)
 274   where
 275     tup_con = tupleCon (length arg_ids)
 276 \end{code}