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