Commit a9d48fd9 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Remove "silent superclass parameters"

We introduced silent superclass parameters as a way to avoid
superclass loops, but we now solve that problem a different
way ("derived" superclass constraints carry no evidence). So
they aren't needed any more.

Apart from being a needless complication, they broke DoCon.
Admittedly in a very obscure way, but still the result is
hard to explain. To see the details see Trac #5051, with
test case typecheck/should_compile/T5051.  (The test is
nice and small!)
parent 089cc292
......@@ -49,7 +49,7 @@ module Id (
isStrictId,
isExportedId, isLocalId, isGlobalId,
isRecordSelector, isNaughtyRecordSelector,
isClassOpId_maybe, isDFunId, dfunNSilent,
isClassOpId_maybe, isDFunId,
isPrimOpId, isPrimOpId_maybe,
isFCallId, isFCallId_maybe,
isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,
......@@ -338,11 +338,6 @@ isDFunId id = case Var.idDetails id of
DFunId {} -> True
_ -> False
dfunNSilent :: Id -> Int
dfunNSilent id = case Var.idDetails id of
DFunId ns _ -> ns
_ -> pprTrace "dfunSilent: not a dfun:" (ppr id) 0
isPrimOpId_maybe id = case Var.idDetails id of
PrimOpId op -> Just op
_ -> Nothing
......
......@@ -129,14 +129,7 @@ data IdDetails
| TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary)
| DFunId Int Bool -- ^ A dictionary function.
-- Int = the number of "silent" arguments to the dfun
-- e.g. class D a => C a where ...
-- instance C a => C [a]
-- has is_silent = 1, because the dfun
-- has type dfun :: (D a, C a) => C [a]
-- See the DFun Superclass Invariant in TcInstDcls
--
| DFunId Bool -- ^ A dictionary function.
-- Bool = True <=> the class has only one method, so may be
-- implemented with a newtype, so it might be bad
-- to be strict on this dictionary
......@@ -158,8 +151,7 @@ pprIdDetails other = brackets (pp other)
pp (PrimOpId _) = ptext (sLit "PrimOp")
pp (FCallId _) = ptext (sLit "ForeignCall")
pp (TickBoxOpId _) = ptext (sLit "TickBoxOp")
pp (DFunId ns nt) = ptext (sLit "DFunId")
<> ppWhen (ns /= 0) (brackets (int ns))
pp (DFunId nt) = ptext (sLit "DFunId")
<> ppWhen nt (ptext (sLit "(nt)"))
pp (RecSelId { sel_naughty = is_naughty })
= brackets $ ptext (sLit "RecSel")
......
......@@ -826,26 +826,17 @@ mkDictFunId :: Name -- Name to use for the dict fun;
-- Implements the DFun Superclass Invariant (see TcInstDcls)
mkDictFunId dfun_name tvs theta clas tys
= mkExportedLocalVar (DFunId n_silent is_nt)
= mkExportedLocalVar (DFunId is_nt)
dfun_name
dfun_ty
vanillaIdInfo
where
is_nt = isNewTyCon (classTyCon clas)
(n_silent, dfun_ty) = mkDictFunTy tvs theta clas tys
dfun_ty = mkDictFunTy tvs theta clas tys
mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> (Int, Type)
mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> 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 (`eqPred` pred) theta
-- See the DFun Superclass Invariant in TcInstDcls
= mkSigmaTy tvs theta (mkDictTy clas tys)
\end{code}
......
......@@ -500,7 +500,6 @@ data Unfolding
data DFunArg e -- Given (df a b d1 d2 d3)
= DFunPolyArg e -- Arg is (e a b d1 d2 d3)
| DFunConstArg e -- Arg is e, which is constant
| DFunLamArg Int -- Arg is one of [a,b,d1,d2,d3], zero indexed
deriving( Functor )
-- 'e' is often CoreExpr, which are usually variables, but can
......@@ -510,7 +509,6 @@ dfunArgExprs :: [DFunArg e] -> [e]
dfunArgExprs [] = []
dfunArgExprs (DFunPolyArg e : as) = e : dfunArgExprs as
dfunArgExprs (DFunConstArg e : as) = e : dfunArgExprs as
dfunArgExprs (DFunLamArg {} : as) = dfunArgExprs as
------------------------------------------------
......
......@@ -1300,7 +1300,6 @@ exprIsConApp_maybe id_unf expr
, let (dfun_tvs, _n_theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
mk_arg (DFunConstArg e) = e
mk_arg (DFunLamArg i) = args !! i
mk_arg (DFunPolyArg e) = mkApps e args
= Just (con, substTys subst dfun_res_tys, map mk_arg ops)
......
......@@ -734,7 +734,7 @@ exprOkForSpeculation other_expr
-- A bit conservative: we don't really need
-- to care about lazy arguments, but this is easy
spec_ok (DFunId _ new_type) _ = not new_type
spec_ok (DFunId new_type) _ = not new_type
-- DFuns terminate, unless the dict is implemented with a newtype
-- in which case they may not
......
......@@ -442,7 +442,6 @@ instance Outputable Unfolding where
instance Outputable e => Outputable (DFunArg e) where
ppr (DFunPolyArg e) = braces (ppr e)
ppr (DFunConstArg e) = ppr e
ppr (DFunLamArg i) = char '<' <> int i <> char '>'
\end{code}
-----------------------------------------------------
......
......@@ -1173,7 +1173,7 @@ instance Binary IfaceBinding where
instance Binary IfaceIdDetails where
put_ bh IfVanillaId = putByte bh 0
put_ bh (IfRecSelId a b) = do { putByte bh 1; put_ bh a; put_ bh b }
put_ bh (IfDFunId n) = do { putByte bh 2; put_ bh n }
put_ bh IfDFunId = putByte bh 2
get bh = do
h <- getByte bh
case h of
......@@ -1181,7 +1181,7 @@ instance Binary IfaceIdDetails where
1 -> do a <- get bh
b <- get bh
return (IfRecSelId a b)
_ -> do { n <- get bh; return (IfDFunId n) }
_ -> return IfDFunId
instance Binary IfaceIdInfo where
put_ bh NoInfo = putByte bh 0
......@@ -1276,12 +1276,10 @@ instance Binary IfaceUnfolding where
instance Binary (DFunArg IfaceExpr) where
put_ bh (DFunPolyArg e) = putByte bh 0 >> put_ bh e
put_ bh (DFunConstArg e) = putByte bh 1 >> put_ bh e
put_ bh (DFunLamArg i) = putByte bh 2 >> put_ bh i
get bh = do { h <- getByte bh
; case h of
0 -> do { a <- get bh; return (DFunPolyArg a) }
1 -> do { a <- get bh; return (DFunConstArg a) }
_ -> do { a <- get bh; return (DFunLamArg a) } }
_ -> do { a <- get bh; return (DFunConstArg a) } }
instance Binary IfaceNote where
put_ bh (IfaceSCC aa) = do
......
......@@ -177,7 +177,7 @@ type IfaceAnnTarget = AnnTarget OccName
data IfaceIdDetails
= IfVanillaId
| IfRecSelId IfaceTyCon Bool
| IfDFunId Int -- Number of silent args
| IfDFunId
data IfaceIdInfo
= NoInfo -- When writing interface file without -O
......@@ -672,7 +672,7 @@ instance Outputable IfaceIdDetails where
ppr IfVanillaId = empty
ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc
<+> if b then ptext (sLit "<naughty>") else empty
ppr (IfDFunId ns) = ptext (sLit "DFunId") <> brackets (int ns)
ppr IfDFunId = ptext (sLit "DFunId")
instance Outputable IfaceIdInfo where
ppr NoInfo = empty
......
......@@ -1498,7 +1498,7 @@ toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
--------------------------
toIfaceIdDetails :: IdDetails -> IfaceIdDetails
toIfaceIdDetails VanillaId = IfVanillaId
toIfaceIdDetails (DFunId ns _) = IfDFunId ns
toIfaceIdDetails (DFunId {}) = IfDFunId
toIfaceIdDetails (RecSelId { sel_naughty = n
, sel_tycon = tc }) = IfRecSelId (toIfaceTyCon tc) n
toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
......
......@@ -1026,8 +1026,8 @@ do_one (IfaceRec pairs) thing_inside
\begin{code}
tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
tcIdDetails _ IfVanillaId = return VanillaId
tcIdDetails ty (IfDFunId ns)
= return (DFunId ns (isNewTyCon (classTyCon cls)))
tcIdDetails ty IfDFunId
= return (DFunId (isNewTyCon (classTyCon cls)))
where
(_, _, cls, _) = tcSplitDFunTy ty
......@@ -1099,7 +1099,6 @@ tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
doc = text "Class ops for dfun" <+> ppr name
tc_arg (DFunPolyArg e) = do { e' <- tcIfaceExpr e; return (DFunPolyArg e') }
tc_arg (DFunConstArg e) = do { e' <- tcIfaceExpr e; return (DFunConstArg e') }
tc_arg (DFunLamArg i) = return (DFunLamArg i)
tcUnfolding name ty info (IfExtWrapper arity wkr)
= tcIfaceWrapper name ty info arity (tcIfaceExtId wkr)
......
......@@ -33,7 +33,6 @@ import Util
import FastString
import Outputable
import DynFlags
import StaticFlags( opt_PprStyle_Debug )
import Data.List( partition )
import Control.Monad( when, unless )
\end{code}
......@@ -242,15 +241,8 @@ getUserGivens :: ReportErrCtxt -> [([EvVar], GivenLoc)]
-- One item for each enclosing implication
getUserGivens (CEC {cec_encl = ctxt})
= reverse $
[ (givens', loc) | Implic {ic_given = givens, ic_loc = loc} <- ctxt
, let givens' = get_user_givens givens
, not (null givens') ]
where
get_user_givens givens | opt_PprStyle_Debug = givens
| otherwise = filterOut isSilentEvVar givens
-- In user mode, don't show the "silent" givens, used for
-- the "self" dictionary and silent superclass arguments for dfuns
[ (givens, loc) | Implic {ic_given = givens, ic_loc = loc} <- ctxt
, not (null givens) ]
\end{code}
......
......@@ -798,25 +798,13 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
-- See Note [Subtle interaction of recursion and overlap]
-- and Note [Binding when looking up instances]
; let (clas, inst_tys) = tcSplitDFunHead inst_head
(class_tyvars, sc_theta, _, op_items) = classBigSig clas
(class_tyvars, sc_theta, sc_sels, op_items) = classBigSig clas
sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
n_ty_args = length inst_tyvars
n_silent = dfunNSilent dfun_id
(silent_theta, orig_theta) = splitAt n_silent dfun_theta
; dfun_ev_vars <- newEvVars dfun_theta
; silent_ev_vars <- mapM newSilentGiven silent_theta
; orig_ev_vars <- newEvVars orig_theta
; let dfun_ev_vars = silent_ev_vars ++ orig_ev_vars
; (sc_dicts, sc_args)
<- mapAndUnzipM (tcSuperClass n_ty_args dfun_ev_vars) sc_theta'
-- Check that any superclasses gotten from a silent arguemnt
-- can be deduced from the originally-specified dfun arguments
; ct_loc <- getCtLoc ScOrigin
; _ <- checkConstraints skol_info inst_tyvars orig_ev_vars $
emitFlats $ listToBag $
[ mkEvVarX sc ct_loc | sc <- sc_dicts, isSilentEvVar sc ]
; (sc_args, sc_binds)
<- mapAndUnzipM (tcSuperClass inst_tyvars dfun_ev_vars)
(sc_sels `zip` sc_theta')
-- Deal with 'SPECIALISE instance' pragmas
-- See Note [SPECIALISE instance pragmas]
......@@ -838,9 +826,14 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
[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)
map wrap_sc sc_args
++ map (wrapId arg_wrapper) meth_ids
wrap_sc (DFunPolyArg (Var sc)) = wrapId arg_wrapper sc
wrap_sc (DFunConstArg (Var sc)) = HsVar sc
wrap_sc _ = panic "wrap_sc"
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
......@@ -872,30 +865,50 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
, abs_binds = unitBag dict_bind }
; return (unitBag (L loc main_bind) `unionBags`
listToBag meth_binds)
listToBag meth_binds `unionBags`
unionManyBags sc_binds)
}
where
skol_info = InstSkol
dfun_ty = idType dfun_id
dfun_id = instanceDFunId ispec
loc = getSrcSpan dfun_id
------------------------------
tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (EvVar, DFunArg CoreExpr)
-- All superclasses should be either
-- (a) be one of the arguments to the dfun, of
-- (b) be a constant, soluble at top level
tcSuperClass n_ty_args ev_vars pred
| Just (ev, i) <- find n_ty_args ev_vars
= return (ev, DFunLamArg i)
tcSuperClass :: [TcTyVar] -> [EvVar]
-> (Id, PredType)
-> TcM (DFunArg CoreExpr, LHsBinds Id)
-- For a constant superclass (no free tyvars)
-- return sc_dict, no bindings, DFunConstArg
-- For a non-constant superclass
-- build a top level decl like
-- sc_op = /\a \d. let sc = ... in
-- sc
-- and return sc_op, that binding, DFunPolyArg
tcSuperClass tyvars ev_vars (sc_sel, sc_pred)
| isEmptyVarSet (tyVarsOfPred sc_pred) -- Constant
= do { sc_dict <- emitWanted ScOrigin sc_pred
; return (DFunConstArg (Var sc_dict), emptyBag) }
| otherwise
= ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred) -- Constant!
do { sc_dict <- emitWanted ScOrigin pred
; return (sc_dict, DFunConstArg (Var sc_dict)) }
where
find _ [] = Nothing
find i (ev:evs) | pred `eqPred` evVarPred ev = Just (ev, i)
| otherwise = find (i+1) evs
= do { (ev_binds, sc_dict)
<- newImplication InstSkol tyvars ev_vars $
emitWanted ScOrigin sc_pred
; uniq <- newUnique
; let sc_op_ty = mkForAllTys tyvars $ mkPiTypes ev_vars (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 ev_vars
<.> mkWpLet ev_binds
binds = unitBag (noLoc sc_op_bind)
; return (DFunPolyArg (Var sc_op_id), binds) }
------------------------------
tcSpecInstPrags :: DFunId -> InstBindings Name
......@@ -909,74 +922,26 @@ tcSpecInstPrags dfun_id (VanillaInst binds uprags _)
; return (spec_inst_prags, mkPragFun uprags binds) }
\end{code}
Note [Silent Superclass Arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Note [Superclass loop avoidance]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following (extreme) situation:
class C a => D a where ...
instance D [a] => D [a] where ...
Although this looks wrong (assume D [a] to prove D [a]), it is only a
more extreme case of what happens with recursive dictionaries.
more extreme case of what happens with recursive dictionaries, and it
can, just about, make sense because the methods do some work before
recursing.
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:
which we had better not get by superclass selection from the supplied
argument:
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:
dw := dfun dw
Although recursive, this binding would pass the TcSMonadisGoodRecEv
check because it appears as guarded. But in reality, it will make a
bottom superclass. The trouble is that isGoodRecEv can't "see" the
superclass-selection inside dfun.
Our solution to this problem is to change the way ‘dfuns’ are created
for instances, so that we pass as first arguments to the dfun some
``silent superclass arguments’’, which are the immediate superclasses
of the dictionary we are trying to construct. In our example:
dfun :: forall a. (C [a], D [a] -> D [a]
dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...
This gives us:
-----------------------------------------------------------
DFun Superclass Invariant
~~~~~~~~~~~~~~~~~~~~~~~~
In the body of a DFun, every superclass argument to the
returned dictionary is
either * one of the arguments of the DFun,
or * constant, bound at top level
-----------------------------------------------------------
This means that no superclass is hidden inside a dfun application, so
the counting argument in isGoodRecEv (more dfun calls than superclass
selections) works correctly.
The extra arguments required to satisfy the DFun Superclass Invariant
always come first, and are called the "silent" arguments. DFun types
are built (only) by MkId.mkDictFunId, so that is where we decide
what silent arguments are to be added.
This net effect is that it is safe to treat a dfun application as
wrapping a dictionary constructor around its arguments (in particular,
a dfun never picks superclasses from the arguments under the dictionary
constructor).
In our example, if we had [Wanted] dw :: D [a] we would get via the instance:
dw := dfun d1 d2
[Wanted] (d1 :: C [a])
[Wanted] (d2 :: D [a])
[Derived] (d :: D [a])
[Derived] (scd :: C [a]) scd := scsel d
[Derived] (scd2 :: C [a]) scd2 := scsel d2
And now, though we *can* solve:
d2 := dw
we will get an isGoodRecEv failure when we try to solve:
d1 := scsel d
or
d1 := scsel d2
Rather, we want to get it by finding an instance for (C [a]). We
achieve this by
not making the superclasses of a "wanted"
available for solving wanted constraints.
Test case SCLoop tests this fix.
......@@ -1028,7 +993,7 @@ tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
= addErrCtxt (spec_ctxt prag) $
do { let name = idName dfun_id
; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty
; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys
; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys
; co_fn <- tcSubType (SpecPragOrigin name) SpecInstCtxt
(idType dfun_id) spec_dfun_ty
......@@ -1097,11 +1062,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
tc_default sel_id (GenDefMeth dm_name)
= do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
; tc_body sel_id False {- Not generated code? -} meth_bind }
{-
tc_default sel_id GenDefMeth -- Derivable type classes stuff
= do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id
; tc_body sel_id False {- Not generated code? -} meth_bind }
-}
tc_default sel_id NoDefMeth -- No default method at all
= do { warnMissingMethod sel_id
; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
......
......@@ -31,9 +31,9 @@ import Coercion
import Outputable
import TcRnTypes
import TcMType ( isSilentEvVar )
import TcErrors
import TcSMonad
import Maybes( orElse )
import Bag
import qualified Data.Map as Map
......@@ -2086,8 +2086,7 @@ matchClassInst inerts clas tys loc
| given_overlap untch ->
do { traceTcS "Delaying instance application" $
vcat [ text "Workitem=" <+> pprPredTy (ClassP clas tys)
, text "Silents and their superclasses=" <+> ppr silents_and_their_scs
, text "All given dictionaries=" <+> ppr all_given_dicts ]
, text "Relevant given dictionaries=" <+> ppr givens_for_this_clas ]
; return NoInstance -- see Note [Instance and Given overlap]
}
......@@ -2110,57 +2109,31 @@ matchClassInst inerts clas tys loc
; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars) }
}
}
where given_overlap :: TcsUntouchables -> Bool
given_overlap untch
= foldlBag (\r d -> r || matchable untch d) False all_given_dicts
matchable untch (CDictCan { cc_class = clas', cc_tyargs = sys, cc_flavor = fl })
| Just GivenOrig <- isGiven_maybe fl
, clas' == clas
, does_not_originate_in_a_silent clas' sys
= case tcUnifyTys (\tv -> if isTouchableMetaTyVar_InRange untch tv &&
tv `elemVarSet` tyVarsOfTypes tys
then BindMe else Skolem) tys sys of
-- We can't learn anything more about any variable at this point, so the only
-- cause of overlap can be by an instantiation of a touchable unification
-- variable. Hence we only bind touchable unification variables. In addition,
-- we use tcUnifyTys instead of tcMatchTys to rule out cyclic substitutions.
Nothing -> False
Just _ -> True
| otherwise = False -- No overlap with a solved, already been taken care of
-- by the overlap check with the instance environment.
matchable _tys ct = pprPanic "Expecting dictionary!" (ppr ct)
does_not_originate_in_a_silent clas sys
-- UGLY: See Note [Silent parameters overlapping]
= null $ filter (eqPred (ClassP clas sys)) silents_and_their_scs
silents_and_their_scs
= foldlBag (\acc rvnt -> case rvnt of
CDictCan { cc_id = d, cc_class = c, cc_tyargs = s }
| isSilentEvVar d -> (ClassP c s) : (transSuperClasses c s) ++ acc
_ -> acc) [] all_given_dicts
-- TODO:
-- When silent parameters will go away we should simply select from
-- the given map of the inert set.
all_given_dicts = Map.fold unionBags emptyCCan (cts_given $ inert_dicts inerts)
where
givens_for_this_clas :: CanonicalCts
givens_for_this_clas = Map.lookup clas (cts_given (inert_dicts inerts))
`orElse` emptyBag
given_overlap :: TcsUntouchables -> Bool
given_overlap untch = anyBag (matchable untch) givens_for_this_clas
matchable untch (CDictCan { cc_class = clas_g, cc_tyargs = sys, cc_flavor = fl })
| Just GivenOrig <- isGiven_maybe fl
= ASSERT( clas_g == clas )
case tcUnifyTys (\tv -> if isTouchableMetaTyVar_InRange untch tv &&
tv `elemVarSet` tyVarsOfTypes tys
then BindMe else Skolem) tys sys of
-- We can't learn anything more about any variable at this point, so the only
-- cause of overlap can be by an instantiation of a touchable unification
-- variable. Hence we only bind touchable unification variables. In addition,
-- we use tcUnifyTys instead of tcMatchTys to rule out cyclic substitutions.
Nothing -> False
Just _ -> True
| otherwise = False -- No overlap with a solved, already been taken care of
-- by the overlap check with the instance environment.
matchable _tys ct = pprPanic "Expecting dictionary!" (ppr ct)
\end{code}
Note [Silent parameters overlapping]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DV 12/05/2011:
The long-term goal is to completely remove silent superclass
parameters when checking instance declarations. But until then we must
make sure that we never prevent the application of an instance
declaration because of a potential match from a silent parameter --
after all we are supposed to have solved that silent parameter from
some instance, anyway! In effect silent parameters behave more like
Solved than like Given.
A concrete example appears in typecheck/SilentParametersOverlapping.hs
Note [Instance and Given overlap]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Assume that we have an inert set that looks as follows:
......
......@@ -26,7 +26,7 @@ module TcMType (
--------------------------------
-- Creating new evidence variables
newEvVar, newCoVar, newEvVars,
newIP, newDict, newSilentGiven, isSilentEvVar,
newIP, newDict,
newWantedEvVar, newWantedEvVars,
newTcEvBinds, addTcEvBind,
......@@ -160,26 +160,6 @@ newName occ
= do { uniq <- newUnique
; loc <- getSrcSpanM
; return (mkInternalName uniq occ loc) }
-----------------
newSilentGiven :: PredType -> TcM EvVar
-- Make a dictionary for a "silent" given dictionary
-- Behaves just like any EvVar except that it responds True to isSilentDict
-- This is used only to suppress confusing error reports
newSilentGiven (ClassP cls tys)
= do { uniq <- newUnique
; let name = mkSystemName uniq (mkDictOcc (getOccName cls))
; return (mkLocalId name (mkPredTy (ClassP cls tys))) }
newSilentGiven (EqPred ty1 ty2)
= do { uniq <- newUnique
; let name = mkSystemName uniq (mkTyVarOccFS (fsLit "co"))
; return (mkCoVar name (mkPredTy (EqPred ty1 ty2))) }
newSilentGiven pred@(IParam {})
= pprPanic "newSilentDict" (ppr pred) -- Implicit parameters rejected earlier
isSilentEvVar :: EvVar -> Bool
isSilentEvVar v = isSystemName (Var.varName v)
-- Notice that all *other* evidence variables get Internal Names
\end{code}
......
......@@ -151,12 +151,8 @@ pprInstance ispec
pprInstanceHdr :: Instance -> SDoc
-- Prints the Instance as an instance declaration
pprInstanceHdr ispec@(Instance { is_flag = flag })
= getPprStyle $ \ sty ->
let theta_to_print
| debugStyle sty = theta
| otherwise = drop (dfunNSilent dfun) theta
in ptext (sLit "instance") <+> ppr flag
<+> sep [pprThetaArrowTy theta_to_print, ppr res_ty]
= ptext (sLit "instance") <+> ppr flag
<+> sep [pprThetaArrowTy theta, ppr res_ty]
where
dfun = is_dfun ispec
(_, theta, res_ty) = tcSplitSigmaTy (idType dfun)
......@@ -166,14 +162,11 @@ pprInstances :: [Instance] -> SDoc
pprInstances ispecs = vcat (map pprInstance ispecs)
instanceHead :: Instance -> ([TyVar], ThetaType, Class, [Type])
-- Returns the *source* theta, without the silent arguments
instanceHead ispec
= (tvs, drop n_silent theta, cls, tys)
instanceHead ispec = (tvs, theta, cls, tys)
where
(tvs, theta, tau) = tcSplitSigmaTy (idType dfun)
(cls, tys) = tcSplitDFunHead tau
dfun = is_dfun ispec
n_silent = dfunNSilent dfun
mkLocalInstance :: DFunId
-> OverlapFlag
......
......@@ -5,7 +5,7 @@ where
import Vectorise.Monad
import Vectorise.Builtins
import Vectorise.Type.Repr
import Vectorise.Type.PRepr
import Vectorise.Type.PRepr( buildPAScAndMethods )
import Vectorise.Utils
import BasicTypes
......@@ -18,13 +18,13 @@ import TypeRep
import Id
import Var
import Name
import FastString
-- import FastString
-- import Outputable
-- debug = False
-- dtrace s x = if debug then pprTrace "Vectoris.Type.PADict" s x else x
-- | Build the PA dictionary for some type and hoist it to top level.
-- | Build the PA dictionary function for some type and hoist it to top level.
-- The PA dictionary holds fns that convert values to and from their vectorised representations.
buildPADict
:: TyCon -- ^ tycon of the type being vectorised.
......@@ -33,48 +33,47 @@ buildPADict
-> SumRepr -- ^ representation used for the type being vectorised.
-> VM Var -- ^ name of the top-level dictionary function.
buildPADict vect_tc prepr_tc arr_tc repr
= polyAbstract tvs $ \args ->
do
-- The superclass dictionary is an argument if the tycon is polymorphic
let mk_super_ty = do
r <- mkPReprType inst_ty
pr_cls <- builtin prClass
return $ PredTy $ ClassP pr_cls [r]
super_tys <- sequence [mk_super_ty | not (null tvs)]
super_args <- mapM (newLocalVar (fsLit "pr")) super_tys
let args' = super_args ++ args
-- it is constant otherwise
super_consts <- sequence [prDictOfPReprInstTyCon inst_ty prepr_tc []
| null tvs]
-- Recall the definition:
-- class class PR (PRepr a) => PA a where
-- toPRepr :: a -> PRepr a
-- fromPRepr :: PRepr a -> a
-- toArrPRepr :: PData a -> PData (PRepr a)
-- fromArrPRepr :: PData (PRepr a) -> PData a
--
-- Example:
-- df :: forall a. PA a -> PA (T a)
-- df = /\a. \(d:PA a). MkPA ($PR_df a d) ($toPRepr a d) ...
-- $dPR_df :: forall a. PA a -> PR (PRepr (T a))
-- $dPR_df = ....
-- $toRepr :: forall a. PA a -> T a -> PRepr (T a)
-- $toPRepr = ...
-- The "..." stuff is filled in by buildPAScAndMethods
-- Get ids for each of the methods in the dictionary.
method_ids <- mapM (method args') paMethods
buildPADict vect_tc prepr_tc arr_tc repr
= polyAbstract tvs $ \args -> -- The args are the dictionaries we lambda
-- abstract over; and they are put in the
-- envt, so when we need a (PA a) we can
-- find it in the envt
do -- Get ids for each of the methods in the dictionary, including superclass
method_ids <- mapM (method args) buildPAScAndMethods
-- Expression to build the dictionary.
pa_dc <- builtin paDataCon
let dict = mkLams (tvs ++ args')
let dict = mkLams (tvs ++ args)
$ mkConApp pa_dc
$ Type inst_ty
: map Var super_args ++ super_consts
-- the superclass dictionary is
-- either lambda-bound or
-- constant
++ map (method_call args') method_ids
: map (method_call args) method_ids
-- Build the type of the dictionary function.
pa_cls <- builtin paClass
let dfun_ty = mkForAllTys tvs
$ mkFunTys (map varType args')
(PredTy $ ClassP pa_cls [inst_ty])
let dfun_ty = mkForAllTys tvs
$ mkFunTys (map varType args)
(PredTy $ ClassP pa_cls [inst_ty])
-- Set the unfolding for the inliner.
raw_dfun <- newExportedVar dfun_name dfun_ty
let dfun_unf = mkDFunUnfolding dfun_ty
$ map (const $ DFunLamArg 0) super_args
++ map DFunConstArg super_consts
++ map (DFunPolyArg . Var) method_ids
let dfun_unf = mkDFunUnfolding dfun_ty $
map (DFunPolyArg . Var) method_ids
dfun = raw_dfun `setIdUnfolding` dfun_unf
`setInlinePragma` dfunInlinePragma
......@@ -102,11 +101,3 @@ buildPADict vect_tc prepr_tc arr_tc repr
method_call args id = mkApps (Var id) (map Type arg_tys ++ map Var args)
method_name name = mkVarOcc $ occNameString dfun_name ++ ('$' : name)
paMethods :: [(String, TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr)]
paMethods = [("toPRepr", buildToPRepr),
("fromPRepr", buildFromPRepr),