summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/coreSyn/CoreFVs.lhs8
-rw-r--r--compiler/coreSyn/CoreSubst.lhs4
-rw-r--r--compiler/coreSyn/CoreSyn.lhs40
-rw-r--r--compiler/coreSyn/CoreUnfold.lhs27
-rw-r--r--compiler/coreSyn/PprCore.lhs9
-rw-r--r--compiler/deSugar/DsBinds.lhs15
-rw-r--r--compiler/iface/MkIface.lhs2
-rw-r--r--compiler/iface/TcIface.lhs4
-rw-r--r--compiler/main/TidyPgm.lhs12
-rw-r--r--compiler/simplCore/Simplify.lhs4
-rw-r--r--compiler/typecheck/TcInstDcls.lhs12
-rw-r--r--compiler/vectorise/VectType.hs6
12 files changed, 96 insertions, 47 deletions
diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs
index 1e8c9e7b0b..46c21b26dd 100644
--- a/compiler/coreSyn/CoreFVs.lhs
+++ b/compiler/coreSyn/CoreFVs.lhs
@@ -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}
diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index c5d8b83e55..3578037f30 100644
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -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!
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 2ddc7a51de..b7a859fa9d 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -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
diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index e645fab4bb..e73e4b07c5 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -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
diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 209ebfbea0..37e22cf64a 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -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
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index bfe4323511..2c6f361ca0 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -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
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 07b1268164..5c236b306f 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -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
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index d8bd414edd..1f846d37fb 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -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
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 0245978491..6a0a2cfcde 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -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
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index b0718e439b..ec7e190e99 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -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
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 55fc342e30..374fb6dab5 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -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
diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index 37d65db91e..37022cfc1d 100644
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -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
View Lorry Controller Status