* primitive operations
\begin{code}
-#include "HsVersions.h"
-
module StdIdInfo (
addStandardIdInfo
) where
-IMP_Ubiq()
+#include "HsVersions.h"
import Type
-import CmdLineOpts ( opt_PprUserLength )
+import TyVar ( alphaTyVar )
import CoreSyn
import Literal
import CoreUnfold ( mkUnfolding, PragmaInfo(..) )
import TysWiredIn ( tupleCon )
-import Id ( GenId, mkTemplateLocals, idType,
+import Id ( mkTemplateLocals, idType,
dataConStrictMarks, dataConFieldLabels, dataConArgTys,
recordSelectorFieldLabel, dataConSig,
StrictnessMark(..),
- isAlgCon, isMethodSelId_maybe, isSuperDictSelId_maybe,
+ isAlgCon, isDictSelId_maybe,
isRecordSelector, isPrimitiveId_maybe,
addIdUnfolding, addIdArity,
- SYN_IE(Id)
+ Id
)
import IdInfo ( ArityInfo, exactArity )
-import Class ( GenClass, GenClassOp, classSig, classOpLocalType )
-import TyCon ( isNewTyCon, isDataTyCon, isAlgTyCon )
+import Class ( classBigSig, classTyCon )
+import TyCon ( isNewTyCon, tyConDataCons, isDataTyCon )
import FieldLabel ( FieldLabel )
import PrelVals ( pAT_ERROR_ID )
import Maybes
-import Outputable ( PprStyle(..), Outputable(..) )
-import Pretty
-import Util ( assertPanic, pprTrace,
- assoc
- )
+import Outputable
+import Util ( assoc )
\end{code}
(tyvars, theta, con_tyvars, con_theta, arg_tys, tycon) = dataConSig con_id
- dict_tys = [mkDictTy clas ty | (clas,ty) <- theta]
- con_dict_tys = [mkDictTy clas ty | (clas,ty) <- con_theta]
+ dict_tys = [mkDictTy clas tys | (clas,tys) <- theta]
+ con_dict_tys = [mkDictTy clas tys | (clas,tys) <- con_theta]
n_dicts = length dict_tys
- result_ty = applyTyCon tycon (mkTyVarTys tyvars)
+ result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
locals = mkTemplateLocals (dict_tys ++ con_dict_tys ++ arg_tys)
data_args = drop n_dicts locals
mkValLam locals $
foldr mk_case con_app strict_args
- mk_case arg body | isUnboxedType (idType arg)
+ mk_case arg body | isUnpointedType (idType arg)
= body -- "!" on unboxed arg does nothing
| otherwise
= Case (Var arg) (AlgAlts [] (BindDefault arg body))
(tyvars, theta, tau) = splitSigmaTy (idType sel_id)
field_lbl = recordSelectorFieldLabel sel_id
- (data_ty,rhs_ty) = expectJust "StdIdInfoRec" (getFunTy_maybe tau)
+ (data_ty,rhs_ty) = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
-- tau is of form (T a b c -> field-type)
- (tycon, _, data_cons) = getAppDataTyCon data_ty
+ (tycon, _, data_cons) = splitAlgTyConApp data_ty
tyvar_tys = mkTyVarTys tyvars
[data_id] = mkTemplateLocals [data_ty]
field_lbls = dataConFieldLabels data_con
maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_lbl
- error_expr = mkApp (Var pAT_ERROR_ID) [] [rhs_ty] [LitArg msg_lit]
- full_msg = show (sep [text "No match in record selector", ppr (PprForUser opt_PprUserLength) sel_id])
+ error_expr = mkApp (Var pAT_ERROR_ID) [rhs_ty] [LitArg msg_lit]
+ full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
msg_lit = NoRepStr (_PK_ full_msg)
\end{code}
%************************************************************************
%* *
-\subsection{Super selectors}
+\subsection{Dictionary selectors}
%* *
%************************************************************************
+Selecting a field for a dictionary. If there is just one field, then
+there's nothing to do.
+
\begin{code}
addStandardIdInfo sel_id
- | maybeToBool maybe_sc_sel_id
+ | maybeToBool maybe_dict_sel_id
= sel_id `addIdUnfolding` unfolding
- -- The always-inline thing means we don't need any other IdInfo
where
- maybe_sc_sel_id = isSuperDictSelId_maybe sel_id
- Just (cls, the_sc) = maybe_sc_sel_id
+ maybe_dict_sel_id = isDictSelId_maybe sel_id
+ Just clas = maybe_dict_sel_id
unfolding = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs
- rhs = mk_dict_selector [tyvar] dict_id arg_ids the_arg_id
+ -- The always-inline thing means we don't need any other IdInfo
- (tyvar, scs, ops) = classSig cls
- tyvar_ty = mkTyVarTy tyvar
- [dict_id] = mkTemplateLocals [mkDictTy cls tyvar_ty]
- arg_ids = mkTemplateLocals ([mkDictTy sc tyvar_ty | sc <- scs] ++
- map classOpLocalType ops)
- the_arg_id = assoc "StdIdInfoSC" (scs `zip` arg_ids) the_sc
+ (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
-addStandardIdInfo sel_id
- | maybeToBool maybe_meth_sel_id
- = sel_id `addIdUnfolding` unfolding
- -- The always-inline thing means we don't need any other IdInfo
- where
- maybe_meth_sel_id = isMethodSelId_maybe sel_id
- Just (cls, the_op) = maybe_meth_sel_id
+ tycon = classTyCon clas
+ [data_con] = tyConDataCons tycon
+ tyvar_tys = mkTyVarTys tyvars
+ arg_tys = dataConArgTys data_con tyvar_tys
+ the_arg_id = assoc "StdIdInfo:mk_sel" ((sc_sel_ids ++ op_sel_ids) `zip` arg_ids) sel_id
- unfolding = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs
- rhs = mk_dict_selector [tyvar] dict_id arg_ids the_arg_id
-
- (tyvar, scs, ops) = classSig cls
- n_scs = length scs
- tyvar_ty = mkTyVarTy tyvar
- [dict_id] = mkTemplateLocals [mkDictTy cls tyvar_ty]
- arg_ids = mkTemplateLocals ([mkDictTy sc tyvar_ty | sc <- scs] ++
- map classOpLocalType ops)
-
- the_arg_id = assoc "StdIdInfoMeth" (ops `zip` (drop n_scs arg_ids)) the_op
+ (dict_id:arg_ids) = mkTemplateLocals (mkDictTy clas tyvar_tys : arg_tys)
+
+ rhs | isNewTyCon tycon = mkLam tyvars [dict_id] $
+ Coerce (CoerceOut data_con) (head arg_tys) (Var dict_id)
+ | otherwise = mkLam tyvars [dict_id] $
+ Case (Var dict_id) $
+ AlgAlts [(data_con, arg_ids, Var the_arg_id)] NoDefault
\end{code}
unfolding = mkUnfolding IWantToBeINLINEd {- Always inline PrimOps -} rhs
- (tyvars, tau) = splitForAllTy (idType prim_id)
- (arg_tys, _) = splitFunTy tau
+ (tyvars, tau) = splitForAllTys (idType prim_id)
+ (arg_tys, _) = splitFunTys tau
args = mkTemplateLocals arg_tys
rhs = mkLam tyvars args $
\begin{code}
addStandardIdInfo id
- = pprTrace "addStandardIdInfo missing:" (ppr PprDebug id) id
+ = pprTrace "addStandardIdInfo missing:" (ppr id) id
\end{code}
-
-%************************************************************************
-%* *
-\subsection{Dictionary selector help function
-%* *
-%************************************************************************
-
-Selecting a field for a dictionary. If there is just one field, then
-there's nothing to do.
-
-\begin{code}
-mk_dict_selector tyvars dict_id [arg_id] the_arg_id
- = mkLam tyvars [dict_id] (Var dict_id)
-
-mk_dict_selector tyvars dict_id arg_ids the_arg_id
- = mkLam tyvars [dict_id] $
- Case (Var dict_id) (AlgAlts [(tup_con, arg_ids, Var the_arg_id)] NoDefault)
- where
- tup_con = tupleCon (length arg_ids)
-\end{code}
projects / ghc-hetmet.git / blobdiff