This patch changes things so that such classes rely on the coercion
mechanism for inlining (since the constructor is really just a cast)
rather than on the dfun mechanism, therby removing some needless
runtime indirections.
wkr_arity = dataConRepArity data_con
wkr_info = noCafIdInfo
wkr_arity = dataConRepArity data_con
wkr_info = noCafIdInfo
- `setArityInfo` wkr_arity
+ `setArityInfo` wkr_arity
`setStrictnessInfo` Just wkr_sig
`setStrictnessInfo` Just wkr_sig
- `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
+ `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
-- even if arity = 0
wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
-- even if arity = 0
wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
nt_work_id = mkGlobalId (DataConWrapId data_con) wkr_name wrap_ty nt_work_info
nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
`setArityInfo` 1 -- Arity 1
nt_work_id = mkGlobalId (DataConWrapId data_con) wkr_name wrap_ty nt_work_info
nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
`setArityInfo` 1 -- Arity 1
+ `setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` newtype_unf
id_arg1 = mkTemplateLocal 1 (head orig_arg_tys)
newtype_unf = ASSERT2( isVanillaDataCon data_con &&
`setUnfoldingInfo` newtype_unf
id_arg1 = mkTemplateLocal 1 (head orig_arg_tys)
newtype_unf = ASSERT2( isVanillaDataCon data_con &&
unsafeCoerceId
= pcMiscPrelId unsafeCoerceName ty info
where
unsafeCoerceId
= pcMiscPrelId unsafeCoerceName ty info
where
- info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+ info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
+ `setUnfoldingInfo` mkCompulsoryUnfolding rhs
ty = mkForAllTys [argAlphaTyVar,openBetaTyVar]
ty = mkForAllTys [argAlphaTyVar,openBetaTyVar]
-- a way to write this literal in Haskell.
nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info
where
-- a way to write this literal in Haskell.
nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info
where
- info = noCafIdInfo `setUnfoldingInfo`
- mkCompulsoryUnfolding (Lit nullAddrLit)
+ info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
+ `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit)
------------------------------------------------
seqId :: Id -- See Note [seqId magic]
seqId = pcMiscPrelId seqName ty info
where
------------------------------------------------
seqId :: Id -- See Note [seqId magic]
seqId = pcMiscPrelId seqName ty info
where
- info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
- `setSpecInfo` mkSpecInfo [seq_cast_rule]
+ info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
+ `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+ `setSpecInfo` mkSpecInfo [seq_cast_rule]
ty = mkForAllTys [alphaTyVar,argBetaTyVar]
ty = mkForAllTys [alphaTyVar,argBetaTyVar]
op_items ibinds
-- Create the result bindings
op_items ibinds
-- Create the result bindings
- ; let dict_constr = classDataCon clas
- dict_bind = mkVarBind self_dict dict_rhs
- dict_rhs = foldl mk_app inst_constr $
- map HsVar sc_dicts ++ map (wrapId arg_wrapper) meth_ids
- inst_constr = L loc $ wrapId (mkWpTyApps inst_tys)
- (dataConWrapId dict_constr)
+ ; self_dict <- newEvVar (ClassP clas inst_tys)
+ ; let class_tc = classTyCon clas
+ [dict_constr] = tyConDataCons class_tc
+ dict_bind = mkVarBind self_dict dict_rhs
+ dict_rhs = foldl mk_app inst_constr $
+ map HsVar sc_dicts ++ map (wrapId arg_wrapper) meth_ids
+ inst_constr = L loc $ wrapId (mkWpTyApps inst_tys)
+ (dataConWrapId dict_constr)
-- We don't produce a binding for the dict_constr; instead we
-- rely on the simplifier to unfold this saturated application
-- We do this rather than generate an HsCon directly, because
-- We don't produce a binding for the dict_constr; instead we
-- rely on the simplifier to unfold this saturated application
-- We do this rather than generate an HsCon directly, because
-- member) are dealt with by the common MkId.mkDataConWrapId
-- code rather than needing to be repeated here.
-- member) are dealt with by the common MkId.mkDataConWrapId
-- code rather than needing to be repeated here.
- mk_app :: LHsExpr Id -> Id -> LHsExpr Id
- mk_app fun arg_id = L loc (HsApp fun (L loc (wrapId arg_wrapper arg_id)))
- arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars')
+ mk_app :: LHsExpr Id -> HsExpr Id -> LHsExpr Id
+ mk_app fun arg = L loc (HsApp fun (L loc arg))
+
+ arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars)
-- Do not inline the dfun; instead give it a magic DFunFunfolding
-- See Note [ClassOp/DFun selection]
-- See also note [Single-method classes]
-- Do not inline the dfun; instead give it a magic DFunFunfolding
-- See Note [ClassOp/DFun selection]
-- See also note [Single-method classes]
- dfun_id_w_fun = dfun_id
- `setIdUnfolding` mkDFunUnfolding inst_ty (map Var dict_and_meth_ids)
- -- Not right for equality superclasses
- `setInlinePragma` dfunInlinePragma
+ dfun_id_w_fun
+ | isNewTyCon class_tc
+ = dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
+ | otherwise
+ = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_ty (sc_args ++ meth_args)
+ `setInlinePragma` dfunInlinePragma
+ meth_args = map (DFunPolyArg . Var) meth_ids
main_bind = AbsBinds { abs_tvs = inst_tyvars
, abs_ev_vars = dfun_ev_vars
main_bind = AbsBinds { abs_tvs = inst_tyvars
, abs_ev_vars = dfun_ev_vars
Although this looks wrong (assume D [a] to prove D [a]), it is only a
more extreme case of what happens with recursive dictionaries.
Although this looks wrong (assume D [a] to prove D [a]), it is only a
more extreme case of what happens with recursive dictionaries.
- ; uniq <- newUnique
- ; let sc_op_ty = mkForAllTys tyvars $ mkPiTypes dicts (varType sc_dict)
- sc_op_name = mkDerivedInternalName mkClassOpAuxOcc uniq
- (getName sc_sel)
- sc_op_id = mkLocalId sc_op_name sc_op_ty
- sc_op_bind = VarBind { var_id = sc_op_id, var_inline = False
- , var_rhs = L noSrcSpan $ wrapId sc_wrapper sc_dict }
- sc_wrapper = mkWpTyLams tyvars
- <.> mkWpLams dicts
- <.> mkWpLet ev_binds
+To implement the dfun we must generate code for the superclass C [a],
+which we can get by superclass selection from the supplied argument!
+So we’d generate:
+ dfun :: forall a. D [a] -> D [a]
+ dfun = \d::D [a] -> MkD (scsel d) ..
However this means that if we later encounter a situation where
we have a [Wanted] dw::D [a] we could solve it thus:
However this means that if we later encounter a situation where
we have a [Wanted] dw::D [a] we could solve it thus: