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