From a3bab0506498db41853543558c52a4fda0d183af Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Mon, 13 Dec 2010 17:15:11 +0000 Subject: [PATCH] Fix recursive superclasses (again). Fixes Trac #4809. This patch finally deals with the super-delicate question of superclases in possibly-recursive dictionaries. The key idea is the DFun Superclass Invariant (see TcInstDcls): 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 To establish the invariant, we add new "silent" superclass argument(s) to each dfun, so that the dfun does not do superclass selection internally. There's a bit of hoo-ha to make sure that we don't print those silent arguments in error messages; a knock on effect was a change in interface-file format. A second change is that instead of the complex and fragile "self dictionary binding" in TcInstDcls and TcClassDcl, using the same mechanism for existential pattern bindings. See Note [Subtle interaction of recursion and overlap] in TcInstDcls and Note [Binding when looking up instances] in InstEnv. Main notes are here: * Note [Silent Superclass Arguments] in TcInstDcls, including the DFun Superclass Invariant Main code changes are: * The code for MkId.mkDictFunId and mkDictFunTy * DFunUnfoldings get a little more complicated; their arguments are a new type DFunArg (in CoreSyn) * No "self" argument in tcInstanceMethod * No special tcSimplifySuperClasss * No "dependents" argument to EvDFunApp IMPORTANT It turns out that it's quite tricky to generate the right DFunUnfolding for a specialised dfun, when you use SPECIALISE INSTANCE. For now I've just commented it out (in DsBinds) but that'll lose some optimisation, and I need to get back to this. --- compiler/basicTypes/Id.lhs | 11 +- compiler/basicTypes/IdInfo.lhs | 21 +- compiler/basicTypes/MkId.lhs | 36 ++- compiler/coreSyn/CoreFVs.lhs | 2 +- compiler/coreSyn/CoreSubst.lhs | 4 +- compiler/coreSyn/CoreSyn.lhs | 32 ++- compiler/coreSyn/CoreTidy.lhs | 2 +- compiler/coreSyn/CoreUnfold.lhs | 10 +- compiler/coreSyn/CoreUtils.lhs | 2 +- compiler/coreSyn/PprCore.lhs | 8 +- compiler/deSugar/DsBinds.lhs | 44 ++-- compiler/hsSyn/HsBinds.lhs | 5 +- compiler/hsSyn/HsExpr.lhs-boot | 4 + compiler/hsSyn/HsPat.lhs-boot | 1 + compiler/iface/BinIface.hs | 15 +- compiler/iface/IfaceSyn.lhs | 15 +- compiler/iface/MkIface.lhs | 4 +- compiler/iface/TcIface.lhs | 9 +- compiler/main/TidyPgm.lhs | 2 +- compiler/simplCore/Simplify.lhs | 2 +- compiler/typecheck/Inst.lhs | 14 +- compiler/typecheck/TcClassDcl.lhs | 24 +- compiler/typecheck/TcDeriv.lhs | 45 ++-- compiler/typecheck/TcEnv.lhs | 4 +- compiler/typecheck/TcErrors.lhs | 19 +- compiler/typecheck/TcHsSyn.lhs | 4 +- compiler/typecheck/TcHsType.lhs | 60 ++--- compiler/typecheck/TcInstDcls.lhs | 335 +++++++++++++++------------ compiler/typecheck/TcInteract.lhs | 5 +- compiler/typecheck/TcMType.lhs | 83 +++---- compiler/typecheck/TcSMonad.lhs | 8 +- compiler/typecheck/TcSimplify.lhs | 120 +--------- compiler/typecheck/TcType.lhs | 13 +- compiler/typecheck/TcUnify.lhs | 12 +- compiler/types/InstEnv.lhs | 26 ++- compiler/vectorise/Vectorise/Type/PADict.hs | 3 +- 36 files changed, 486 insertions(+), 518 deletions(-) diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index 65ab644..fd65fe4 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -49,7 +49,7 @@ module Id ( isImplicitId, isDeadBinder, isDictId, isStrictId, isExportedId, isLocalId, isGlobalId, isRecordSelector, isNaughtyRecordSelector, - isClassOpId_maybe, isDFunId, + isClassOpId_maybe, isDFunId, dfunNSilent, isPrimOpId, isPrimOpId_maybe, isFCallId, isFCallId_maybe, isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon, @@ -332,8 +332,13 @@ isPrimOpId id = case Var.idDetails id of _ -> False isDFunId id = case Var.idDetails id of - DFunId _ -> True - _ -> False + 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 diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index 9dda37e..1c01ba4 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -128,11 +128,17 @@ data IdDetails | TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary) - | DFunId Bool -- ^ A dictionary function. - -- 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 - + | 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 + -- + -- 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 instance Outputable IdDetails where ppr = pprIdDetails @@ -148,8 +154,9 @@ pprIdDetails other = brackets (pp other) pp (PrimOpId _) = ptext (sLit "PrimOp") pp (FCallId _) = ptext (sLit "ForeignCall") pp (TickBoxOpId _) = ptext (sLit "TickBoxOp") - pp (DFunId b) = ptext (sLit "DFunId") <> - ppWhen b (ptext (sLit "(newtype)")) + pp (DFunId ns nt) = ptext (sLit "DFunId") + <> ppWhen (ns /= 0) (brackets (int ns)) + <> ppWhen nt (ptext (sLit "(nt)")) pp (RecSelId { sel_naughty = is_naughty }) = brackets $ ptext (sLit "RecSel") <> ppWhen is_naughty (ptext (sLit "(naughty)")) diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 29c1f4c..4bfb53b 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -13,8 +13,7 @@ have a standard form, namely: \begin{code} module MkId ( - mkDictFunId, mkDefaultMethodId, - mkDictSelId, + mkDictFunId, mkDictFunTy, mkDefaultMethodId, mkDictSelId, mkDataConIds, mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId, @@ -492,15 +491,11 @@ mkDictSelId no_unf name clas 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 @@ -839,12 +834,29 @@ mkDictFunId :: Name -- Name to use for the dict fun; -> 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} diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index 24af9e2..9abf11f 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -432,7 +432,7 @@ idUnfoldingVars id = stableUnfoldingVars (realIdUnfolding id) stableUnfoldingVars :: Unfolding -> VarSet stableUnfoldingVars (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) | isStableSource src = exprFreeVars rhs -stableUnfoldingVars (DFunUnfolding _ _ args) = exprsFreeVars args +stableUnfoldingVars (DFunUnfolding _ _ args) = exprsFreeVars (dfunArgExprs args) stableUnfoldingVars _ = emptyVarSet \end{code} diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index 346f78f..a229b8c 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -574,7 +574,9 @@ substUnfoldingSC subst unf -- Short-cut version | otherwise = substUnfolding subst unf substUnfolding subst (DFunUnfolding ar con args) - = DFunUnfolding ar con (map (substExpr (text "dfun-unf") subst) args) + = DFunUnfolding ar con (map subst_arg args) + where + subst_arg = fmap (substExpr (text "dfun-unf") subst) 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 2dda733..0a8659c 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -4,7 +4,7 @@ % \begin{code} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-} -- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection module CoreSyn ( @@ -37,9 +37,9 @@ module CoreSyn ( notSccNote, -- * Unfolding data types - Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..), - -- Abstract everywhere but in CoreUnfold.lhs - + Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..), + DFunArg(..), dfunArgExprs, + -- ** Constructing 'Unfolding's noUnfolding, evaldUnfolding, mkOtherCon, unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk, @@ -437,10 +437,7 @@ data Unfolding 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). + [DFunArg CoreExpr] -- Specification of superclasses and methods, in positional order | CoreUnfolding { -- An unfolding for an Id with no pragma, -- or perhaps a NOINLINE pragma @@ -478,7 +475,24 @@ data Unfolding -- uf_guidance: Tells us about the /size/ of the unfolding template ------------------------------------------------ -data UnfoldingSource +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 + -- be trivial expressions instead (e.g. a type application). + +dfunArgExprs :: [DFunArg e] -> [e] +dfunArgExprs [] = [] +dfunArgExprs (DFunPolyArg e : as) = e : dfunArgExprs as +dfunArgExprs (DFunConstArg e : as) = e : dfunArgExprs as +dfunArgExprs (DFunLamArg {} : as) = dfunArgExprs as + + +------------------------------------------------ +data UnfoldingSource = InlineRhs -- The current rhs of the function -- Replace uf_tmpl each time around diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs index e3bc72a..582f873 100644 --- a/compiler/coreSyn/CoreTidy.lhs +++ b/compiler/coreSyn/CoreTidy.lhs @@ -197,7 +197,7 @@ tidyIdBndr env@(tidy_env, var_env) id ------------ Unfolding -------------- tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding tidyUnfolding tidy_env (DFunUnfolding ar con ids) _ - = DFunUnfolding ar con (map (tidyExpr tidy_env) ids) + = DFunUnfolding ar con (map (fmap (tidyExpr tidy_env)) ids) tidyUnfolding tidy_env unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) unf_from_rhs diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 5a00869..519fb74 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -91,7 +91,7 @@ mkImplicitUnfolding expr = mkTopUnfolding False (simpleOptExpr expr) mkSimpleUnfolding :: CoreExpr -> Unfolding mkSimpleUnfolding = mkUnfolding InlineRhs False False -mkDFunUnfolding :: Type -> [CoreExpr] -> Unfolding +mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding mkDFunUnfolding dfun_ty ops = DFunUnfolding dfun_nargs data_con ops where @@ -1270,9 +1270,11 @@ exprIsConApp_maybe id_unf expr 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, - [mkApps op args | op <- ops]) + 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) -- Look through unfoldings, but only cheap ones, because -- we are effectively duplicating the unfolding diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 69a5135..72977be 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -692,7 +692,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 diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index f167a1f..041b842 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -415,8 +415,7 @@ instance Outputable Unfolding where 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 con <+> brackets (pprWithCommas ppr 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 @@ -437,6 +436,11 @@ instance Outputable Unfolding where | otherwise = empty -- Don't print the RHS or we get a quadratic -- blowup in the size of the printout! + +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} ----------------------------------------------------- diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index d7a88c0..8cbcf81 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -11,7 +11,7 @@ lower levels it is preserved with @let@/@letrec@s). \begin{code} module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec, - dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds, + dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds, DsEvBind(..), AutoScc(..) ) where @@ -90,7 +90,7 @@ dsLHsBind auto_scc (L loc bind) dsHsBind :: AutoScc -> HsBind Id -> DsM (OrdList (Id,CoreExpr)) dsHsBind _ (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless }) - = do { core_expr <- dsLExpr expr + = do { core_expr <- dsLExpr expr -- Dictionary bindings are always VarBinds, -- so we only need do this here @@ -230,11 +230,11 @@ dsEvBinds bs = return (map dsEvGroup sccs) mk_node b@(EvBind var term) = (b, var, free_vars_of term) free_vars_of :: EvTerm -> [EvVar] - free_vars_of (EvId v) = [v] - free_vars_of (EvCast v co) = v : varSetElems (tyVarsOfType co) - free_vars_of (EvCoercion co) = varSetElems (tyVarsOfType co) - free_vars_of (EvDFunApp _ _ vs _) = vs - free_vars_of (EvSuperClass d _) = [d] + free_vars_of (EvId v) = [v] + free_vars_of (EvCast v co) = v : varSetElems (tyVarsOfType co) + free_vars_of (EvCoercion co) = varSetElems (tyVarsOfType co) + free_vars_of (EvDFunApp _ _ vs) = vs + free_vars_of (EvSuperClass d _) = [d] dsEvGroup :: SCC EvBind -> DsEvBind dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n))) @@ -261,10 +261,10 @@ dsEvGroup (CyclicSCC bs) ds_pair (EvBind v r) = (v, dsEvTerm r) dsEvTerm :: EvTerm -> CoreExpr -dsEvTerm (EvId v) = Var v -dsEvTerm (EvCast v co) = Cast (Var v) co -dsEvTerm (EvDFunApp df tys vars _deps) = Var df `mkTyApps` tys `mkVarApps` vars -dsEvTerm (EvCoercion co) = Type co +dsEvTerm (EvId v) = Var v +dsEvTerm (EvCast v co) = Cast (Var v) co +dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars +dsEvTerm (EvCoercion co) = Type co dsEvTerm (EvSuperClass d n) = ASSERT( isClassPred (classSCTheta cls !! n) ) -- We can only select *dictionary* superclasses @@ -537,31 +537,17 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) specUnfolding :: (CoreExpr -> CoreExpr) -> Type -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr)) +{- [Dec 10: TEMPORARILY commented out, until we can straighten out how to + generate unfoldings for specialised DFuns + 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 (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) } +-} specUnfolding _ _ _ = return (noUnfolding, nilOL) -{- -mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type --- If any of the tyvars is missing from any of the lists in --- the second arg, return a binding in the result -mkArbitraryTypeEnv tyvars exports - = go emptyVarEnv exports - where - go env [] = env - go env ((ltvs, _, _, _) : exports) - = go env' exports - where - env' = foldl extend env [tv | tv <- tyvars - , not (tv `elem` ltvs) - , not (tv `elemVarEnv` env)] - - extend env tv = extendVarEnv env tv (dsMkArbitraryType tv) --} - dsMkArbitraryType :: TcTyVar -> Type dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv) \end{code} diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 00aa1dc..2544515 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -449,9 +449,6 @@ data EvTerm | EvDFunApp DFunId -- Dictionary instance application [Type] [EvVar] - [EvVar] -- The dependencies, which is generally a bigger list than - -- the arguments of the dfun. - -- See Note [Dependencies in self dictionaries] in TcSimplify | EvSuperClass DictId Int -- n'th superclass. Used for both equalities and -- dictionaries, even though the former have no @@ -578,7 +575,7 @@ instance Outputable EvTerm where ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendType co ppr (EvCoercion co) = ppr co ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) - ppr (EvDFunApp df tys ts deps) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts, ppr deps ] + ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] \end{code} %************************************************************************ diff --git a/compiler/hsSyn/HsExpr.lhs-boot b/compiler/hsSyn/HsExpr.lhs-boot index 272bdbd..ccae210 100644 --- a/compiler/hsSyn/HsExpr.lhs-boot +++ b/compiler/hsSyn/HsExpr.lhs-boot @@ -12,9 +12,13 @@ data HsSplice i data MatchGroup a data GRHSs a +instance Typeable1 HsSplice instance Data i => Data (HsSplice i) +instance Typeable1 HsExpr instance Data i => Data (HsExpr i) +instance Typeable1 MatchGroup instance Data i => Data (MatchGroup i) +instance Typeable1 GRHSs instance Data i => Data (GRHSs i) type LHsExpr a = Located (HsExpr a) diff --git a/compiler/hsSyn/HsPat.lhs-boot b/compiler/hsSyn/HsPat.lhs-boot index 5a8726f..7ba338e 100644 --- a/compiler/hsSyn/HsPat.lhs-boot +++ b/compiler/hsSyn/HsPat.lhs-boot @@ -7,5 +7,6 @@ import Data.Data data Pat i type LPat i = Located (Pat i) +instance Typeable1 Pat instance Data i => Data (Pat i) \end{code} diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 7c84778..b1c97cd 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -19,6 +19,7 @@ import HscTypes import BasicTypes import Demand import Annotations +import CoreSyn import IfaceSyn import Module import Name @@ -1145,7 +1146,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 = putByte bh 2 + put_ bh (IfDFunId n) = do { putByte bh 2; put_ bh n } get bh = do h <- getByte bh case h of @@ -1153,7 +1154,7 @@ instance Binary IfaceIdDetails where 1 -> do a <- get bh b <- get bh return (IfRecSelId a b) - _ -> return IfDFunId + _ -> do { n <- get bh; return (IfDFunId n) } instance Binary IfaceIdInfo where put_ bh NoInfo = putByte bh 0 @@ -1245,6 +1246,16 @@ instance Binary IfaceUnfolding where _ -> do e <- get bh return (IfCompulsory e) +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) } } + instance Binary IfaceNote where put_ bh (IfaceSCC aa) = do putByte bh 0 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index f86f4b9..c06137c 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -27,7 +27,8 @@ module IfaceSyn ( #include "HsVersions.h" import IfaceType - +import CoreSyn( DFunArg, dfunArgExprs ) +import PprCore() -- Printing DFunArgs import Demand import Annotations import Class @@ -183,7 +184,7 @@ type IfaceAnnTarget = AnnTarget OccName data IfaceIdDetails = IfVanillaId | IfRecSelId IfaceTyCon Bool - | IfDFunId + | IfDFunId Int -- Number of silent args data IfaceIdInfo = NoInfo -- When writing interface file without -O @@ -226,7 +227,7 @@ data IfaceUnfolding | IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in -- another module. - | IfDFunUnfold [IfaceExpr] + | IfDFunUnfold [DFunArg IfaceExpr] -------------------------------- data IfaceExpr @@ -675,7 +676,7 @@ instance Outputable IfaceIdDetails where ppr IfVanillaId = empty ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc <+> if b then ptext (sLit "") else empty - ppr IfDFunId = ptext (sLit "DFunId") + ppr (IfDFunId ns) = ptext (sLit "DFunId") <> brackets (int ns) instance Outputable IfaceIdInfo where ppr NoInfo = empty @@ -699,8 +700,7 @@ instance Outputable IfaceUnfolding where ppr (IfExtWrapper a wkr) = ptext (sLit "Worker(ext0:") <+> ppr wkr <+> parens (ptext (sLit "arity") <+> int a) ppr (IfDFunUnfold ns) = ptext (sLit "DFun:") - <+> brackets (pprWithCommas pprParendIfaceExpr ns) - + <+> brackets (pprWithCommas ppr ns) -- ----------------------------------------------------------------------------- -- Finding the Names in IfaceSyn @@ -822,7 +822,7 @@ freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e freeNamesIfUnfold (IfExtWrapper _ v) = unitNameSet v freeNamesIfUnfold (IfLclWrapper {}) = emptyNameSet -freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr vs +freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr (dfunArgExprs vs) freeNamesIfExpr :: IfaceExpr -> NameSet freeNamesIfExpr (IfaceExt v) = unitNameSet v @@ -858,7 +858,6 @@ freeNamesIfExpr (IfaceLet (IfaceRec as) x) freeNamesIfExpr _ = emptyNameSet - freeNamesIfTc :: IfaceTyCon -> NameSet freeNamesIfTc (IfaceTc tc) = unitNameSet tc -- ToDo: shouldn't we include IfaceIntTc & co.? diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 98a606e..f8d66d5 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1471,7 +1471,7 @@ toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) -------------------------- toIfaceIdDetails :: IdDetails -> IfaceIdDetails toIfaceIdDetails VanillaId = IfVanillaId -toIfaceIdDetails (DFunId {}) = IfDFunId +toIfaceIdDetails (DFunId ns _) = IfDFunId ns toIfaceIdDetails (RecSelId { sel_naughty = n , sel_tycon = tc }) = IfRecSelId (toIfaceTyCon tc) n toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) @@ -1536,7 +1536,7 @@ toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity if_rhs = toIfaceExpr rhs toIfUnfolding lb (DFunUnfolding _ar _con ops) - = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops))) + = Just (HsUnfold lb (IfDFunUnfold (map (fmap 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 8fff412..c880a8a 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -986,8 +986,8 @@ do_one (IfaceRec pairs) thing_inside \begin{code} tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails tcIdDetails _ IfVanillaId = return VanillaId -tcIdDetails ty IfDFunId - = return (DFunId (isNewTyCon (classTyCon cls))) +tcIdDetails ty (IfDFunId ns) + = return (DFunId ns (isNewTyCon (classTyCon cls))) where (_, cls, _) = tcSplitDFunTy ty @@ -1051,12 +1051,15 @@ tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr) } tcUnfolding name dfun_ty _ (IfDFunUnfold ops) - = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops + = do { mb_ops1 <- forkM_maybe doc $ mapM tc_arg ops ; return (case mb_ops1 of Nothing -> noUnfolding Just ops1 -> mkDFunUnfolding dfun_ty ops1) } where 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) diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 4ab553d..98fbeb3 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -712,7 +712,7 @@ addExternal expose_all id = (new_needed_ids, show_unfold) 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) + DFunUnfolding _ _ ops -> Just (exprsFvsInOrder (dfunArgExprs ops)) _ -> Nothing where unf_ext_ids (InlineWrapper v) _ = (unitVarSet v, [v]) diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 59c8ae4..7222703 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -702,7 +702,7 @@ simplUnfolding :: SimplEnv-> TopLevelFlag simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops) = return (DFunUnfolding ar con ops') where - ops' = map (substExpr (text "simplUnfolding") env) ops + ops' = map (fmap (substExpr (text "simplUnfolding") env)) ops simplUnfolding env top_lvl id _ _ (CoreUnfolding { uf_tmpl = expr, uf_arity = arity diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index e1f3fb7..1496ec5 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -404,10 +404,18 @@ addLocalInst home_ie ispec -- This is important because the template variables must -- not overlap with anything in the things being looked up -- (since we do unification). - -- We use tcInstSkolType because we don't want to allocate fresh - -- *meta* type variables. + -- + -- We use tcInstSkolType because we don't want to allocate fresh + -- *meta* type variables. + -- + -- We use UnkSkol --- and *not* InstSkol or PatSkol --- because + -- these variables must be bindable by tcUnifyTys. See + -- the call to tcUnifyTys in InstEnv, and the special + -- treatment that instanceBindFun gives to isOverlappableTyVar + -- This is absurdly delicate. + let dfun = instanceDFunId ispec - ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun) + ; (tvs', theta', tau') <- tcInstSkolType UnkSkol (idType dfun) ; let (cls, tys') = tcSplitDFunHead tau' dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau') ispec' = setInstanceDFunId ispec dfun' diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 839a5a2..542ce20 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -229,45 +229,35 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info) tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict] - Nothing dm_id_w_inline local_dm_id dm_sig_fn IsDefaultMethod meth_bind } --------------- tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar] - -> Maybe EvBind -> Id -> Id -> SigFun -> TcSpecPrags -> LHsBind Name -> TcM (LHsBind Id) tcInstanceMethodBody skol_info tyvars dfun_ev_vars - this_dict meth_id local_meth_id + meth_id local_meth_id meth_sig_fn specs (L loc bind) = do { -- Typecheck the binding, first extending the envt -- so that when tcInstSig looks up the local_meth_id to find -- its signature, we'll find it in the environment - let full_given = case this_dict of - Nothing -> dfun_ev_vars - Just (EvBind dict _) -> dict : dfun_ev_vars - lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) }) - -- Substitue the local_meth_name for the binder + let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) }) + -- Substitute the local_meth_name for the binder -- NB: the binding is always a FunBind ; (ev_binds, (tc_bind, _)) - <- checkConstraints skol_info tyvars full_given $ + <- checkConstraints skol_info tyvars dfun_ev_vars $ tcExtendIdEnv [local_meth_id] $ tcPolyBinds TopLevel meth_sig_fn no_prag_fn NonRecursive NonRecursive [lm_bind] - -- Add the binding for this_dict, if we have one - ; ev_binds' <- case this_dict of - Nothing -> return ev_binds - Just (EvBind self rhs) -> extendTcEvBinds ev_binds self rhs - - ; let full_bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars + ; let full_bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars , abs_exports = [(tyvars, meth_id, local_meth_id, specs)] - , abs_ev_binds = ev_binds' + , abs_ev_binds = ev_binds , abs_binds = tc_bind } ; return (L loc full_bind) } @@ -538,7 +528,7 @@ mkGenericInstance clas (hs_ty, binds) = do let inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars] dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty] - ispec = mkLocalInstance dfun_id overlap_flag + ispec = mkLocalInstance dfun_id overlap_flag return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] False }) \end{code} diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 30e57ff..4d1d448 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -373,14 +373,14 @@ renameDeriv is_boot gen_binds insts , mkFVs (map dataConName (tyConDataCons tc))) -- See Note [Newtype deriving and unused constructors] - rn_inst_info (InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs standalone_deriv }) + rn_inst_info inst_info@(InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs standalone_deriv }) = -- Bring the right type variables into -- scope (yuk), and rename the method binds ASSERT( null sigs ) bindLocalNames (map Var.varName tyvars) $ do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds ; let binds' = VanillaInst rn_binds [] standalone_deriv - ; return (InstInfo { iSpec = inst, iBinds = binds' }, fvs) } + ; return (inst_info { iBinds = binds' }, fvs) } where (tyvars,_, clas,_) = instanceHead inst clas_nm = className clas @@ -467,12 +467,13 @@ deriveStandalone (L loc (DerivDecl deriv_ty)) = setSrcSpan loc $ addErrCtxt (standaloneCtxt deriv_ty) $ do { traceTc "Standalone deriving decl for" (ppr deriv_ty) - ; (tvs, theta, tau) <- tcHsInstHead deriv_ty + ; (tvs, theta, cls, inst_tys) <- tcHsInstHead deriv_ty ; traceTc "Standalone deriving;" $ vcat [ text "tvs:" <+> ppr tvs , text "theta:" <+> ppr theta - , text "tau:" <+> ppr tau ] - ; (cls, inst_tys) <- checkValidInstance deriv_ty tvs theta tau + , text "cls:" <+> ppr cls + , text "tys:" <+> ppr inst_tys ] + ; checkValidInstance deriv_ty tvs theta cls inst_tys -- C.f. TcInstDcls.tcLocalInstDecl1 ; let cls_tys = take (length inst_tys - 1) inst_tys @@ -1400,26 +1401,26 @@ the renamer. What a great hack! genInst :: Bool -- True <=> standalone deriving -> OverlapFlag -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds) -genInst standalone_deriv oflag spec - | ds_newtype spec - = return (InstInfo { iSpec = mkInstance oflag (ds_theta spec) spec - , iBinds = NewTypeDerived co rep_tycon }, []) +genInst standalone_deriv oflag + spec@(DS { ds_tc = rep_tycon, ds_tc_args = rep_tc_args + , ds_theta = theta, ds_newtype = is_newtype + , ds_name = name, ds_cls = clas }) + | is_newtype + = return (InstInfo { iSpec = inst_spec + , iBinds = NewTypeDerived co rep_tycon }, []) | otherwise - = do { let loc = getSrcSpan (ds_name spec) - inst = mkInstance oflag (ds_theta spec) spec - clas = ds_cls spec - - -- In case of a family instance, we need to use the representation - -- tycon (after all, it has the data constructors) - ; fix_env <- getFixityEnv - ; let (meth_binds, aux_binds) = genDerivBinds loc fix_env clas rep_tycon - binds = VanillaInst meth_binds [] standalone_deriv - ; return (InstInfo { iSpec = inst, iBinds = binds }, aux_binds) - } + = do { fix_env <- getFixityEnv + ; let loc = getSrcSpan name + (meth_binds, aux_binds) = genDerivBinds loc fix_env clas rep_tycon + -- In case of a family instance, we need to use the representation + -- tycon (after all, it has the data constructors) + + ; return (InstInfo { iSpec = inst_spec + , iBinds = VanillaInst meth_binds [] standalone_deriv } + , aux_binds) } where - rep_tycon = ds_tc spec - rep_tc_args = ds_tc_args spec + inst_spec = mkInstance oflag theta spec co1 = case tyConFamilyCoercion_maybe rep_tycon of Just co_con -> ACo (mkTyConApp co_con rep_tc_args) Nothing -> id_co diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index b69163c..4b5730b 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -606,8 +606,8 @@ as well as explicit user written ones. \begin{code} data InstInfo a = InstInfo { - iSpec :: Instance, -- Includes the dfun id. Its forall'd type - iBinds :: InstBindings a -- variables scope over the stuff in InstBindings! + iSpec :: Instance, -- Includes the dfun id. Its forall'd type + iBinds :: InstBindings a -- variables scope over the stuff in InstBindings! } iDFunId :: InstInfo a -> DFunId diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 873af73..c040473 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -343,11 +343,9 @@ getUserGivens (CEC {cec_encl = ctxt}) where givens = foldl (\gs ic -> ic_given ic ++ gs) [] ctxt user_givens | opt_PprStyle_Debug = givens - | otherwise = filterOut isSelfDict givens - -- In user mode, don't show the "self-dict" given - -- which is only added to do co-inductive solving - -- Rather an awkward hack, but there we are - -- This is the only use of isSelfDict, so it's not in an inner loop + | otherwise = filterOut isSilentEvVar givens + -- In user mode, don't show the "silent" givens, used for + -- the "self" dictionary and silent superclass arguments for dfuns \end{code} @@ -595,10 +593,13 @@ reportDictErrs ctxt wanteds orig <+> ptext (sLit "to the context of") , nest 2 $ pprErrCtxtLoc ctxt ] - fixes2 | null instance_dicts = [] - | otherwise = [sep [ptext (sLit "add an instance declaration for"), - pprTheta instance_dicts]] - instance_dicts = filterOut isTyVarClassPred wanteds + fixes2 = case instance_dicts of + [] -> [] + [_] -> [sep [ptext (sLit "add an instance declaration for"), + pprTheta instance_dicts]] + _ -> [sep [ptext (sLit "add instance declarations for"), + pprTheta instance_dicts]] + instance_dicts = filterOut isTyVarClassPred wanteds -- Insts for which it is worth suggesting an adding an -- instance declaration. Exclude tyvar dicts. diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 5367f8f..6b4449a 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -1033,10 +1033,10 @@ zonkEvTerm env (EvCast v co) = ASSERT( isId v) do { co' <- zonkTcTypeToType env co ; return (EvCast (zonkIdOcc env v) co') } zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n) -zonkEvTerm env (EvDFunApp df tys tms _deps) -- Ignore the dependencies +zonkEvTerm env (EvDFunApp df tys tms) = do { tys' <- zonkTcTypeToTypes env tys ; let tms' = map (zonkEvVarOcc env) tms - ; return (EvDFunApp (zonkIdOcc env df) tys' tms' _deps) } + ; return (EvDFunApp (zonkIdOcc env df) tys' tms') } zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds) zonkTcEvBinds env (TcEvBinds var) = do { (env', bs') <- zonkEvBindsVar env var diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 50cc4d6..43e58be 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -155,29 +155,36 @@ tcHsSigTypeNC ctxt hs_ty ; checkValidType ctxt ty ; return ty } -tcHsInstHead :: LHsType Name -> TcM ([TyVar], ThetaType, Type) +tcHsInstHead :: LHsType Name -> TcM ([TyVar], ThetaType, Class, [Type]) -- Typecheck an instance head. We can't use -- tcHsSigType, because it's not a valid user type. -tcHsInstHead (L loc ty) +tcHsInstHead (L loc hs_ty) = setSrcSpan loc $ -- No need for an "In the type..." context - tc_inst_head ty -- because that comes from the caller + -- because that comes from the caller + do { kinded_ty <- kc_inst_head hs_ty + ; ds_inst_head kinded_ty } where - -- tc_inst_head expects HsPredTy, which isn't usually even allowed - tc_inst_head (HsPredTy pred) - = do { pred' <- kcHsPred pred - ; pred'' <- dsHsPred pred' - ; return ([], [], mkPredTy pred'') } - - tc_inst_head (HsForAllTy _ tvs ctxt (L _ (HsPredTy pred))) - = kcHsTyVars tvs $ \ tvs' -> - do { ctxt' <- kcHsContext ctxt - ; pred' <- kcHsPred pred - ; tcTyVarBndrs tvs' $ \ tvs'' -> - do { ctxt'' <- mapM dsHsLPred (unLoc ctxt') - ; pred'' <- dsHsPred pred' - ; return (tvs'', ctxt'', mkPredTy pred'') } } - - tc_inst_head _ = failWithTc (ptext (sLit "Malformed instance type")) + kc_inst_head ty@(HsPredTy pred@(HsClassP {})) + = do { (pred', kind) <- kc_pred pred + ; checkExpectedKind ty kind ekLifted + ; return (HsPredTy pred') } + kc_inst_head (HsForAllTy exp tv_names context (L loc ty)) + = kcHsTyVars tv_names $ \ tv_names' -> + do { ctxt' <- kcHsContext context + ; ty' <- kc_inst_head ty + ; return (HsForAllTy exp tv_names' ctxt' (L loc ty')) } + kc_inst_head _ = failWithTc (ptext (sLit "Malformed instance type")) + + ds_inst_head (HsPredTy (HsClassP cls_name tys)) + = do { clas <- tcLookupClass cls_name + ; arg_tys <- dsHsTypes tys + ; return ([], [], clas, arg_tys) } + ds_inst_head (HsForAllTy _ tvs ctxt (L _ tau)) + = tcTyVarBndrs tvs $ \ tvs' -> + do { ctxt' <- mapM dsHsLPred (unLoc ctxt) + ; (tvs_r, ctxt_r, cls, tys) <- ds_inst_head tau + ; return (tvs' ++ tvs_r, ctxt' ++ ctxt_r , cls, tys) } + ds_inst_head _ = panic "ds_inst_head" tcHsQuantifiedType :: [LHsTyVarBndr Name] -> LHsType Name -> TcM ([TyVar], Type) -- Behave very like type-checking (HsForAllTy sig_tvs hs_ty), @@ -491,9 +498,9 @@ kcHsLPred :: LHsPred Name -> TcM (LHsPred Name) kcHsLPred = wrapLocM kcHsPred kcHsPred :: HsPred Name -> TcM (HsPred Name) -kcHsPred pred = do -- Checks that the result is of kind liftedType +kcHsPred pred = do -- Checks that the result is a type kind (pred', kind) <- kc_pred pred - checkExpectedKind pred kind ekLifted + checkExpectedKind pred kind ekOpen return pred' --------------------------- @@ -502,21 +509,16 @@ kc_pred :: HsPred Name -> TcM (HsPred Name, TcKind) -- application (reason: used from TcDeriv) kc_pred (HsIParam name ty) = do { (ty', kind) <- kc_lhs_type ty - ; return (HsIParam name ty', kind) - } + ; return (HsIParam name ty', kind) } kc_pred (HsClassP cls tys) = do { kind <- kcClass cls ; (tys', res_kind) <- kcApps cls kind tys - ; return (HsClassP cls tys', res_kind) - } + ; return (HsClassP cls tys', res_kind) } kc_pred (HsEqualP ty1 ty2) = do { (ty1', kind1) <- kc_lhs_type ty1 --- ; checkExpectedKind ty1 kind1 liftedTypeKind ; (ty2', kind2) <- kc_lhs_type ty2 --- ; checkExpectedKind ty2 kind2 liftedTypeKind ; checkExpectedKind ty2 kind2 (EK kind1 EkEqPred) - ; return (HsEqualP ty1' ty2', liftedTypeKind) - } + ; return (HsEqualP ty1' ty2', unliftedTypeKind) } --------------------------- kcTyVar :: Name -> TcM TcKind diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 801992c..16ae641 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -13,6 +13,7 @@ import TcBinds import TcTyClsDecls import TcClassDcl import TcPat( addInlinePrags ) +import TcSimplify( simplifyTop ) import TcRnMonad import TcMType import TcType @@ -24,7 +25,6 @@ import MkCore ( nO_METHOD_BINDING_ERROR_ID ) import TcDeriv import TcEnv import RnSource ( addTcgDUs ) -import TcSimplify( simplifySuperClass ) import TcHsType import TcUnify import Type @@ -33,9 +33,10 @@ import TyCon import DataCon import Class import Var +import VarSet import CoreUtils ( mkPiTypes ) import CoreUnfold ( mkDFunUnfolding ) -import CoreSyn ( Expr(Var) ) +import CoreSyn ( Expr(Var), DFunArg(..), CoreExpr ) import Id import MkId import Name @@ -272,13 +273,12 @@ See the overlapping instances for RegexContext, and the fact that they call 'nullFail' just like the example above. The DoCon package also does the same thing; it shows up in module Fraction.hs -Conclusion: when typechecking the methods in a C [a] instance, we want -to have C [a] available. That is why we have the strange local -definition for 'this' in the definition of op1_i in the example above. -We can typecheck the defintion of local_op1, and when doing tcSimplifyCheck -we supply 'this' as a given dictionary. Only needed, though, if there -are some type variables involved; otherwise there can be no overlap and -none of this arises. +Conclusion: when typechecking the methods in a C [a] instance, we want to +treat the 'a' as an *existential* type variable, in the sense described +by Note [Binding when looking up instances]. That is why isOverlappableTyVar +responds True to an InstSkol, which is the kind of skolem we use in +tcInstDecl2. + Note [Tricky type variable scoping] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -397,10 +397,8 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags)) badBootDeclErr - ; (tyvars, theta, tau) <- tcHsInstHead poly_ty - - -- Now, check the validity of the instance. - ; (clas, inst_tys) <- checkValidInstance poly_ty tyvars theta tau + ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead poly_ty + ; checkValidInstance poly_ty tyvars theta clas inst_tys -- Next, process any associated types. ; idx_tycons <- recoverM (return []) $ @@ -420,8 +418,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys ispec = mkLocalInstance dfun overlap_flag - ; return (InstInfo { iSpec = ispec, - iBinds = VanillaInst binds uprags False }, + ; return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False }, idx_tycons) } where @@ -561,16 +558,6 @@ tcInstDecls2 tycl_decls inst_decls -- Done ; return (dm_binds `unionBags` unionManyBags inst_binds_s) } - -tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id) -tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) - = recoverM (return emptyLHsBinds) $ - setSrcSpan loc $ - addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ - tc_inst_decl2 dfun_id ibinds - where - dfun_id = instanceDFunId ispec - loc = getSrcSpan dfun_id \end{code} See Note [Default methods and instances] @@ -587,70 +574,59 @@ So right here in tcInstDecl2 we must re-extend the type envt with the default method Ids replete with their INLINE pragmas. Urk. \begin{code} -tc_inst_decl2 :: Id -> InstBindings Name -> TcM (LHsBinds Id) --- Returns a binding for the dfun -tc_inst_decl2 dfun_id inst_binds - = 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 - -- These inst_tyvars' scope over the 'where' part - -- Those tyvars are inside the dfun_id's type, which is a bit - -- bizarre, but OK so long as you realise it! - ; let - (clas, inst_tys') = tcSplitDFunHead inst_head' - (class_tyvars, sc_theta, sc_sels, op_items) = classBigSig clas - - -- Instantiate the super-class context with inst_tys - sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta - - -- Create dictionary Ids from the specified instance contexts. - ; dfun_ev_vars <- newEvVars dfun_theta' - ; self_dict <- newSelfDict clas inst_tys' - -- Default-method Ids may be mentioned in synthesised RHSs, - -- but they'll already be in the environment. - - -- Cook up a binding for "self = df d1 .. dn", - -- to use in each method binding - -- Why? See Note [Subtle interaction of recursion and overlap] - ; let self_ev_bind = EvBind self_dict $ - EvDFunApp dfun_id (mkTyVarTys inst_tyvars') dfun_ev_vars [] - -- Empty dependencies [], since it only - -- depends on "given" things + +tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id) + -- Returns a binding for the dfun +tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) + = recoverM (return emptyLHsBinds) $ + setSrcSpan loc $ + addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ + do { -- Instantiate the instance decl with skolem constants + ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolSigType skol_info (idType dfun_id) + ; let (clas, inst_tys) = tcSplitDFunHead inst_head + (class_tyvars, sc_theta, _, 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 + + ; silent_ev_vars <- mapM newSilentGiven silent_theta + ; orig_ev_vars <- newEvVars orig_theta + ; let dfun_ev_vars = silent_ev_vars ++ orig_ev_vars + + ; (sc_binds, sc_dicts, sc_args) + <- mapAndUnzip3M (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 $ + emitConstraints $ listToBag $ + [ WcEvVar (WantedEvVar sc ct_loc) + | sc <- sc_dicts, isSilentEvVar sc ] -- Deal with 'SPECIALISE instance' pragmas -- See Note [SPECIALISE instance pragmas] - ; spec_info <- tcSpecInstPrags dfun_id inst_binds + ; spec_info <- tcSpecInstPrags dfun_id ibinds -- Typecheck the methods ; (meth_ids, meth_binds) - <- tcExtendTyVarEnv inst_tyvars' $ - tcInstanceMethods dfun_id clas inst_tyvars' dfun_ev_vars - inst_tys' self_ev_bind spec_info - op_items inst_binds - - -- Figure out bindings for the superclass context - ; let tc_sc = tcSuperClass inst_tyvars' dfun_ev_vars self_ev_bind - (sc_eqs, sc_dicts) = splitAt (classSCNEqs clas) sc_theta' - ; (sc_dict_ids, sc_binds) <- ASSERT( equalLength sc_sels sc_dicts ) - ASSERT( all isEqPred sc_eqs ) - mapAndUnzipM tc_sc (sc_sels `zip` sc_dicts) - - -- NOT FINISHED! - ; (_eq_sc_binds, sc_eq_vars) <- checkConstraints InstSkol - inst_tyvars' dfun_ev_vars $ - emitWanteds ScOrigin sc_eqs + <- tcExtendTyVarEnv inst_tyvars $ + -- The inst_tyvars scope over the 'where' part + -- Those tyvars are inside the dfun_id's type, which is a bit + -- bizarre, but OK so long as you realise it! + tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars + inst_tys spec_info + op_items ibinds -- Create the result bindings + ; self_dict <- newEvVar (ClassP clas inst_tys) ; let dict_constr = classDataCon clas dict_bind = mkVarBind self_dict dict_rhs - dict_rhs = foldl mk_app inst_constr dict_and_meth_ids - dict_and_meth_ids = sc_dict_ids ++ meth_ids - inst_constr = L loc $ wrapId (mkWpEvVarApps sc_eq_vars - <.> mkWpTyApps inst_tys') - (dataConWrapId dict_constr) + 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) -- 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 @@ -658,33 +634,61 @@ tc_inst_decl2 dfun_id inst_binds -- member) are dealt with by the common MkId.mkDataConWrapId code rather -- than needing to be repeated here. - mk_app :: LHsExpr Id -> Id -> LHsExpr Id - mk_app fun arg_id = L loc (HsApp fun (L loc (wrapId arg_wrapper arg_id))) - arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars') + mk_app :: LHsExpr Id -> HsExpr Id -> LHsExpr Id + mk_app fun arg = L loc (HsApp fun (L loc arg)) + + arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars) -- Do not inline the dfun; instead give it a magic DFunFunfolding -- See Note [ClassOp/DFun selection] -- See also note [Single-method classes] dfun_id_w_fun = dfun_id - `setIdUnfolding` mkDFunUnfolding inst_ty (map Var dict_and_meth_ids) - -- Not right for equality superclasses + `setIdUnfolding` mkDFunUnfolding dfun_ty (sc_args ++ meth_args) `setInlinePragma` dfunInlinePragma + meth_args = map (DFunPolyArg . Var) meth_ids - (spec_inst_prags, _) = spec_info - main_bind = AbsBinds { abs_tvs = inst_tyvars' + main_bind = AbsBinds { abs_tvs = inst_tyvars , abs_ev_vars = dfun_ev_vars - , abs_exports = [(inst_tyvars', dfun_id_w_fun, self_dict, - SpecPrags spec_inst_prags)] + , abs_exports = [(inst_tyvars, dfun_id_w_fun, self_dict, + SpecPrags [] {- spec_inst_prags -})] , abs_ev_binds = emptyTcEvBinds , abs_binds = unitBag dict_bind } - ; return (unitBag (L loc main_bind) `unionBags` - listToBag meth_binds `unionBags` - listToBag sc_binds) + ; return (unitBag (L loc main_bind) `unionBags` + unionManyBags sc_binds `unionBags` + listToBag meth_binds) } + where + skol_info = InstSkol -- See Note [Subtle interaction of recursion and overlap] + dfun_ty = idType dfun_id + dfun_id = instanceDFunId ispec + loc = getSrcSpan dfun_id + +------------------------------ +tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (LHsBinds Id, Id, DFunArg CoreExpr) +tcSuperClass n_ty_args ev_vars pred + | Just (ev, i) <- find n_ty_args ev_vars + = return (emptyBag, ev, DFunLamArg i) + | otherwise + = ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred) + do { sc_dict <- newWantedEvVar pred + ; loc <- getCtLoc ScOrigin + ; ev_binds <- simplifyTop (unitBag (WcEvVar (WantedEvVar sc_dict loc))) + ; let ev_wrap = WpLet (EvBinds ev_binds) + sc_bind = mkVarBind sc_dict (noLoc $ (wrapId ev_wrap sc_dict)) + ; return (unitBag sc_bind, sc_dict, DFunConstArg (Var sc_dict)) } + -- It's very important to solve the superclass constraint *in isolation* + -- so that it isn't generated by superclass selection from something else + -- We then generate the (also rather degenerate) top-level binding: + -- sc_dict = let sc_dict = in sc_dict + -- where is generated by solving the implication constraint + where + find _ [] = Nothing + find i (ev:evs) | pred `tcEqPred` evVarPred ev = Just (ev, i) + | otherwise = find (i+1) evs ------------------------------ -tcSpecInstPrags :: DFunId -> InstBindings Name +tcSpecInstPrags :: DFunId -> InstBindings Name -> TcM ([Located TcSpecPrag], PragFun) tcSpecInstPrags _ (NewTypeDerived {}) = return ([], \_ -> []) @@ -693,45 +697,79 @@ tcSpecInstPrags dfun_id (VanillaInst binds uprags _) filter isSpecInstLSig uprags -- The filter removes the pragmas for methods ; return (spec_inst_prags, mkPragFun uprags binds) } - ------------------------------- -tcSuperClass :: [TyVar] -> [EvVar] - -> EvBind - -> (Id, PredType) -> TcM (Id, LHsBind Id) --- Build a top level decl like --- sc_op = /\a \d. let this = ... in --- let sc = ... in --- sc --- The "this" part is just-in-case (discarded if not used) --- See Note [Recursive superclasses] -tcSuperClass tyvars dicts - self_ev_bind - (sc_sel, sc_pred) - = do { sc_dict <- newWantedEvVar sc_pred - ; ev_binds <- simplifySuperClass tyvars dicts sc_dict self_ev_bind - - ; uniq <- newUnique - ; let sc_op_ty = mkForAllTys tyvars $ mkPiTypes dicts (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 dicts - <.> mkWpLet ev_binds - - ; return (sc_op_id, noLoc sc_op_bind) } \end{code} -Note [Recursive superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See Trac #1470 for why we would *like* to add "self_dict" to the -available instances here. But we can't do so because then the superclases -get satisfied by selection from self_dict, and that leads to an immediate -loop. What we need is to add self_dict to Avails without adding its -superclasses, and we currently have no way to do that. - +Note [Silent Superclass Arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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. + +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: + 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 + +Test case SCLoop tests this fix. + Note [SPECIALISE instance pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -779,10 +817,11 @@ tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag tcSpecInst dfun_id prag@(SpecInstSig hs_ty) = addErrCtxt (spec_ctxt prag) $ do { let name = idName dfun_id - ; (tyvars, theta, tau) <- tcHsInstHead hs_ty - ; let spec_ty = mkSigmaTy tyvars theta tau - ; co_fn <- tcSubType (SpecPragOrigin name) (SigSkol SpecInstCtxt) - (idType dfun_id) spec_ty + ; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty + ; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys + + ; co_fn <- tcSubType (SpecPragOrigin name) (SigSkol SpecInstCtxt) + (idType dfun_id) spec_dfun_ty ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } where spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) @@ -808,15 +847,14 @@ tcInstanceMethod tcInstanceMethods :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType] - -> EvBind -- "This" and its binding - -> ([Located TcSpecPrag], PragFun) + -> ([Located TcSpecPrag], PragFun) -> [(Id, DefMeth)] -> InstBindings Name -> TcM ([Id], [LHsBind Id]) -- The returned inst_meth_ids all have types starting -- forall tvs. theta => ... tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys - self_dict_ev (spec_inst_prags, prag_fn) + (spec_inst_prags, prag_fn) op_items (VanillaInst binds _ standalone_deriv) = mapAndUnzipM tc_item op_items where @@ -837,7 +875,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ; meth_id1 <- addInlinePrags meth_id prags ; spec_prags <- tcSpecPrags meth_id1 prags ; bind <- tcInstanceMethodBody InstSkol - tyvars dfun_ev_vars mb_dict_ev + tyvars dfun_ev_vars meth_id1 local_meth_id meth_sig_fn (mk_meth_spec_prags meth_id1 spec_prags) rn_bind @@ -867,22 +905,25 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys = do { -- Build the typechecked version directly, -- without calling typecheck_method; -- see Note [Default methods in instances] - -- Generate /\as.\ds. let this = df as ds - -- in $dm inst_tys this + -- Generate /\as.\ds. let self = df as ds + -- in $dm inst_tys self -- The 'let' is necessary only because HsSyn doesn't allow -- you to apply a function to a dictionary *expression*. + ; self_dict <- newEvVar (ClassP clas inst_tys) + ; let self_ev_bind = EvBind self_dict $ + EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars + ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id ; dm_id <- tcLookupId dm_name ; let dm_inline_prag = idInlinePragma dm_id - EvBind self_dict _ = self_dict_ev rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $ HsVar dm_id meth_bind = L loc $ VarBind { var_id = local_meth_id , var_rhs = L loc rhs - , var_inline = False } + , var_inline = False } meth_id1 = meth_id `setInlinePragma` dm_inline_prag -- Copy the inline pragma (if any) from the default -- method to this version. Note [INLINE and default methods] @@ -890,7 +931,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars , abs_exports = [( tyvars, meth_id1, local_meth_id , mk_meth_spec_prags meth_id1 [])] - , abs_ev_binds = EvBinds (unitBag self_dict_ev) + , abs_ev_binds = EvBinds (unitBag self_ev_bind) , abs_binds = unitBag meth_bind } -- Default methods in an instance declaration can't have their own -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but @@ -921,13 +962,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys -- instance C [c] where { op = } -- In , 'c' is scope but 'b' is not! - mb_dict_ev = if null tyvars then Nothing else Just self_dict_ev - -- Only need the self_dict stuff if there are type - -- variables involved; otherwise overlap is not possible - -- See Note [Subtle interaction of recursion and overlap] - -- in TcInstDcls - - -- For instance decls that come from standalone deriving clauses + -- For instance decls that come from standalone deriving clauses -- we want to print out the full source code if there's an error -- because otherwise the user won't see the code at all add_meth_ctxt sel_id generated_code rn_bind thing @@ -936,7 +971,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys - _ _ op_items (NewTypeDerived coi _) + _ op_items (NewTypeDerived coi _) -- Running example: -- class Show b => Foo a b where diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index bc0aae0..30b1ae1 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -1963,12 +1963,11 @@ matchClassInst clas tys loc ; tys <- instDFunTypes mb_inst_tys ; let (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys) ; if null theta then - return (GenInst [] (EvDFunApp dfun_id tys [] [])) + return (GenInst [] (EvDFunApp dfun_id tys [])) else do { ev_vars <- instDFunConstraints theta ; let wevs = [WantedEvVar w loc | w <- ev_vars] - ; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars ev_vars) } - -- NB: All the dependencies are ev_vars + ; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars) } } } \end{code} diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 02eba6d..ef4ad34 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -26,7 +26,7 @@ module TcMType ( -- Creating new evidence variables newEvVar, newCoVar, newEvVars, newWantedCoVar, writeWantedCoVar, readWantedCoVar, - newIP, newDict, newSelfDict, isSelfDict, + newIP, newDict, newSilentGiven, isSilentEvVar, newWantedEvVar, newWantedEvVars, newTcEvBinds, addTcEvBind, @@ -42,8 +42,8 @@ module TcMType ( -- Checking type validity Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, SourceTyCtxt(..), checkValidTheta, - checkValidInstHead, checkValidInstance, - checkInstTermination, checkValidTypeInst, checkTyFamFreeness, + checkValidInstance, + checkValidTypeInst, checkTyFamFreeness, arityErr, growPredTyVars, growThetaTyVars, validDerivPred, @@ -163,20 +163,23 @@ newName occ ; return (mkInternalName uniq occ loc) } ----------------- -newSelfDict :: Class -> [TcType] -> TcM DictId --- Make a dictionary for "self". It behaves just like a normal DictId --- except that it responds True to isSelfDict +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 -newSelfDict cls tys +newSilentGiven (ClassP cls tys) = do { uniq <- newUnique - ; let name = mkSystemName uniq selfDictOcc + ; 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 -selfDictOcc :: OccName -selfDictOcc = mkVarOcc "self" - -isSelfDict :: EvVar -> Bool -isSelfDict v = isSystemName (Var.varName v) +isSilentEvVar :: EvVar -> Bool +isSilentEvVar v = isSystemName (Var.varName v) -- Notice that all *other* evidence variables get Internal Names \end{code} @@ -1339,34 +1342,20 @@ compiled elsewhere). In these cases, we let them go through anyway. We can also have instances for functions: @instance Foo (a -> b) ...@. \begin{code} -checkValidInstHead :: Type -> TcM (Class, [TcType]) - -checkValidInstHead ty -- Should be a source type - = case tcSplitPredTy_maybe ty of { - Nothing -> failWithTc (instTypeErr (ppr ty) empty) ; - Just pred -> - - case getClassPredTys_maybe pred of { - Nothing -> failWithTc (instTypeErr (pprPred pred) empty) ; - Just (clas,tys) -> do +checkValidInstHead :: Class -> [Type] -> TcM () +checkValidInstHead clas tys + = do { dflags <- getDOpts - dflags <- getDOpts - check_inst_head dflags clas tys - return (clas, tys) - }} - -check_inst_head :: DynFlags -> Class -> [Type] -> TcM () -check_inst_head dflags clas tys - = do { -- If GlasgowExts then check at least one isn't a type variable + -- If GlasgowExts then check at least one isn't a type variable ; checkTc (xopt Opt_TypeSynonymInstances dflags || all tcInstHeadTyNotSynonym tys) - (instTypeErr (pprClassPred clas tys) head_type_synonym_msg) + (instTypeErr pp_pred head_type_synonym_msg) ; checkTc (xopt Opt_FlexibleInstances dflags || all tcInstHeadTyAppAllTyVars tys) - (instTypeErr (pprClassPred clas tys) head_type_args_tyvars_msg) + (instTypeErr pp_pred head_type_args_tyvars_msg) ; checkTc (xopt Opt_MultiParamTypeClasses dflags || isSingleton tys) - (instTypeErr (pprClassPred clas tys) head_one_type_msg) + (instTypeErr pp_pred head_one_type_msg) -- May not contain type family applications ; mapM_ checkTyFamFreeness tys @@ -1379,6 +1368,7 @@ check_inst_head dflags clas tys } where + pp_pred = pprClassPred clas tys head_type_synonym_msg = parens ( text "All instance types must be of the form (T t1 ... tn)" $$ text "where T is not a synonym." $$ @@ -1386,7 +1376,7 @@ check_inst_head dflags clas tys head_type_args_tyvars_msg = parens (vcat [ text "All instance types must be of the form (T a1 ... an)", - text "where a1 ... an are type *variables*,", + text "where a1 ... an are *distinct type variables*,", text "and each type variable appears at most once in the instance head.", text "Use -XFlexibleInstances if you want to disable this."]) @@ -1408,35 +1398,30 @@ instTypeErr pp_ty msg %************************************************************************ \begin{code} -checkValidInstance :: LHsType Name -> [TyVar] -> ThetaType -> Type - -> TcM (Class, [TcType]) -checkValidInstance hs_type tyvars theta tau +checkValidInstance :: LHsType Name -> [TyVar] -> ThetaType + -> Class -> [TcType] -> TcM () +checkValidInstance hs_type tyvars theta clas inst_tys = setSrcSpan (getLoc hs_type) $ - do { (clas, inst_tys) <- setSrcSpan head_loc $ - checkValidInstHead tau - - ; undecidable_ok <- xoptM Opt_UndecidableInstances - - ; checkValidTheta InstThetaCtxt theta + do { setSrcSpan head_loc (checkValidInstHead clas inst_tys) + ; checkValidTheta InstThetaCtxt theta ; checkAmbiguity tyvars theta (tyVarsOfTypes inst_tys) -- Check that instance inference will terminate (if we care) -- For Haskell 98 this will already have been done by checkValidTheta, -- but as we may be using other extensions we need to check. - ; unless undecidable_ok $ + ; undecidable_ok <- xoptM Opt_UndecidableInstances + ; unless undecidable_ok $ mapM_ addErrTc (checkInstTermination inst_tys theta) -- The Coverage Condition ; checkTc (undecidable_ok || checkInstCoverage clas inst_tys) (instTypeErr (pprClassPred clas inst_tys) msg) - - ; return (clas, inst_tys) - } + } where msg = parens (vcat [ptext (sLit "the Coverage Condition fails for one of the functional dependencies;"), undecidableMsg]) - -- The location of the "head" of the instance + -- The location of the "head" of the instance head_loc = case hs_type of L _ (HsForAllTy _ _ _ (L loc _)) -> loc L loc _ -> loc diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index edeb5cb..1e99876 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -901,10 +901,8 @@ isGoodRecEv ev_var wv chase_ev assocs trg curr_grav visited (EvCoercion co) = chase_co assocs trg curr_grav visited co - chase_ev assocs trg curr_grav visited (EvDFunApp _ _ _ev_vars ev_deps) + chase_ev assocs trg curr_grav visited (EvDFunApp _ _ ev_deps) = do { chase_results <- mapM (chase_ev_var assocs trg (curr_grav+1) visited) ev_deps - -- Notice that we chase the ev_deps and not the ev_vars - -- See Note [Dependencies in self dictionaries] in TcSimplify ; return (comb_chase_res Nothing chase_results) } chase_co assocs trg curr_grav visited co @@ -937,7 +935,7 @@ matchClass :: Class -> [Type] -> TcS (MatchInstResult (DFunId, [Either TyVar TcT matchClass clas tys = do { let pred = mkClassPred clas tys ; instEnvs <- getInstEnvs - ; case lookupInstEnv instEnvs clas tys of { + ; case lookupInstEnv instEnvs clas tys of { ([], unifs) -- Nothing matches -> do { traceTcS "matchClass not matching" (vcat [ text "dict" <+> ppr pred, @@ -949,7 +947,7 @@ matchClass clas tys ; traceTcS "matchClass success" (vcat [text "dict" <+> ppr pred, text "witness" <+> ppr dfun_id - <+> ppr (idType dfun_id) ]) + <+> ppr (idType dfun_id), ppr instEnvs ]) -- Record that this dfun is needed ; return $ MatchInstSingle (dfun_id, inst_tys) } ; diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index b312d09..90048b7 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -1,6 +1,6 @@ \begin{code} module TcSimplify( - simplifyInfer, simplifySuperClass, + simplifyInfer, simplifyDefault, simplifyDeriv, simplifyBracket, simplifyRule, simplifyTop, simplifyInteractive ) where @@ -32,7 +32,6 @@ import BasicTypes ( RuleName ) import Data.List ( partition ) import Outputable import FastString -import Control.Monad ( unless ) \end{code} @@ -45,9 +44,9 @@ import Control.Monad ( unless ) \begin{code} simplifyTop :: WantedConstraints -> TcM (Bag EvBind) -- Simplify top-level constraints --- Usually these will be implications, when there is --- nothing to quanitfy we don't wrap in a degenerate implication, --- so we do that here instead +-- Usually these will be implications, +-- but when there is nothing to quantify we don't wrap +-- in a degenerate implication, so we do that here instead simplifyTop wanteds = simplifyCheck SimplCheck wanteds @@ -435,122 +434,13 @@ over implicit parameters. See the predicate isFreeWhenInferring. ********************************************************************************* * * -* Superclasses * -* * -*********************************************************************************** - -When constructing evidence for superclasses in an instance declaration, - * we MUST have the "self" dictionary available - -Moreover, we must *completely* solve the constraints right now, -not wrap them in an implication constraint to solve later. Why? -Because when that implication constraint is solved there may -be some unrelated other solved top-level constraints that -recursively depend on the superclass we are building. Consider - class Ord a => C a where - instance C [Int] where ... -Then we get - dCListInt :: C [Int] - dCListInt = MkC $cNum ... - - $cNum :: Ord [Int] -- The superclass - $cNum = let self = dCListInt in - -Now, if there is some *other* top-level constraint solved -looking like - foo :: Ord [Int] - foo = scsel dCInt -we must not solve the (Ord [Int]) wanted from foo! - -Note [Dependencies in self dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Moreover, notice that when solving for a superclass, we record the dependency of -self on the superclass. This is because this dependency is not evident in the -EvBind of the self dictionary, which only involves a call to a DFun. Example: - -class A a => C a -instance B a => C a - -When we check the instance declaration, we pass in a self dictionary that is merely - self = dfun b -But we will be asked to solve that from: - [Given] d : B a - [Derived] self : C a -We can show: - [Wanted] sc : A a -The problem is that self *depends* on the sc variable, but that is not apparent in -the binding self = dfun b. So we record the extra dependency, using the evidence bind: - EvBind self (EvDFunApp dfun [b] [b,sc]) -It is these dependencies that are the ''true'' dependencies in an EvDFunApp, and those -that we must chase in function isGoodRecEv (in TcSMonad) - -\begin{code} -simplifySuperClass :: [TyVar] - -> [EvVar] -- givens - -> EvVar -- the superclass we must solve for - -> EvBind -- the 'self' evidence bind - -> TcM TcEvBinds --- Post: --- ev_binds <- simplifySuperClasses tvs inst_givens sc_dict self_ev_bind --- Then: --- 1) ev_binds already contains self_ev_bind --- 2) if successful then ev_binds contains binding for --- the wanted superclass, sc_dict -simplifySuperClass tvs inst_givens sc_dict (EvBind self_dict self_ev) - = do { giv_loc <- getCtLoc InstSkol -- For the inst_givens - ; want_loc <- getCtLoc ScOrigin -- As wanted/derived (for the superclass and self) - ; lcl_env <- getLclTypeEnv - - -- Record the dependency of self_dict to sc_dict, see Note [Dependencies in self dictionaries] - ; let wanted = unitBag $ WcEvVar $ WantedEvVar sc_dict want_loc - self_ev_with_dep - = case self_ev of - EvDFunApp df tys insts deps -> EvDFunApp df tys insts (sc_dict:deps) - _ -> panic "Self-dictionary not EvDFunApp!" - - -- And solve for it - ; ((unsolved_flats, unsolved_implics), frozen_errors, ev_binds) - <- runTcS SimplCheck NoUntouchables $ - do { -- Record a binding for self_dict that *depends on sc_dict* - -- And canonicalise self_dict (which adds its superclasses) - -- with a Derived origin, which in turn triggers the - -- goodRecEv recursive-evidence check - ; setEvBind self_dict self_ev_with_dep - -- The rest is just like solveImplication - ; let cts = mapBag (\d -> (Given giv_loc, d)) (listToBag inst_givens) - `snocBag` (Derived want_loc DerSelf, self_dict) - ; inert <- solveInteract emptyInert cts - - ; solveWanteds inert wanted } - - -- For error reporting, conjure up a fake implication, - -- so that we get decent error messages - ; let implic = Implic { ic_untch = NoUntouchables - , ic_env = lcl_env - , ic_skols = mkVarSet tvs - , ic_given = inst_givens - , ic_wanted = mapBag WcEvVar unsolved_flats - , ic_scoped = panic "super1" - , ic_binds = panic "super2" - , ic_loc = giv_loc } - ; ASSERT (isEmptyBag unsolved_implics) -- Impossible to have any implications! - unless (isEmptyBag unsolved_flats) $ - reportUnsolved (emptyBag, unitBag implic) frozen_errors - - ; return (EvBinds ev_binds) } -\end{code} - - -********************************************************************************* -* * * RULES * * * *********************************************************************************** Note [Simplifying RULE lhs constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -On the LHS of transformation rules we only simplify only equalitis, +On the LHS of transformation rules we only simplify only equalities, but not dictionaries. We want to keep dictionaries unsimplified, to serve as the available stuff for the RHS of the rule. We *do* want to simplify equalities, however, to detect ill-typed rules that cannot be diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index b2da9f0..89aba65 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -28,7 +28,7 @@ module TcType ( MetaDetails(Flexi, Indirect), MetaInfo(..), SkolemInfo(..), pprSkolTvBinding, pprSkolInfo, isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, - isSigTyVar, isExistentialTyVar, isTyConableTyVar, + isSigTyVar, isOverlappableTyVar, isTyConableTyVar, metaTvRef, isFlexi, isIndirect, isUnkSkol, isRuntimeUnkSkol, @@ -614,7 +614,7 @@ isImmutableTyVar tv | isTcTyVar tv = isSkolemTyVar tv | otherwise = True -isTyConableTyVar, isSkolemTyVar, isExistentialTyVar, +isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar, isMetaTyVar :: TcTyVar -> Bool isTyConableTyVar tv @@ -633,11 +633,14 @@ isSkolemTyVar tv FlatSkol {} -> True MetaTv {} -> False -isExistentialTyVar tv -- Existential type variable, bound by a pattern +-- isOverlappableTyVar has a unique purpose. +-- See Note [Binding when looking up instances] in InstEnv. +isOverlappableTyVar tv = ASSERT( isTcTyVar tv ) case tcTyVarDetails tv of - SkolemTv (PatSkol {}) -> True - _ -> False + SkolemTv (PatSkol {}) -> True + SkolemTv (InstSkol {}) -> True + _ -> False isMetaTyVar tv = ASSERT2( isTcTyVar tv, ppr tv ) diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index ade2db0..6738b0c 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -402,14 +402,11 @@ checkConstraints skol_info skol_tvs given thing_inside -- tcPolyExpr, which uses tcGen and hence checkConstraints. | otherwise - = do { (ev_binds, wanted, result) <- newImplication skol_info - skol_tvs given thing_inside - ; emitConstraints wanted - ; return (ev_binds, result) } + = newImplication skol_info skol_tvs given thing_inside newImplication :: SkolemInfo -> [TcTyVar] -> [EvVar] -> TcM result - -> TcM (TcEvBinds, WantedConstraints, result) + -> TcM (TcEvBinds, result) newImplication skol_info skol_tvs given thing_inside = ASSERT2( all isTcTyVar skol_tvs, ppr skol_tvs ) ASSERT2( all isSkolemTyVar skol_tvs, ppr skol_tvs ) @@ -424,7 +421,7 @@ newImplication skol_info skol_tvs given thing_inside -- we don't want to lose the "inaccessible alternative" -- error check then - return (emptyTcEvBinds, emptyWanteds, result) + return (emptyTcEvBinds, result) else do { ev_binds_var <- newTcEvBinds ; lcl_env <- getLclTypeEnv @@ -438,7 +435,8 @@ newImplication skol_info skol_tvs given thing_inside , ic_binds = ev_binds_var , ic_loc = loc } - ; return (TcEvBinds ev_binds_var, unitBag (WcImplic implic), result) } } + ; emitConstraint (WcImplic implic) + ; return (TcEvBinds ev_binds_var, result) } } \end{code} %************************************************************************ diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 7327992..2d6a9eb 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -151,10 +151,15 @@ pprInstance ispec pprInstanceHdr :: Instance -> SDoc -- Prints the Instance as an instance declaration pprInstanceHdr ispec@(Instance { is_flag = flag }) - = ptext (sLit "instance") <+> ppr flag - <+> sep [pprThetaArrow theta, ppr res_ty] + = getPprStyle $ \ sty -> + let theta_to_print + | debugStyle sty = theta + | otherwise = drop (dfunNSilent dfun) theta + in ptext (sLit "instance") <+> ppr flag + <+> sep [pprThetaArrow theta_to_print, ppr res_ty] where - (_, theta, res_ty) = tcSplitSigmaTy (idType (is_dfun ispec)) + dfun = is_dfun ispec + (_, theta, res_ty) = tcSplitSigmaTy (idType dfun) -- Print without the for-all, which the programmer doesn't write pprInstances :: [Instance] -> SDoc @@ -167,12 +172,14 @@ instanceHead ispec (tvs, theta, tau) = tcSplitSigmaTy (idType (is_dfun ispec)) (cls, tys) = tcSplitDFunHead tau -mkLocalInstance :: DFunId -> OverlapFlag -> Instance +mkLocalInstance :: DFunId + -> OverlapFlag + -> Instance -- Used for local instances, where we can safely pull on the DFunId mkLocalInstance dfun oflag = Instance { is_flag = oflag, is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys, - is_cls = className cls, is_tcs = roughMatchTcs tys } + is_cls = className cls, is_tcs = roughMatchTcs tys } where (tvs, cls, tys) = tcSplitDFunTy (idType dfun) @@ -353,6 +360,9 @@ data ClsInstEnv -- If *not* then the common case of looking up -- (C a b c) can fail immediately +instance Outputable ClsInstEnv where + ppr (ClsIE is b) = ptext (sLit "ClsIE") <+> ppr b <+> pprInstances is + -- INVARIANTS: -- * The is_tvs are distinct in each Instance -- of a ClsInstEnv (so we can safely unify them) @@ -539,8 +549,8 @@ insert_overlapping new_item (item:items) \begin{code} instanceBindFun :: TyVar -> BindFlag -instanceBindFun tv | isTcTyVar tv && isExistentialTyVar tv = Skolem - | otherwise = BindMe +instanceBindFun tv | isTcTyVar tv && isOverlappableTyVar tv = Skolem + | otherwise = BindMe -- Note [Binding when looking up instances] \end{code} @@ -563,7 +573,7 @@ The op [x,x] means we need (Foo [a]). Without the filterVarSet we'd complain, saying that the choice of instance depended on the instantiation of 'a'; but of course it isn't *going* to be instantiated. -We do this only for pattern-bound skolems. For example we reject +We do this only for isOverlappableTyVar skolems. For example we reject g :: forall a => [a] -> Int g x = op x on the grounds that the correct instance depends on the instantiation of 'a' diff --git a/compiler/vectorise/Vectorise/Type/PADict.hs b/compiler/vectorise/Vectorise/Type/PADict.hs index 8af9f41..ed6264a 100644 --- a/compiler/vectorise/Vectorise/Type/PADict.hs +++ b/compiler/vectorise/Vectorise/Type/PADict.hs @@ -60,7 +60,8 @@ buildPADict vect_tc prepr_tc arr_tc repr -- Set the unfolding for the inliner. raw_dfun <- newExportedVar dfun_name dfun_ty - let dfun = raw_dfun `setIdUnfolding` mkDFunUnfolding dfun_ty (map Var method_ids) + let dfun_unf = mkDFunUnfolding dfun_ty (map (DFunPolyArg . Var) method_ids) + dfun = raw_dfun `setIdUnfolding` dfun_unf `setInlinePragma` dfunInlinePragma -- Add the new binding to the top-level environment. -- 1.7.10.4