\begin{code}
module MkId (
- mkDictFunId, mkDefaultMethodId,
- mkDictSelId,
+ mkDictFunId, mkDictFunTy, mkDefaultMethodId, mkDictSelId,
mkDataConIds,
mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
wkr_arity = dataConRepArity data_con
wkr_info = noCafIdInfo
- `setArityInfo` wkr_arity
+ `setArityInfo` wkr_arity
`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)
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 &&
`setArityInfo` wrap_arity
-- It's important to specify the arity, so that partial
-- applications are treated as values
+ `setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` wrap_unf
`setStrictnessInfo` Just wrap_sig
-- ...(let w = C x in ...(w p q)...)...
-- we want to see that w is strict in its two arguments
- wrap_unf = mkInlineRule wrap_rhs (Just (length dict_args + length id_args))
+ wrap_unf = mkInlineUnfolding (Just (length dict_args + length id_args)) wrap_rhs
wrap_rhs = mkLams wrap_tvs $
mkLams eq_args $
mkLams dict_args $ mkLams id_args $
base_info = noCafIdInfo
`setArityInfo` 1
- `setStrictnessInfo` Just strict_sig
+ `setStrictnessInfo` Just strict_sig
`setUnfoldingInfo` (if no_unf then noUnfolding
- else mkImplicitUnfolding rhs)
+ else mkImplicitUnfolding rhs)
-- In module where class op is defined, we must add
-- the unfolding, even though it'll never be inlined
-- becuase we use that to generate a top-level binding
-- for the ClassOp
- info = base_info `setSpecInfo` mkSpecInfo [rule]
- `setInlinePragInfo` neverInlinePragma
- -- Add a magic BuiltinRule, and never inline it
- -- so that the rule is always available to fire.
- -- See Note [ClassOp/DFun selection] in TcInstDcls
+ info | new_tycon = base_info `setInlinePragInfo` alwaysInlinePragma
+ -- See Note [Single-method classes] for why alwaysInlinePragma
+ | otherwise = base_info `setSpecInfo` mkSpecInfo [rule]
+ `setInlinePragInfo` neverInlinePragma
+ -- Add a magic BuiltinRule, and never inline it
+ -- so that the rule is always available to fire.
+ -- See Note [ClassOp/DFun selection] in TcInstDcls
n_ty_args = length tyvars
dictSelRule :: Int -> Arity -> Arity
-> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
--- Oh, very clever
--- sel_i t1..tk (df s1..sn d1..dm) = op_i_helper s1..sn d1..dm
+-- Tries to persuade the argument to look like a constructor
+-- application, using exprIsConApp_maybe, and then selects
+-- from it
-- sel_i t1..tk (D t1..tk op1 ... opm) = opi
--
--- NB: the data constructor has the same number of type and
--- coercion args as the selector
---
--- This only works for *value* superclasses
--- There are no selector functions for equality superclasses
dictSelRule val_index n_ty_args n_eq_args id_unf args
| (dict_arg : _) <- drop n_ty_args args
, Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
-> Class
-> [Type]
-> Id
+-- Implements the DFun Superclass Invariant (see TcInstDcls)
-mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys
- = mkExportedLocalVar (DFunId is_nt) dfun_name dfun_ty vanillaIdInfo
+mkDictFunId dfun_name tvs theta clas tys
+ = mkExportedLocalVar (DFunId n_silent is_nt)
+ dfun_name
+ dfun_ty
+ vanillaIdInfo
where
is_nt = isNewTyCon (classTyCon clas)
- dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
+ (n_silent, dfun_ty) = mkDictFunTy tvs theta clas tys
+
+mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> (Int, Type)
+mkDictFunTy tvs theta clas tys
+ = (length silent_theta, dfun_ty)
+ where
+ dfun_ty = mkSigmaTy tvs (silent_theta ++ theta) (mkDictTy clas tys)
+ silent_theta = filterOut discard $
+ substTheta (zipTopTvSubst (classTyVars clas) tys)
+ (classSCTheta clas)
+ -- See Note [Silent Superclass Arguments]
+ discard pred = isEmptyVarSet (tyVarsOfPred pred)
+ || any (`tcEqPred` pred) theta
+ -- See the DFun Superclass Invariant in TcInstDcls
\end{code}
unsafeCoerceId
= pcMiscPrelId unsafeCoerceName ty info
where
- info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+ info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
+ `setUnfoldingInfo` mkCompulsoryUnfolding rhs
ty = mkForAllTys [argAlphaTyVar,openBetaTyVar]
-- 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
- 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]
projects / ghc-hetmet.git / blobdiff