Commit a90dc390 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Robustify the treatement of DFunUnfolding

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
parent 470ff37b
......@@ -422,10 +422,10 @@ idUnfoldingVars :: Id -> VarSet
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
\end{code}
......
......@@ -543,8 +543,8 @@ substUnfoldingSC subst unf -- Short-cut version
| 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!
......
......@@ -420,12 +420,17 @@ data 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)
-- 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).
......@@ -509,7 +514,34 @@ data UnfoldingGuidance
-- (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
......
......@@ -40,6 +40,7 @@ import StaticFlags
import DynFlags
import CoreSyn
import PprCore () -- Instances
import TcType ( tcSplitSigmaTy, tcSplitDFunHead )
import OccurAnal
import CoreSubst hiding( substTy )
import CoreFVs ( exprFreeVars )
......@@ -126,8 +127,16 @@ mkCoreUnfolding top_lvl src expr arity 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
......@@ -1223,13 +1232,15 @@ exprIsConApp_maybe id_unf expr
analyse (Var fun) args
| Just con <- isDataConWorkId_maybe fun
, is_saturated
, 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]
| 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,
......@@ -1241,7 +1252,6 @@ exprIsConApp_maybe id_unf expr
= -- pprTrace "expanding" (ppr fun $$ ppr rhs) $
analyse rhs args
where
is_saturated = count isValArg args == idArity fun
unfolding = id_unf fun
analyse _ _ = Nothing
......@@ -1282,3 +1292,8 @@ So to split it up we just need to apply the ops $c1, $c2 etc
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
......@@ -386,10 +386,11 @@ instance Outputable UnfoldingSource 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
......
......@@ -462,6 +462,7 @@ dsSpecs poly_id poly_rhs prags
; 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 } ;
......@@ -473,10 +474,9 @@ dsSpecs poly_id poly_rhs prags
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
......@@ -511,12 +511,13 @@ dsSpecs poly_id poly_rhs prags
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
; 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
......
......@@ -1545,7 +1545,7 @@ toIfUnfolding lb unf@(CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
-- 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
......
......@@ -1053,11 +1053,9 @@ tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
= 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
(_, 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
......
......@@ -709,10 +709,10 @@ addExternal expose_all id = (new_needed_ids, show_unfold)
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
......@@ -1094,8 +1094,8 @@ tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info
------------ 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
......
......@@ -705,8 +705,8 @@ simplUnfolding :: SimplEnv-> TopLevelFlag
-> 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
......
......@@ -32,6 +32,7 @@ import DataCon
import Class
import Var
import CoreUnfold ( mkDFunUnfolding )
import CoreSyn ( Expr(Var) )
import Id
import MkId
import Name
......@@ -704,9 +705,9 @@ tc_inst_decl2 dfun_id (NewTypeDerived coi _)
-- 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
......@@ -773,7 +774,8 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
; 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
......@@ -791,7 +793,7 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
-- 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
......
......@@ -802,16 +802,16 @@ buildPADict vect_tc prepr_tc arr_tc repr
method_ids <- mapM (method args) paMethods
pa_tc <- builtin paTyCon
pa_con <- builtin paDataCon
pa_dc <- builtin paDataCon
let dict = mkLams (tvs ++ args)
$ mkConApp pa_con
$ mkConApp pa_dc
$ 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
......
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