See Note [DFun unfoldings] in CoreSyn. The issue here is that
you can't tell how many dictionary arguments a DFun needs just
from looking at the Arity of the DFun Id: if the dictionary is
represented by a newtype the arity might include the dictionary
and value arguments of the (single) method.
So we need to record the number of arguments need by the DFun
in the DFunUnfolding itself. Details in
Note [DFun unfoldings] in CoreSyn
12 files changed:
idUnfoldingVars id
= case realIdUnfolding id of
CoreUnfolding { uf_tmpl = rhs, uf_src = src }
idUnfoldingVars id
= case realIdUnfolding id of
CoreUnfolding { uf_tmpl = rhs, uf_src = src }
- | isInlineRuleSource src
- -> exprFreeVars rhs
- DFunUnfolding _ args -> exprsFreeVars args
- _ -> emptyVarSet
+ | isInlineRuleSource src
+ -> exprFreeVars rhs
+ DFunUnfolding _ _ args -> exprsFreeVars args
+ _ -> emptyVarSet
| isEmptySubst subst = unf
| otherwise = substUnfolding subst unf
| isEmptySubst subst = unf
| otherwise = substUnfolding subst unf
-substUnfolding subst (DFunUnfolding con args)
- = DFunUnfolding con (map (substExpr (text "dfun-unf") subst) args)
+substUnfolding subst (DFunUnfolding ar con args)
+ = DFunUnfolding ar con (map (substExpr (text "dfun-unf") subst) args)
substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
-- Retain an InlineRule!
substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
-- Retain an InlineRule!
--
-- Here, @f@ gets an @OtherCon []@ unfolding.
--
-- Here, @f@ gets an @OtherCon []@ unfolding.
- | DFunUnfolding DataCon [CoreExpr]
- -- The Unfolding of a DFunId
+ | DFunUnfolding -- The Unfolding of a DFunId
+ -- See Note [DFun unfoldings]
-- df = /\a1..am. \d1..dn. MkD (op1 a1..am d1..dn)
-- (op2 a1..am d1..dn)
-- df = /\a1..am. \d1..dn. MkD (op1 a1..am d1..dn)
-- (op2 a1..am d1..dn)
- -- where Arity = n, the number of dict args to the dfun
- -- The [CoreExpr] are the superclasses and methods [op1,op2],
+
+ Arity -- Arity = m+n, the *total* number of args
+ -- (unusually, both type and value) to the dfun
+
+ DataCon -- The dictionary data constructor (possibly a newtype datacon)
+
+ [CoreExpr] -- The [CoreExpr] are the superclasses and methods [op1,op2],
-- in positional order.
-- They are usually variables, but can be trivial expressions
-- instead (e.g. a type application).
-- in positional order.
-- They are usually variables, but can be trivial expressions
-- instead (e.g. a type application).
-- (where there are the right number of arguments.)
| UnfNever -- The RHS is big, so don't inline it
-- (where there are the right number of arguments.)
| UnfNever -- The RHS is big, so don't inline it
+\end{code}
+
+
+Note [DFun unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~
+The Arity in a DFunUnfolding is total number of args (type and value)
+that the DFun needs to produce a dictionary. That's not necessarily
+related to the ordinary arity of the dfun Id, esp if the class has
+one method, so the dictionary is represented by a newtype. Example
+
+ class C a where { op :: a -> Int }
+ instance C a -> C [a] where op xs = op (head xs)
+The instance translates to
+
+ $dfCList :: forall a. C a => C [a] -- Arity 2!
+ $dfCList = /\a.\d. $copList {a} d |> co
+
+ $copList :: forall a. C a => [a] -> Int -- Arity 2!
+ $copList = /\a.\d.\xs. op {a} d (head xs)
+
+Now we might encounter (op (dfCList {ty} d) a1 a2)
+and we want the (op (dfList {ty} d)) rule to fire, because $dfCList
+has all its arguments, even though its (value) arity is 2. That's
+why we cache the number of expected
+
+
+\begin{code}
-- Constants for the UnfWhen constructor
needSaturated, unSaturatedOk :: Bool
needSaturated = False
-- Constants for the UnfWhen constructor
needSaturated, unSaturatedOk :: Bool
needSaturated = False
import DynFlags
import CoreSyn
import PprCore () -- Instances
import DynFlags
import CoreSyn
import PprCore () -- Instances
+import TcType ( tcSplitSigmaTy, tcSplitDFunHead )
import OccurAnal
import CoreSubst hiding( substTy )
import CoreFVs ( exprFreeVars )
import OccurAnal
import CoreSubst hiding( substTy )
import CoreFVs ( exprFreeVars )
uf_expandable = exprIsExpandable expr,
uf_guidance = guidance }
uf_expandable = exprIsExpandable expr,
uf_guidance = guidance }
-mkDFunUnfolding :: DataCon -> [Id] -> Unfolding
-mkDFunUnfolding con ops = DFunUnfolding con (map Var ops)
+mkDFunUnfolding :: Type -> [CoreExpr] -> Unfolding
+mkDFunUnfolding dfun_ty ops
+ = DFunUnfolding dfun_nargs data_con ops
+ where
+ (tvs, theta, head_ty) = tcSplitSigmaTy dfun_ty
+ -- NB: tcSplitSigmaTy: do not look through a newtype
+ -- when the dictionary type is a newtype
+ (cls, _) = tcSplitDFunHead head_ty
+ dfun_nargs = length tvs + length theta
+ data_con = classDataCon cls
mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
mkWwInlineRule id expr arity
mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
mkWwInlineRule id expr arity
analyse (Var fun) args
| Just con <- isDataConWorkId_maybe fun
analyse (Var fun) args
| Just con <- isDataConWorkId_maybe fun
+ , count isValArg args == idArity fun
, let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars con) args
= Just (con, stripTypeArgs univ_ty_args, rest_args)
-- Look through dictionary functions; see Note [Unfolding DFuns]
, let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars con) args
= Just (con, stripTypeArgs univ_ty_args, rest_args)
-- Look through dictionary functions; see Note [Unfolding DFuns]
- | DFunUnfolding con ops <- unfolding
- , is_saturated
+ | DFunUnfolding dfun_nargs con ops <- unfolding
+ , let sat = length args == dfun_nargs -- See Note [DFun arity check]
+ in if sat then True else
+ pprTrace "Unsaturated dfun" (ppr fun <+> int dfun_nargs $$ ppr args) False
, let (dfun_tvs, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
= Just (con, substTys subst dfun_res_tys,
, let (dfun_tvs, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
= Just (con, substTys subst dfun_res_tys,
= -- pprTrace "expanding" (ppr fun $$ ppr rhs) $
analyse rhs args
where
= -- pprTrace "expanding" (ppr fun $$ ppr rhs) $
analyse rhs args
where
- is_saturated = count isValArg args == idArity fun
unfolding = id_unf fun
analyse _ _ = Nothing
unfolding = id_unf fun
analyse _ _ = Nothing
to the very same args as the dfun. It takes a little more work
to compute the type arguments to the dictionary constructor.
to the very same args as the dfun. It takes a little more work
to compute the type arguments to the dictionary constructor.
+Note [DFun arity check]
+~~~~~~~~~~~~~~~~~~~~~~~
+Here we check that the total number of supplied arguments (inclding
+type args) matches what the dfun is expecting. This may be *less*
+than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn
\ No newline at end of file
ppr InlineRhs = ptext (sLit "<vanilla>")
instance Outputable Unfolding where
ppr InlineRhs = ptext (sLit "<vanilla>")
instance Outputable Unfolding where
- ppr NoUnfolding = ptext (sLit "No unfolding")
- ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs
- ppr (DFunUnfolding con ops) = ptext (sLit "DFun") <+> ppr con
- <+> brackets (pprWithCommas pprParendExpr ops)
+ ppr NoUnfolding = ptext (sLit "No unfolding")
+ ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs
+ ppr (DFunUnfolding ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar)
+ <+> ppr con
+ <+> brackets (pprWithCommas pprParendExpr ops)
ppr (CoreUnfolding { uf_src = src
, uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
, uf_is_conlike=conlike, uf_is_cheap=cheap
ppr (CoreUnfolding { uf_src = src
, uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
, uf_is_conlike=conlike, uf_is_cheap=cheap
; spec_name <- newLocalName poly_name
; wrap_fn <- dsCoercion spec_co
; let ds_spec_expr = wrap_fn (Var poly_id)
; spec_name <- newLocalName poly_name
; wrap_fn <- dsCoercion spec_co
; let ds_spec_expr = wrap_fn (Var poly_id)
+ spec_ty = exprType ds_spec_expr
; case decomposeRuleLhs ds_spec_expr of {
Nothing -> do { warnDs (decomp_msg spec_co)
; return Nothing } ;
; case decomposeRuleLhs ds_spec_expr of {
Nothing -> do { warnDs (decomp_msg spec_co)
; return Nothing } ;
bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
| otherwise -> do
bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
| otherwise -> do
- { (spec_unf, unf_pairs) <- specUnfolding wrap_fn (realIdUnfolding poly_id)
+ { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
- ; let spec_ty = exprType ds_spec_expr
- spec_id = mkLocalId spec_name spec_ty
+ ; let spec_id = mkLocalId spec_name spec_ty
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
2 (pprHsWrapper (ppr poly_id) spec_co)
2 (pprHsWrapper (ppr poly_id) spec_co)
-specUnfolding :: (CoreExpr -> CoreExpr) -> Unfolding -> DsM (Unfolding, [(Id,CoreExpr)])
-specUnfolding wrap_fn (DFunUnfolding con ops)
+specUnfolding :: (CoreExpr -> CoreExpr) -> Type
+ -> Unfolding -> DsM (Unfolding, [(Id,CoreExpr)])
+specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
= do { let spec_rhss = map wrap_fn ops
; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
= do { let spec_rhss = map wrap_fn ops
; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
- ; return (DFunUnfolding con (map Var spec_ids), spec_ids `zip` spec_rhss) }
-specUnfolding _ _
+ ; return (mkDFunUnfolding spec_ty (map Var spec_ids), spec_ids `zip` spec_rhss) }
+specUnfolding _ _ _
= return (noUnfolding, [])
mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
= return (noUnfolding, [])
mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
-- have stuck in NoUnfolding. For supercompilation we want
-- to see that unfolding!
-- have stuck in NoUnfolding. For supercompilation we want
-- to see that unfolding!
-toIfUnfolding lb (DFunUnfolding _con ops)
+toIfUnfolding lb (DFunUnfolding _ar _con ops)
= Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops)))
-- No need to serialise the data constructor;
-- we can recover it from the type of the dfun
= Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops)))
-- No need to serialise the data constructor;
-- we can recover it from the type of the dfun
= do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
; return (case mb_ops1 of
Nothing -> noUnfolding
= do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
; return (case mb_ops1 of
Nothing -> noUnfolding
- Just ops1 -> DFunUnfolding data_con ops1) }
+ Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
where
doc = text "Class ops for dfun" <+> ppr name
where
doc = text "Class ops for dfun" <+> ppr name
- (_, cls, _) = tcSplitDFunTy dfun_ty
- data_con = classDataCon cls
\end{code}
For unfoldings we try to do the job lazily, so that we never type check
\end{code}
For unfoldings we try to do the job lazily, so that we never type check
mb_unfold_ids :: Maybe (IdSet, [Id]) -- Nothing => don't unfold
mb_unfold_ids = case unfoldingInfo idinfo of
CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_guidance = guide }
mb_unfold_ids :: Maybe (IdSet, [Id]) -- Nothing => don't unfold
mb_unfold_ids = case unfoldingInfo idinfo of
CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_guidance = guide }
- | show_unfolding src guide
- -> Just (unf_ext_ids src unf_rhs)
- DFunUnfolding _ ops -> Just (exprsFvsInOrder ops)
- _ -> Nothing
+ | show_unfolding src guide
+ -> Just (unf_ext_ids src unf_rhs)
+ DFunUnfolding _ _ ops -> Just (exprsFvsInOrder ops)
+ _ -> Nothing
where
unf_ext_ids (InlineWrapper v) _ = (unitVarSet v, [v])
unf_ext_ids _ unf_rhs = exprFvsInOrder unf_rhs
where
unf_ext_ids (InlineWrapper v) _ = (unitVarSet v, [v])
unf_ext_ids _ unf_rhs = exprFvsInOrder unf_rhs
------------ Unfolding --------------
tidyUnfolding :: TidyEnv -> CoreExpr -> Maybe StrictSig -> Unfolding -> Unfolding
------------ Unfolding --------------
tidyUnfolding :: TidyEnv -> CoreExpr -> Maybe StrictSig -> Unfolding -> Unfolding
-tidyUnfolding tidy_env _ _ (DFunUnfolding con ids)
- = DFunUnfolding con (map (tidyExpr tidy_env) ids)
+tidyUnfolding tidy_env _ _ (DFunUnfolding ar con ids)
+ = DFunUnfolding ar con (map (tidyExpr tidy_env) ids)
tidyUnfolding tidy_env tidy_rhs strict_sig
unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
| isInlineRuleSource src
tidyUnfolding tidy_env tidy_rhs strict_sig
unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
| isInlineRuleSource src
-> OccInfo -> OutExpr
-> Unfolding -> SimplM Unfolding
-- Note [Setting the new unfolding]
-> OccInfo -> OutExpr
-> Unfolding -> SimplM Unfolding
-- Note [Setting the new unfolding]
-simplUnfolding env _ _ _ _ (DFunUnfolding con ops)
- = return (DFunUnfolding con ops')
+simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops)
+ = return (DFunUnfolding ar con ops')
where
ops' = map (substExpr (text "simplUnfolding") env) ops
where
ops' = map (substExpr (text "simplUnfolding") env) ops
import Class
import Var
import CoreUnfold ( mkDFunUnfolding )
import Class
import Var
import CoreUnfold ( mkDFunUnfolding )
+import CoreSyn ( Expr(Var) )
import Id
import MkId
import Name
import Id
import MkId
import Name
-- Ordinary instances
tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
-- Ordinary instances
tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
- = do { let rigid_info = InstSkol
- inst_ty = idType dfun_id
- loc = getSrcSpan dfun_id
+ = do { let rigid_info = InstSkol
+ inst_ty = idType dfun_id
+ loc = getSrcSpan dfun_id
-- Instantiate the instance decl with skolem constants
; (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty
-- Instantiate the instance decl with skolem constants
; (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty
; let dict_constr = classDataCon clas
this_dict_id = instToId this_dict
dict_bind = mkVarBind this_dict_id dict_rhs
; let dict_constr = classDataCon clas
this_dict_id = instToId this_dict
dict_bind = mkVarBind this_dict_id dict_rhs
- dict_rhs = foldl mk_app inst_constr (sc_ids ++ meth_ids)
+ dict_rhs = foldl mk_app inst_constr sc_meth_ids
+ sc_meth_ids = sc_ids ++ 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
inst_constr = L loc $ wrapId (mkWpTyApps inst_tys')
(dataConWrapId dict_constr)
-- We don't produce a binding for the dict_constr; instead we
-- See Note [ClassOp/DFun selection]
-- See also note [Single-method classes]
dfun_id_w_fun = dfun_id
-- See Note [ClassOp/DFun selection]
-- See also note [Single-method classes]
dfun_id_w_fun = dfun_id
- `setIdUnfolding` mkDFunUnfolding dict_constr (sc_ids ++ meth_ids)
+ `setIdUnfolding` mkDFunUnfolding inst_ty (map Var sc_meth_ids)
`setInlinePragma` dfunInlinePragma
main_bind = AbsBinds
`setInlinePragma` dfunInlinePragma
main_bind = AbsBinds
method_ids <- mapM (method args) paMethods
pa_tc <- builtin paTyCon
method_ids <- mapM (method args) paMethods
pa_tc <- builtin paTyCon
- pa_con <- builtin paDataCon
+ pa_dc <- builtin paDataCon
let dict = mkLams (tvs ++ args)
let dict = mkLams (tvs ++ args)
$ Type inst_ty : map (method_call args) method_ids
dfun_ty = mkForAllTys tvs
$ mkFunTys (map varType args) (mkTyConApp pa_tc [inst_ty])
raw_dfun <- newExportedVar dfun_name dfun_ty
$ Type inst_ty : map (method_call args) method_ids
dfun_ty = mkForAllTys tvs
$ mkFunTys (map varType args) (mkTyConApp pa_tc [inst_ty])
raw_dfun <- newExportedVar dfun_name dfun_ty
- let dfun = raw_dfun `setIdUnfolding` mkDFunUnfolding pa_con method_ids
+ let dfun = raw_dfun `setIdUnfolding` mkDFunUnfolding dfun_ty (map Var method_ids)
`setInlinePragma` dfunInlinePragma
hoistBinding dfun dict
`setInlinePragma` dfunInlinePragma
hoistBinding dfun dict