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