From 1cf5c7554da206fe39eb4e4a2e37e9e1d5c8ab27 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Wed, 3 Aug 2011 16:22:06 +0100
Subject: [PATCH] Fix a grevious error in InstEnv: Trac #5095
An claimed short-cut optimisation was actually an error.
The optimisation was this: when looking up (C a b), where
'a' and 'b' are type variables, we were returning [] immediately
if the instance environment had no instances of form (C a b).
Why? Because the thing being looked up definitely won't match
(C Int Bool), say.
BUT it will *unify* with (C Int Bool) and we care very much
about things it might unify with. If we neglect them we may
silently allow incoherent instance selection, and that is
exactly what happened in #5095.
The fix is easy: remove the "optimisation".
---
compiler/types/InstEnv.lhs | 45 ++++++++++++++------------------------
1 file changed, 17 insertions(+), 28 deletions(-)
diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs
index 2789a331cc02..bfae8b359bae 100644
--- a/compiler/types/InstEnv.lhs
+++ b/compiler/types/InstEnv.lhs
@@ -350,14 +350,11 @@ or, to put it another way, we have
---------------------------------------------------
type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class
-data ClsInstEnv
+newtype ClsInstEnv
= ClsIE [Instance] -- The instances for a particular class, in any order
- Bool -- True <=> there is an instance of form C a b c
- -- 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
+ ppr (ClsIE is) = pprInstances is
-- INVARIANTS:
-- * The is_tvs are distinct in each Instance
@@ -372,26 +369,24 @@ emptyInstEnv :: InstEnv
emptyInstEnv = emptyUFM
instEnvElts :: InstEnv -> [Instance]
-instEnvElts ie = [elt | ClsIE elts _ <- eltsUFM ie, elt <- elts]
+instEnvElts ie = [elt | ClsIE elts <- eltsUFM ie, elt <- elts]
classInstances :: (InstEnv,InstEnv) -> Class -> [Instance]
classInstances (pkg_ie, home_ie) cls
= get home_ie ++ get pkg_ie
where
get env = case lookupUFM env cls of
- Just (ClsIE insts _) -> insts
- Nothing -> []
+ Just (ClsIE insts) -> insts
+ Nothing -> []
extendInstEnvList :: InstEnv -> [Instance] -> InstEnv
extendInstEnvList inst_env ispecs = foldl extendInstEnv inst_env ispecs
extendInstEnv :: InstEnv -> Instance -> InstEnv
-extendInstEnv inst_env ins_item@(Instance { is_cls = cls_nm, is_tcs = mb_tcs })
- = addToUFM_C add inst_env cls_nm (ClsIE [ins_item] ins_tyvar)
+extendInstEnv inst_env ins_item@(Instance { is_cls = cls_nm })
+ = addToUFM_C add inst_env cls_nm (ClsIE [ins_item])
where
- add (ClsIE cur_insts cur_tyvar) _ = ClsIE (ins_item : cur_insts)
- (ins_tyvar || cur_tyvar)
- ins_tyvar = not (any isJust mb_tcs)
+ add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts)
\end{code}
@@ -442,7 +437,7 @@ lookupInstEnv :: (InstEnv, InstEnv) -- External and home package inst-env
-- Then which we choose would depend on the way in which 'a'
-- is instantiated. So we report that Foo [b] is a match (mapping b->a)
-- but Foo [Int] is a unifier. This gives the caller a better chance of
--- giving a suitable error messagen
+-- giving a suitable error message
lookupInstEnv (pkg_ie, home_ie) cls tys
= (safe_matches, all_unifs, safe_fail)
@@ -494,22 +489,9 @@ lookupInstEnv (pkg_ie, home_ie) cls tys
--------------
lookup env = case lookupUFM env cls of
Nothing -> ([],[]) -- No instances for this class
- Just (ClsIE insts has_tv_insts)
- | all_tvs && not has_tv_insts
- -> ([],[]) -- Short cut for common case
- -- The thing we are looking up is of form (C a b c), and
- -- the ClsIE has no instances of that form, so don't bother to search
-
- | otherwise
- -> find [] [] insts
+ Just (ClsIE insts) -> find [] [] insts
--------------
- lookup_tv :: TvSubst -> TyVar -> Either TyVar Type
- -- See Note [InstTypes: instantiating types]
- lookup_tv subst tv = case lookupTyVar subst tv of
- Just ty -> Right ty
- Nothing -> Left tv
-
find ms us [] = (ms, us)
find ms us (item@(Instance { is_tcs = mb_tcs, is_tvs = tpl_tvs,
is_tys = tpl_tys, is_flag = oflag,
@@ -541,6 +523,13 @@ lookupInstEnv (pkg_ie, home_ie) cls tys
Just _ -> find ms (item:us) rest
Nothing -> find ms us rest
+ ----------------
+ lookup_tv :: TvSubst -> TyVar -> Either TyVar Type
+ -- See Note [InstTypes: instantiating types]
+ lookup_tv subst tv = case lookupTyVar subst tv of
+ Just ty -> Right ty
+ Nothing -> Left tv
+
---------------
---------------
insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch]
--
GitLab