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               ( mkTemplateLocals, idType,
  28                           dataConStrictMarks, dataConFieldLabels, dataConArgTys,
  29                           recordSelectorFieldLabel, dataConSig,
  30                           StrictnessMark(..),
  31                           isAlgCon, isDictSelId_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, isDataTyCon )
  39 import FieldLabel       ( FieldLabel )
  40 import PrelVals         ( pAT_ERROR_ID )
  41 import Maybes
  42 import Maybe            ( isJust )
  43 import Outputable
  44 import Util             ( assoc )
  45 \end{code}
  46
  47
  48 %************************************************************************
  49 %*                                                                      *
  50 \subsection{Data constructors}
  51 %*                                                                      *
  52 %************************************************************************
  53
  54 We're going to build a constructor that looks like:
  55
  56         data (Data a, C b) =>  T a b = T1 !a !Int b
  57
  58         T1 = /\ a b ->
  59              \d1::Data a, d2::C b ->
  60              \p q r -> case p of { p ->
  61                        case q of { q ->
  62                        Con T1 [a,b] [p,q,r]}}
  63
  64 Notice that
  65
  66 * d2 is thrown away --- a context in a data decl is used to make sure
  67   one *could* construct dictionaries at the site the constructor
  68   is used, but the dictionary isn't actually used.
  69
  70 * We have to check that we can construct Data dictionaries for
  71   the types a and Int.  Once we've done that we can throw d1 away too.
  72
  73 * We use (case p of ...) to evaluate p, rather than "seq" because
  74   all that matters is that the arguments are evaluated.  "seq" is
  75   very careful to preserve evaluation order, which we don't need
  76   to be here.
  77
  78 \begin{code}
  79 addStandardIdInfo :: Id -> Id
  80
  81 addStandardIdInfo con_id
  82
  83   | isAlgCon con_id
  84   = con_id `addIdUnfolding` unfolding
  85            `addIdArity` exactArity (length locals)
  86   where
  87         unfolding = mkUnfolding IWantToBeINLINEd {- Always inline constructors -} con_rhs
  88
  89         (tyvars, theta, con_tyvars, con_theta, arg_tys, tycon) = dataConSig con_id
  90
  91         dict_tys     = [mkDictTy clas tys | (clas,tys) <- theta]
  92         con_dict_tys = [mkDictTy clas tys | (clas,tys) <- con_theta]
  93         n_dicts      = length dict_tys
  94         result_ty    = mkTyConApp tycon (mkTyVarTys tyvars)
  95
  96         locals        = mkTemplateLocals (dict_tys ++ con_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 | isUnpointedType (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 && isDataTyCon tycon )
 143     sel_id `addIdUnfolding` unfolding
 144            `addIdArity` exactArity 1
 145         -- ToDo: consider adding further IdInfo
 146   where
 147         unfolding = mkUnfolding NoPragmaInfo {- 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" (splitFunTy_maybe tau)
 152                                         -- tau is of form (T a b c -> field-type)
 153         (tycon, _, data_cons) = splitAlgTyConApp data_ty
 154         tyvar_tys             = mkTyVarTys tyvars
 155
 156         [data_id] = mkTemplateLocals [data_ty]
 157         alts      = map mk_maybe_alt data_cons
 158         sel_rhs   = mkTyLam tyvars $
 159                     mkValLam [data_id] $
 160                     Case (Var data_id)
 161                          -- if any of the constructors don't have the label, ...
 162                          (if any (not . isJust) alts then
 163                            AlgAlts (catMaybes alts)
 164                                    (BindDefault data_id error_expr)
 165                           else
 166                            AlgAlts (catMaybes alts) NoDefault)
 167
 168         mk_maybe_alt data_con
 169           = case maybe_the_arg_id of
 170                 Nothing         -> Nothing
 171                 Just the_arg_id -> Just (data_con, arg_ids, Var the_arg_id)
 172           where
 173             arg_ids          = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
 174                                     -- The first one will shadow data_id, but who cares
 175             field_lbls       = dataConFieldLabels data_con
 176             maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_lbl
 177
 178         error_expr = mkApp (Var pAT_ERROR_ID) [rhs_ty] [LitArg msg_lit]
 179         full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id])
 180         msg_lit    = NoRepStr (_PK_ full_msg)
 181 \end{code}
 182
 183
 184 %************************************************************************
 185 %*                                                                      *
 186 \subsection{Dictionary selectors}
 187 %*                                                                      *
 188 %************************************************************************
 189
 190 Selecting a field for a dictionary.  If there is just one field, then
 191 there's nothing to do.
 192
 193 \begin{code}
 194 addStandardIdInfo sel_id
 195   | maybeToBool maybe_dict_sel_id
 196   = sel_id `addIdUnfolding` unfolding
 197   where
 198     maybe_dict_sel_id = isDictSelId_maybe sel_id
 199     Just clas       = maybe_dict_sel_id
 200
 201     unfolding = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs
 202         -- The always-inline thing means we don't need any other IdInfo
 203
 204     (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
 205
 206     tycon      = classTyCon clas
 207     [data_con] = tyConDataCons tycon
 208     tyvar_tys  = mkTyVarTys tyvars
 209     arg_tys    = dataConArgTys data_con tyvar_tys
 210     the_arg_id = assoc "StdIdInfo:mk_sel" ((sc_sel_ids ++ op_sel_ids) `zip` arg_ids) sel_id
 211
 212     (dict_id:arg_ids) = mkTemplateLocals (mkDictTy clas tyvar_tys : arg_tys)
 213
 214     rhs | isNewTyCon tycon = mkLam tyvars [dict_id] $
 215                              Coerce (CoerceOut data_con) (head arg_tys) (Var dict_id)
 216         | otherwise        = mkLam tyvars [dict_id] $
 217                              Case (Var dict_id) $
 218                              AlgAlts [(data_con, arg_ids, Var the_arg_id)] NoDefault
 219 \end{code}
 220
 221
 222 %************************************************************************
 223 %*                                                                      *
 224 \subsection{Primitive operations
 225 %*                                                                      *
 226 %************************************************************************
 227
 228
 229 \begin{code}
 230 addStandardIdInfo prim_id
 231   | maybeToBool maybe_prim_id
 232   = prim_id `addIdUnfolding` unfolding
 233   where
 234     maybe_prim_id = isPrimitiveId_maybe prim_id
 235     Just prim_op  = maybe_prim_id
 236
 237     unfolding = mkUnfolding IWantToBeINLINEd {- Always inline PrimOps -} rhs
 238
 239     (tyvars, tau) = splitForAllTys (idType prim_id)
 240     (arg_tys, _)  = splitFunTys tau
 241
 242     args = mkTemplateLocals arg_tys
 243     rhs =  mkLam tyvars args $
 244            Prim prim_op
 245                 ([TyArg (mkTyVarTy tv) | tv <- tyvars] ++
 246                  [VarArg v | v <- args])
 247 \end{code}
 248
 249
 250 %************************************************************************
 251 %*                                                                      *
 252 \subsection{Catch-all}
 253 %*                                                                      *
 254 %************************************************************************
 255
 256 \begin{code}
 257 addStandardIdInfo id
 258   = pprTrace "addStandardIdInfo missing:" (ppr id) id
 259 \end{code}
 260