Commit 0f978b5b authored by Simon Peyton Jones's avatar Simon Peyton Jones

Refactor buildClass and mkDictSelId a bit, to avoid the no_unf argument

No change in functionality, just a cleaner story, with the RHS for
dictionary selectors being treated less specially than before.
parent 76820ca3
......@@ -20,7 +20,7 @@ have a standard form, namely:
-- for details
module MkId (
mkDictFunId, mkDictFunTy, mkDictSelId,
mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs,
mkPrimOpId, mkFCallId,
......@@ -272,39 +272,36 @@ at the outside. When dealing with classes it's very convenient to
recover the original type signature from the class op selector.
\begin{code}
mkDictSelId :: DynFlags
-> Bool -- True <=> don't include the unfolding
-- Little point on imports without -O, because the
-- dictionary itself won't be visible
-> Name -- Name of one of the *value* selectors
mkDictSelId :: Name -- Name of one of the *value* selectors
-- (dictionary superclass or method)
-> Class -> Id
mkDictSelId dflags no_unf name clas
mkDictSelId name clas
= mkGlobalId (ClassOpId clas) name sel_ty info
where
sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id))
-- We can't just say (exprType rhs), because that would give a type
-- C a -> C a
-- for a single-op class (after all, the selector is the identity)
-- But it's type must expose the representation of the dictionary
-- to get (say) C a -> (a -> a)
tycon = classTyCon clas
sel_names = map idName (classAllSelIds clas)
new_tycon = isNewTyCon tycon
[data_con] = tyConDataCons tycon
tyvars = dataConUnivTyVars data_con
arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses
val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name
sel_ty = mkForAllTys tyvars (mkFunTy (mkClassPred clas (mkTyVarTys tyvars))
(getNth arg_tys val_index))
base_info = noCafIdInfo
`setArityInfo` 1
`setStrictnessInfo` strict_sig
`setUnfoldingInfo` (if no_unf then noUnfolding
else mkImplicitUnfolding dflags rhs)
-- In module where class op is defined, we must add
-- the unfolding, even though it'll never be inlined
-- because we use that to generate a top-level binding
-- for the ClassOp
info | new_tycon = base_info `setInlinePragInfo` alwaysInlinePragma
info | new_tycon
= base_info `setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` mkInlineUnfolding (Just 1) (mkDictSelRhs clas val_index)
-- See Note [Single-method classes] in TcInstDcls
-- for why alwaysInlinePragma
| otherwise = base_info `setSpecInfo` mkSpecInfo [rule]
`setInlinePragInfo` neverInlinePragma
-- Add a magic BuiltinRule, and never inline it
| otherwise
= base_info `setSpecInfo` mkSpecInfo [rule]
-- Add a magic BuiltinRule, but no unfolding
-- so that the rule is always available to fire.
-- See Note [ClassOp/DFun selection] in TcInstDcls
......@@ -326,25 +323,26 @@ mkDictSelId dflags no_unf name clas
strict_sig = mkClosedStrictSig [arg_dmd] topRes
arg_dmd | new_tycon = evalDmd
| otherwise = mkManyUsedDmd $
mkProdDmd [ if the_arg_id == id then evalDmd else absDmd
| id <- arg_ids ]
mkProdDmd [ if name == sel_name then evalDmd else absDmd
| sel_name <- sel_names ]
mkDictSelRhs :: Class
-> Int -- 0-indexed selector among (superclasses ++ methods)
-> CoreExpr
mkDictSelRhs clas val_index
= mkLams tyvars (Lam dict_id rhs_body)
where
tycon = classTyCon clas
new_tycon = isNewTyCon tycon
[data_con] = tyConDataCons tycon
tyvars = dataConUnivTyVars data_con
arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses
-- 'index' is a 0-index into the *value* arguments of the dictionary
val_index = assoc "MkId.mkDictSelId" sel_index_prs name
sel_index_prs = map idName (classAllSelIds clas) `zip` [0..]
the_arg_id = getNth arg_ids val_index
pred = mkClassPred clas (mkTyVarTys tyvars)
dict_id = mkTemplateLocal 1 pred
arg_ids = mkTemplateLocalsNum 2 arg_tys
rhs = mkLams tyvars (Lam dict_id rhs_body)
rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
| otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
[(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)]
......
......@@ -254,10 +254,7 @@ type TcMethInfo = (Name, DefMethSpec, Type)
-- A temporary intermediate, to communicate between
-- tcClassSigs and buildClass.
buildClass :: Bool -- True <=> do not include unfoldings
-- on dict selectors
-- Used when importing a class without -O
-> Name -> [TyVar] -> [Role] -> ThetaType
buildClass :: Name -> [TyVar] -> [Role] -> ThetaType
-> [FunDep TyVar] -- Functional dependencies
-> [ClassATItem] -- Associated types
-> [TcMethInfo] -- Method info
......@@ -265,10 +262,9 @@ buildClass :: Bool -- True <=> do not include unfoldings
-> RecFlag -- Info for type constructor
-> TcRnIf m n Class
buildClass no_unf tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
= fixM $ \ rec_clas -> -- Only name generation inside loop
do { traceIf (text "buildClass")
; dflags <- getDynFlags
; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
-- The class name is the 'parent' for this datacon, not its tycon,
......@@ -282,7 +278,7 @@ buildClass no_unf tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc
-- Make selectors for the superclasses
; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc)
[1..length sc_theta]
; let sc_sel_ids = [ mkDictSelId dflags no_unf sc_name rec_clas
; let sc_sel_ids = [ mkDictSelId sc_name rec_clas
| sc_name <- sc_sel_names]
-- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
-- can construct names for the selectors. Thus
......@@ -348,14 +344,13 @@ buildClass no_unf tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc
where
mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
mk_op_item rec_clas (op_name, dm_spec, _)
= do { dflags <- getDynFlags
; dm_info <- case dm_spec of
= do { dm_info <- case dm_spec of
NoDM -> return NoDefMeth
GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc
; return (GenDefMeth dm_name) }
VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
; return (DefMeth dm_name) }
; return (mkDictSelId dflags no_unf op_name rec_clas, dm_info) }
; return (mkDictSelId op_name rec_clas, dm_info) }
\end{code}
Note [Class newtypes and equality predicates]
......
......@@ -527,7 +527,7 @@ tc_iface_decl _parent ignore_prags
; cls <- fixM $ \ cls -> do
{ ats <- mapM (tc_at cls) rdr_ats
; traceIf (text "tc-iface-class4" <+> ppr tc_occ)
; buildClass ignore_prags tc_name tyvars roles ctxt fds ats sigs mindef tc_isrec }
; buildClass tc_name tyvars roles ctxt fds ats sigs mindef tc_isrec }
; return (ATyCon (classTyCon cls)) }
where
tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
......
......@@ -26,6 +26,7 @@ import VarEnv
import VarSet
import Var
import Id
import MkId ( mkDictSelRhs )
import IdInfo
import InstEnv
import FamInstEnv
......@@ -566,7 +567,9 @@ getTyConImplicitBinds :: TyCon -> [CoreBind]
getTyConImplicitBinds tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))
getClassImplicitBinds :: Class -> [CoreBind]
getClassImplicitBinds cls = map get_defn (classAllSelIds cls)
getClassImplicitBinds cls
= [ NonRec op (mkDictSelRhs cls val_index)
| (op, val_index) <- classAllSelIds cls `zip` [0..] ]
get_defn :: Id -> CoreBind
get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id))
......
......@@ -638,7 +638,7 @@ tcTyClDecl1 _parent rec_info
; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths
; at_stuff <- tcClassATs class_name (AssocFamilyTyCon clas) ats at_defs
; mindef <- tcClassMinimalDef class_name sigs sig_stuff
; clas <- buildClass False {- Must include unfoldings for selectors -}
; clas <- buildClass
class_name tvs' roles ctxt' fds' at_stuff
sig_stuff mindef tc_isrec
; traceTc "tcClassDecl" (ppr fundeps $$ ppr tvs' $$ ppr fds')
......
......@@ -59,7 +59,6 @@ vectTyConDecl tycon name'
-- NB: 'buildClass' attaches new quantifiers and dictionaries to the method types
; cls' <- liftDs $
buildClass
False -- include unfoldings on dictionary selectors
name' -- new name: "V:Class"
(tyConTyVars tycon) -- keep original type vars
(map (const Nominal) (tyConRoles tycon)) -- all role are N for safety
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment