Skip to content
Snippets Groups Projects
Commit 7bb06950 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

[project @ 2000-07-07 12:13:43 by simonpj] 

This commit moves the instance environment out of the Class data
structure, where it was immutable, to part of the type-checker
environment.  This change is absolutely essential as part of
our move to GHCi, and I think it's also going to be necessary
for Andrei's work on generic functions.

As part of this change, we can remove

  a) types/InstEnv.*	(thereby also removing a hi-boot loop)
  b) a tc-fixpoint-loop in TcModule

Both of these are worthwhile simplifications.
parent ec459c23
No related merge requests found
Hide whitespace changes
Inline Side-by-side
Showing
with 478 additions and 519 deletions
ghc/compiler/DEPEND-NOTES
+ 1
− 3
View file @ 7bb06950
...@@ -12,7 +12,7 @@ then ...@@ -12,7 +12,7 @@ then
then then
VarEnv, VarSet, ThinAir VarEnv, VarSet, ThinAir
then then
Class (loop TyCon.TyCon, loop Type.Type, loop InstEnv.InstEnv) Class (loop TyCon.TyCon, loop Type.Type)
then then
TyCon (loop Type.Type, loop Type.Kind, loop DataCon.DataCon) TyCon (loop Type.Type, loop Type.Kind, loop DataCon.DataCon)
then then
...@@ -23,8 +23,6 @@ then ...@@ -23,8 +23,6 @@ then
Unify, PprType (PprEnv) Unify, PprType (PprEnv)
then then
Literal (TysPrim, PprType), DataCon Literal (TysPrim, PprType), DataCon
then
InstEnv (Unify)
then then
TysWiredIn (DataCon.mkDataCon, loop MkId.mkDataConId) TysWiredIn (DataCon.mkDataCon, loop MkId.mkDataConId)
then then
......
ghc/compiler/typecheck/Inst.lhs
+ 15
− 34
View file @ 7bb06950
...@@ -11,8 +11,6 @@ module Inst ( ...@@ -11,8 +11,6 @@ module Inst (
Inst, OverloadedLit(..), Inst, OverloadedLit(..),
pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts, pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts,
InstanceMapper,
newDictFromOld, newDicts, newClassDicts, newDictsAtLoc, newDictFromOld, newDicts, newClassDicts, newDictsAtLoc,
newMethod, newMethodWithGivenTy, newOverloadedLit, newMethod, newMethodWithGivenTy, newOverloadedLit,
newIPDict, instOverloadedFun, newIPDict, instOverloadedFun,
...@@ -45,21 +43,22 @@ import TcHsSyn ( TcExpr, TcId, ...@@ -45,21 +43,22 @@ import TcHsSyn ( TcExpr, TcId,
mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
) )
import TcMonad import TcMonad
import TcEnv ( TcIdSet, tcLookupValueByKey, tcLookupTyConByKey ) import TcEnv ( TcIdSet, InstEnv, tcGetInstEnv, lookupInstEnv, InstLookupResult(..),
tcLookupValueByKey, tcLookupTyConByKey
)
import TcType ( TcThetaType, import TcType ( TcThetaType,
TcType, TcTauType, TcTyVarSet, TcType, TcTauType, TcTyVarSet,
zonkTcTyVars, zonkTcType, zonkTcTypes, zonkTcTyVars, zonkTcType, zonkTcTypes,
zonkTcThetaType zonkTcThetaType
) )
import Bag import Bag
import Class ( classInstEnv, Class, FunDep ) import Class ( Class, FunDep )
import FunDeps ( instantiateFdClassTys ) import FunDeps ( instantiateFdClassTys )
import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal ) import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass ) import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
import Name ( OccName, Name, mkDictOcc, mkMethodOcc, mkIPOcc, import Name ( OccName, Name, mkDictOcc, mkMethodOcc, mkIPOcc,
getOccName, nameUnique ) getOccName, nameUnique )
import PprType ( pprPred ) import PprType ( pprPred )
import InstEnv ( InstEnv, lookupInstEnv, InstEnvResult(..) )
import SrcLoc ( SrcLoc ) import SrcLoc ( SrcLoc )
import Type ( Type, PredType(..), ThetaType, import Type ( Type, PredType(..), ThetaType,
mkTyVarTy, isTyVarTy, mkDictTy, mkPredTy, mkTyVarTy, isTyVarTy, mkDictTy, mkPredTy,
...@@ -67,7 +66,6 @@ import Type ( Type, PredType(..), ThetaType, ...@@ -67,7 +66,6 @@ import Type ( Type, PredType(..), ThetaType,
splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
mkSynTy, tidyOpenType, tidyOpenTypes mkSynTy, tidyOpenType, tidyOpenTypes
) )
import InstEnv ( InstEnv )
import Subst ( emptyInScopeSet, mkSubst, import Subst ( emptyInScopeSet, mkSubst,
substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst
) )
...@@ -285,6 +283,7 @@ Predicates ...@@ -285,6 +283,7 @@ Predicates
isDict :: Inst -> Bool isDict :: Inst -> Bool
isDict (Dict _ _ _) = True isDict (Dict _ _ _) = True
isDict other = False isDict other = False
isClassDict :: Inst -> Bool isClassDict :: Inst -> Bool
isClassDict (Dict _ (Class _ _) _) = True isClassDict (Dict _ (Class _ _) _) = True
isClassDict other = False isClassDict other = False
...@@ -294,10 +293,8 @@ isMethod (Method _ _ _ _ _ _) = True ...@@ -294,10 +293,8 @@ isMethod (Method _ _ _ _ _ _) = True
isMethod other = False isMethod other = False
isMethodFor :: TcIdSet -> Inst -> Bool isMethodFor :: TcIdSet -> Inst -> Bool
isMethodFor ids (Method uniq id tys _ _ loc) isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
= id `elemVarSet` ids isMethodFor ids inst = False
isMethodFor ids inst
= False
isTyVarDict :: Inst -> Bool isTyVarDict :: Inst -> Bool
isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys
...@@ -628,25 +625,6 @@ show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}") ...@@ -628,25 +625,6 @@ show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
%* * %* *
%************************************************************************ %************************************************************************
\begin{code}
type InstanceMapper = Class -> InstEnv
\end{code}
A @ClassInstEnv@ lives inside a class, and identifies all the instances
of that class. The @Id@ inside a ClassInstEnv mapping is the dfun for
that instance.
There is an important consistency constraint between the @MatchEnv@s
in and the dfun @Id@s inside them: the free type variables of the
@Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
type variables of the dfun. Thus, the @ClassInstEnv@ for @Eq@ might
contain the following entry:
@
[a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
@
The "a" in the pattern must be one of the forall'd variables in
the dfun type.
\begin{code} \begin{code}
data LookupInstResult s data LookupInstResult s
= NoInstance = NoInstance
...@@ -659,7 +637,8 @@ lookupInst :: Inst ...@@ -659,7 +637,8 @@ lookupInst :: Inst
-- Dictionaries -- Dictionaries
lookupInst dict@(Dict _ (Class clas tys) loc) lookupInst dict@(Dict _ (Class clas tys) loc)
= case lookupInstEnv (classInstEnv clas) tys of = tcGetInstEnv `thenNF_Tc` \ inst_env ->
case lookupInstEnv inst_env clas tys of
FoundInst tenv dfun_id FoundInst tenv dfun_id
-> let -> let
...@@ -754,13 +733,13 @@ appropriate dictionary if it exists. It is used only when resolving ...@@ -754,13 +733,13 @@ appropriate dictionary if it exists. It is used only when resolving
ambiguous dictionaries. ambiguous dictionaries.
\begin{code} \begin{code}
lookupSimpleInst :: InstEnv lookupSimpleInst :: Class
-> Class
-> [Type] -- Look up (c,t) -> [Type] -- Look up (c,t)
-> NF_TcM s (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s -> NF_TcM s (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s
lookupSimpleInst class_inst_env clas tys lookupSimpleInst clas tys
= case lookupInstEnv class_inst_env tys of = tcGetInstEnv `thenNF_Tc` \ inst_env ->
case lookupInstEnv inst_env clas tys of
FoundInst tenv dfun FoundInst tenv dfun
-> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta')) -> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta'))
where where
...@@ -769,3 +748,5 @@ lookupSimpleInst class_inst_env clas tys ...@@ -769,3 +748,5 @@ lookupSimpleInst class_inst_env clas tys
other -> returnNF_Tc Nothing other -> returnNF_Tc Nothing
\end{code} \end{code}
ghc/compiler/typecheck/TcClassDcl.lhs
+ 1
− 3
View file @ 7bb06950
...@@ -140,7 +140,7 @@ kcClassDecl (ClassDecl context class_name ...@@ -140,7 +140,7 @@ kcClassDecl (ClassDecl context class_name
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
tcClassDecl1 rec_env rec_inst_mapper rec_vrcs tcClassDecl1 rec_env rec_vrcs
(ClassDecl context class_name (ClassDecl context class_name
tyvar_names fundeps class_sigs def_methods pragmas tyvar_names fundeps class_sigs def_methods pragmas
tycon_name datacon_name datacon_wkr_name sc_sel_names src_loc) tycon_name datacon_name datacon_wkr_name sc_sel_names src_loc)
...@@ -166,11 +166,9 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs ...@@ -166,11 +166,9 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
-- MAKE THE CLASS OBJECT ITSELF -- MAKE THE CLASS OBJECT ITSELF
let let
(op_tys, op_items) = unzip sig_stuff (op_tys, op_items) = unzip sig_stuff
rec_class_inst_env = rec_inst_mapper rec_class
clas = mkClass class_name tyvars fds clas = mkClass class_name tyvars fds
sc_theta sc_sel_ids op_items sc_theta sc_sel_ids op_items
tycon tycon
rec_class_inst_env
dict_component_tys = sc_tys ++ op_tys dict_component_tys = sc_tys ++ op_tys
new_or_data = case dict_component_tys of new_or_data = case dict_component_tys of
......
ghc/compiler/typecheck/TcDeriv.lhs
+ 13
− 14
View file @ 7bb06950
...@@ -16,10 +16,9 @@ import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds ) ...@@ -16,10 +16,9 @@ import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds )
import CmdLineOpts ( opt_D_dump_deriv ) import CmdLineOpts ( opt_D_dump_deriv )
import TcMonad import TcMonad
import Inst ( InstanceMapper ) import TcEnv ( InstEnv, getEnvTyCons, tcSetInstEnv )
import TcEnv ( getEnvTyCons )
import TcGenDeriv -- Deriv stuff import TcGenDeriv -- Deriv stuff
import TcInstUtil ( InstInfo(..), buildInstanceEnvs ) import TcInstUtil ( InstInfo(..), buildInstanceEnv )
import TcSimplify ( tcSimplifyThetas ) import TcSimplify ( tcSimplifyThetas )
import RnBinds ( rnMethodBinds, rnTopMonoBinds ) import RnBinds ( rnMethodBinds, rnTopMonoBinds )
...@@ -422,15 +421,15 @@ solveDerivEqns inst_decl_infos_in orig_eqns ...@@ -422,15 +421,15 @@ solveDerivEqns inst_decl_infos_in orig_eqns
-- with the current set of solutions, giving a -- with the current set of solutions, giving a
add_solns inst_decl_infos_in orig_eqns current_solns add_solns inst_decl_infos_in orig_eqns current_solns
`thenNF_Tc` \ (new_inst_infos, inst_mapper) -> `thenNF_Tc` \ (new_inst_infos, inst_env) ->
let
class_to_inst_env cls = inst_mapper cls
in
-- Simplify each RHS -- Simplify each RHS
listTc [ tcAddErrCtxt (derivCtxt tc) $ tcSetInstEnv inst_env (
tcSimplifyThetas class_to_inst_env deriv_rhs listTc [ tcAddErrCtxt (derivCtxt tc) $
| (_,tc,_,deriv_rhs) <- orig_eqns ] `thenTc` \ next_solns -> tcSimplifyThetas deriv_rhs
| (_,tc,_,deriv_rhs) <- orig_eqns ]
) `thenTc` \ next_solns ->
-- Canonicalise the solutions, so they compare nicely -- Canonicalise the solutions, so they compare nicely
let canonicalised_next_solns let canonicalised_next_solns
...@@ -443,18 +442,18 @@ solveDerivEqns inst_decl_infos_in orig_eqns ...@@ -443,18 +442,18 @@ solveDerivEqns inst_decl_infos_in orig_eqns
add_solns :: Bag InstInfo -- The global, non-derived ones add_solns :: Bag InstInfo -- The global, non-derived ones
-> [DerivEqn] -> [DerivSoln] -> [DerivEqn] -> [DerivSoln]
-> NF_TcM s ([InstInfo], -- The new, derived ones -> NF_TcM s ([InstInfo], -- The new, derived ones
InstanceMapper) InstEnv)
-- the eqns and solns move "in lockstep"; we have the eqns -- the eqns and solns move "in lockstep"; we have the eqns
-- because we need the LHS info for addClassInstance. -- because we need the LHS info for addClassInstance.
add_solns inst_infos_in eqns solns add_solns inst_infos_in eqns solns
= discardErrsTc (buildInstanceEnvs all_inst_infos) `thenNF_Tc` \ inst_mapper -> = discardErrsTc (buildInstanceEnv all_inst_infos) `thenNF_Tc` \ inst_env ->
-- We do the discard-errs so that we don't get repeated error messages -- We do the discard-errs so that we don't get repeated error messages
-- about duplicate instances. -- about duplicate instances.
-- They'll appear later, when we do the top-level buildInstanceEnvs. -- They'll appear later, when we do the top-level buildInstanceEnv.
returnNF_Tc (new_inst_infos, inst_mapper) returnNF_Tc (new_inst_infos, inst_env)
where where
new_inst_infos = zipWithEqual "add_solns" mk_deriv_inst_info eqns solns new_inst_infos = zipWithEqual "add_solns" mk_deriv_inst_info eqns solns
......
ghc/compiler/typecheck/TcEnv.lhs
+ 321
− 46
View file @ 7bb06950
...@@ -27,6 +27,10 @@ module TcEnv( ...@@ -27,6 +27,10 @@ module TcEnv(
newLocalId, newSpecPragmaId, newLocalId, newSpecPragmaId,
tcGetGlobalTyVars, tcExtendGlobalTyVars, tcGetGlobalTyVars, tcExtendGlobalTyVars,
InstEnv, emptyInstEnv, addToInstEnv,
lookupInstEnv, InstLookupResult(..),
tcGetInstEnv, tcSetInstEnv, classInstEnv,
badCon, badPrimOp badCon, badPrimOp
) where ) where
...@@ -44,7 +48,7 @@ import TcType ( TcType, TcTyVar, TcTyVarSet, TcThetaType, ...@@ -44,7 +48,7 @@ import TcType ( TcType, TcTyVar, TcTyVarSet, TcThetaType,
) )
import VarEnv import VarEnv
import VarSet import VarSet
import Type ( Kind, superKind, import Type ( Kind, Type, superKind,
tyVarsOfType, tyVarsOfTypes, mkTyVarTy, tyVarsOfType, tyVarsOfTypes, mkTyVarTy,
splitForAllTys, splitRhoTy, splitFunTys, splitForAllTys, splitRhoTy, splitFunTys,
splitAlgTyConApp_maybe, getTyVar splitAlgTyConApp_maybe, getTyVar
...@@ -65,15 +69,16 @@ import Name ( Name, OccName, nameOccName, getSrcLoc, ...@@ -65,15 +69,16 @@ import Name ( Name, OccName, nameOccName, getSrcLoc,
NameEnv, emptyNameEnv, addToNameEnv, NameEnv, emptyNameEnv, addToNameEnv,
extendNameEnv, lookupNameEnv, nameEnvElts extendNameEnv, lookupNameEnv, nameEnvElts
) )
import Unify ( unifyTyListsX, matchTys )
import Unique ( pprUnique10, Unique, Uniquable(..) ) import Unique ( pprUnique10, Unique, Uniquable(..) )
import FiniteMap ( lookupFM, addToFM ) import FiniteMap ( lookupFM, addToFM )
import UniqFM import UniqFM
import Unique ( Uniquable(..) ) import Unique ( Uniquable(..) )
import Util ( zipEqual, zipWith3Equal, mapAccumL ) import Util ( zipEqual, zipWith3Equal, mapAccumL )
import Bag ( bagToList ) import Bag ( bagToList )
import Maybes ( maybeToBool, catMaybes )
import SrcLoc ( SrcLoc ) import SrcLoc ( SrcLoc )
import FastString ( FastString ) import FastString ( FastString )
import Maybes
import Outputable import Outputable
\end{code} \end{code}
...@@ -144,6 +149,7 @@ data TcEnv = TcEnv ...@@ -144,6 +149,7 @@ data TcEnv = TcEnv
UsageEnv UsageEnv
TypeEnv TypeEnv
ValueEnv ValueEnv
InstEnv
(TcTyVarSet, -- The in-scope TyVars (TcTyVarSet, -- The in-scope TyVars
TcRef TcTyVarSet) -- Free type variables of the value env TcRef TcTyVarSet) -- Free type variables of the value env
-- ...why mutable? see notes with tcGetGlobalTyVars -- ...why mutable? see notes with tcGetGlobalTyVars
...@@ -165,11 +171,11 @@ data TcTyThing = ATyVar TcTyVar -- Mutable only so that the kind can be mutable ...@@ -165,11 +171,11 @@ data TcTyThing = ATyVar TcTyVar -- Mutable only so that the kind can be mutable
initEnv :: TcRef TcTyVarSet -> TcEnv initEnv :: TcRef TcTyVarSet -> TcEnv
initEnv mut = TcEnv emptyNameEnv emptyNameEnv emptyNameEnv (emptyVarSet, mut) initEnv mut = TcEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyInstEnv (emptyVarSet, mut)
getEnvClasses (TcEnv _ te _ _) = [cl | (_, AClass cl _) <- nameEnvElts te] getEnvClasses (TcEnv _ te _ _ _) = [cl | (_, AClass cl _) <- nameEnvElts te]
getEnvTyCons (TcEnv _ te _ _) = catMaybes (map get_tc (nameEnvElts te)) getEnvTyCons (TcEnv _ te _ _ _) = catMaybes (map get_tc (nameEnvElts te))
where where
get_tc (_, ADataTyCon tc) = Just tc get_tc (_, ADataTyCon tc) = Just tc
get_tc (_, ASynTyCon tc _) = Just tc get_tc (_, ASynTyCon tc _) = Just tc
...@@ -184,16 +190,20 @@ getEnvAllTyCons te_list = catMaybes (map get_tc te_list) ...@@ -184,16 +190,20 @@ getEnvAllTyCons te_list = catMaybes (map get_tc te_list)
get_tc other = Nothing get_tc other = Nothing
\end{code} \end{code}
The UsageEnv
~~~~~~~~~~~~
Extending the usage environment. %************************************************************************
%* *
\subsection{The usage environment}
%* *
%************************************************************************
Extending the usage environment
\begin{code} \begin{code}
tcExtendUVarEnv :: Name -> UVar -> TcM s r -> TcM s r tcExtendUVarEnv :: Name -> UVar -> TcM s r -> TcM s r
tcExtendUVarEnv uv_name uv scope tcExtendUVarEnv uv_name uv scope
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
tcSetEnv (TcEnv (addToNameEnv ue uv_name uv) te ve gtvs) scope tcSetEnv (TcEnv (addToNameEnv ue uv_name uv) te ve ie gtvs) scope
\end{code} \end{code}
Looking up in the environments. Looking up in the environments.
...@@ -201,22 +211,23 @@ Looking up in the environments. ...@@ -201,22 +211,23 @@ Looking up in the environments.
\begin{code} \begin{code}
tcLookupUVar :: Name -> NF_TcM s UVar tcLookupUVar :: Name -> NF_TcM s UVar
tcLookupUVar uv_name tcLookupUVar uv_name
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve _ gtvs) ->
case lookupNameEnv ue uv_name of case lookupNameEnv ue uv_name of
Just uv -> returnNF_Tc uv Just uv -> returnNF_Tc uv
Nothing -> failWithTc (uvNameOutOfScope uv_name) Nothing -> failWithTc (uvNameOutOfScope uv_name)
\end{code} \end{code}
The TypeEnv %************************************************************************
~~~~~~~~~~~~ %* *
\subsection{The type environment}
Extending the type environment. %* *
%************************************************************************
\begin{code} \begin{code}
tcExtendTyVarEnv :: [TyVar] -> TcM s r -> TcM s r tcExtendTyVarEnv :: [TyVar] -> TcM s r -> TcM s r
tcExtendTyVarEnv tyvars scope tcExtendTyVarEnv tyvars scope
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs, gtvs)) -> = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope_tvs, gtvs)) ->
let let
extend_list = [ (getName tv, (kindToTcKind (tyVarKind tv), ATyVar tv)) extend_list = [ (getName tv, (kindToTcKind (tyVarKind tv), ATyVar tv))
| tv <- tyvars | tv <- tyvars
...@@ -232,7 +243,7 @@ tcExtendTyVarEnv tyvars scope ...@@ -232,7 +243,7 @@ tcExtendTyVarEnv tyvars scope
-- class and instance decls, when we mustn't generalise the class tyvars -- class and instance decls, when we mustn't generalise the class tyvars
-- when typechecking the methods. -- when typechecking the methods.
tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' -> tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
tcSetEnv (TcEnv ue te' ve (in_scope_tvs', gtvs')) scope tcSetEnv (TcEnv ue te' ve ie (in_scope_tvs', gtvs')) scope
-- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars: -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
-- the signature tyvars contain the original names -- the signature tyvars contain the original names
...@@ -242,20 +253,20 @@ tcExtendTyVarEnv tyvars scope ...@@ -242,20 +253,20 @@ tcExtendTyVarEnv tyvars scope
tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM s r -> TcM s r tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM s r -> TcM s r
tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
let let
te' = extendNameEnv te stuff te' = extendNameEnv te stuff
in in
tcSetEnv (TcEnv ue te' ve gtvs) thing_inside tcSetEnv (TcEnv ue te' ve ie gtvs) thing_inside
where where
stuff = [ (getName sig_tv, (kindToTcKind (tyVarKind inst_tv), ATyVar inst_tv)) stuff = [ (getName sig_tv, (kindToTcKind (tyVarKind inst_tv), ATyVar inst_tv))
| (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
] ]
tcExtendGlobalTyVars extra_global_tvs scope tcExtendGlobalTyVars extra_global_tvs scope
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (in_scope,gtvs)) -> = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope,gtvs)) ->
tc_extend_gtvs gtvs extra_global_tvs `thenNF_Tc` \ gtvs' -> tc_extend_gtvs gtvs extra_global_tvs `thenNF_Tc` \ gtvs' ->
tcSetEnv (TcEnv ue te ve (in_scope,gtvs')) scope tcSetEnv (TcEnv ue te ve ie (in_scope,gtvs')) scope
tc_extend_gtvs gtvs extra_global_tvs tc_extend_gtvs gtvs extra_global_tvs
= tcReadMutVar gtvs `thenNF_Tc` \ global_tvs -> = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
...@@ -272,7 +283,7 @@ the environment. ...@@ -272,7 +283,7 @@ the environment.
\begin{code} \begin{code}
tcGetGlobalTyVars :: NF_TcM s TcTyVarSet tcGetGlobalTyVars :: NF_TcM s TcTyVarSet
tcGetGlobalTyVars tcGetGlobalTyVars
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (_,gtvs)) -> = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (_,gtvs)) ->
tcReadMutVar gtvs `thenNF_Tc` \ global_tvs -> tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' -> zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' ->
let let
...@@ -283,7 +294,7 @@ tcGetGlobalTyVars ...@@ -283,7 +294,7 @@ tcGetGlobalTyVars
tcGetInScopeTyVars :: NF_TcM s [TcTyVar] tcGetInScopeTyVars :: NF_TcM s [TcTyVar]
tcGetInScopeTyVars tcGetInScopeTyVars
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs, gtvs)) -> = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope_tvs, gtvs)) ->
returnNF_Tc (varSetElems in_scope_tvs) returnNF_Tc (varSetElems in_scope_tvs)
\end{code} \end{code}
...@@ -295,11 +306,11 @@ tcExtendTypeEnv :: [(Name, (TcKind, TcTyThing))] -> TcM s r -> TcM s r ...@@ -295,11 +306,11 @@ tcExtendTypeEnv :: [(Name, (TcKind, TcTyThing))] -> TcM s r -> TcM s r
tcExtendTypeEnv bindings scope tcExtendTypeEnv bindings scope
= ASSERT( null [tv | (_, (_,ATyVar tv)) <- bindings] ) = ASSERT( null [tv | (_, (_,ATyVar tv)) <- bindings] )
-- Not for tyvars; use tcExtendTyVarEnv -- Not for tyvars; use tcExtendTyVarEnv
tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
let let
te' = extendNameEnv te bindings te' = extendNameEnv te bindings
in in
tcSetEnv (TcEnv ue te' ve gtvs) scope tcSetEnv (TcEnv ue te' ve ie gtvs) scope
\end{code} \end{code}
...@@ -308,7 +319,7 @@ Looking up in the environments. ...@@ -308,7 +319,7 @@ Looking up in the environments.
\begin{code} \begin{code}
tcLookupTy :: Name -> NF_TcM s (TcKind, TcTyThing) tcLookupTy :: Name -> NF_TcM s (TcKind, TcTyThing)
tcLookupTy name tcLookupTy name
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
case lookupNameEnv te name of { case lookupNameEnv te name of {
Just thing -> returnNF_Tc thing ; Just thing -> returnNF_Tc thing ;
Nothing -> Nothing ->
...@@ -324,21 +335,21 @@ tcLookupTy name ...@@ -324,21 +335,21 @@ tcLookupTy name
tcLookupClassByKey :: Unique -> NF_TcM s Class tcLookupClassByKey :: Unique -> NF_TcM s Class
tcLookupClassByKey key tcLookupClassByKey key
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
case lookupUFM_Directly te key of case lookupUFM_Directly te key of
Just (_, AClass cl _) -> returnNF_Tc cl Just (_, AClass cl _) -> returnNF_Tc cl
other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key) other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key)
tcLookupClassByKey_maybe :: Unique -> NF_TcM s (Maybe Class) tcLookupClassByKey_maybe :: Unique -> NF_TcM s (Maybe Class)
tcLookupClassByKey_maybe key tcLookupClassByKey_maybe key
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
case lookupUFM_Directly te key of case lookupUFM_Directly te key of
Just (_, AClass cl _) -> returnNF_Tc (Just cl) Just (_, AClass cl _) -> returnNF_Tc (Just cl)
other -> returnNF_Tc Nothing other -> returnNF_Tc Nothing
tcLookupTyConByKey :: Unique -> NF_TcM s TyCon tcLookupTyConByKey :: Unique -> NF_TcM s TyCon
tcLookupTyConByKey key tcLookupTyConByKey key
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
case lookupUFM_Directly te key of case lookupUFM_Directly te key of
Just (_, ADataTyCon tc) -> returnNF_Tc tc Just (_, ADataTyCon tc) -> returnNF_Tc tc
Just (_, ASynTyCon tc _) -> returnNF_Tc tc Just (_, ASynTyCon tc _) -> returnNF_Tc tc
...@@ -357,22 +368,22 @@ tcLookupTyConByKey key ...@@ -357,22 +368,22 @@ tcLookupTyConByKey key
\begin{code} \begin{code}
tcExtendGlobalValEnv :: [Id] -> TcM s a -> TcM s a tcExtendGlobalValEnv :: [Id] -> TcM s a -> TcM s a
tcExtendGlobalValEnv ids scope tcExtendGlobalValEnv ids scope
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
let let
ve' = addListToUFM_Directly ve [(getUnique id, id) | id <- ids] ve' = addListToUFM_Directly ve [(getUnique id, id) | id <- ids]
in in
tcSetEnv (TcEnv ue te ve' gtvs) scope tcSetEnv (TcEnv ue te ve' ie gtvs) scope
tcExtendLocalValEnv :: [(Name,TcId)] -> TcM s a -> TcM s a tcExtendLocalValEnv :: [(Name,TcId)] -> TcM s a -> TcM s a
tcExtendLocalValEnv names_w_ids scope tcExtendLocalValEnv names_w_ids scope
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs,gtvs)) -> = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope_tvs,gtvs)) ->
tcReadMutVar gtvs `thenNF_Tc` \ global_tvs -> tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
let let
ve' = extendNameEnv ve names_w_ids ve' = extendNameEnv ve names_w_ids
extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids) extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids)
in in
tc_extend_gtvs gtvs extra_global_tyvars `thenNF_Tc` \ gtvs' -> tc_extend_gtvs gtvs extra_global_tyvars `thenNF_Tc` \ gtvs' ->
tcSetEnv (TcEnv ue te ve' (in_scope_tvs,gtvs')) scope tcSetEnv (TcEnv ue te ve' ie (in_scope_tvs,gtvs')) scope
\end{code} \end{code}
...@@ -381,7 +392,7 @@ tcLookupValue :: Name -> NF_TcM s Id -- Panics if not found ...@@ -381,7 +392,7 @@ tcLookupValue :: Name -> NF_TcM s Id -- Panics if not found
tcLookupValue name tcLookupValue name
= case maybeWiredInIdName name of = case maybeWiredInIdName name of
Just id -> returnNF_Tc id Just id -> returnNF_Tc id
Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
returnNF_Tc (lookupWithDefaultUFM ve def name) returnNF_Tc (lookupWithDefaultUFM ve def name)
where where
def = pprPanic "tcLookupValue:" (ppr name) def = pprPanic "tcLookupValue:" (ppr name)
...@@ -390,28 +401,29 @@ tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id) ...@@ -390,28 +401,29 @@ tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id)
tcLookupValueMaybe name tcLookupValueMaybe name
= case maybeWiredInIdName name of = case maybeWiredInIdName name of
Just id -> returnNF_Tc (Just id) Just id -> returnNF_Tc (Just id)
Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
returnNF_Tc (lookupNameEnv ve name) returnNF_Tc (lookupNameEnv ve name)
tcLookupValueByKey :: Unique -> NF_TcM s Id -- Panics if not found tcLookupValueByKey :: Unique -> NF_TcM s Id -- Panics if not found
tcLookupValueByKey key tcLookupValueByKey key
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
returnNF_Tc (explicitLookupValueByKey ve key) returnNF_Tc (explicitLookupValueByKey ve key)
tcLookupValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id) tcLookupValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
tcLookupValueByKeyMaybe key tcLookupValueByKeyMaybe key
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
returnNF_Tc (lookupUFM_Directly ve key) returnNF_Tc (lookupUFM_Directly ve key)
tcGetValueEnv :: NF_TcM s ValueEnv tcGetValueEnv :: NF_TcM s ValueEnv
tcGetValueEnv tcGetValueEnv
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) ->
returnNF_Tc ve returnNF_Tc ve
tcSetValueEnv :: ValueEnv -> TcM s a -> TcM s a tcSetValueEnv :: ValueEnv -> TcM s a -> TcM s a
tcSetValueEnv ve scope tcSetValueEnv ve scope
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te _ gtvs) -> = tcGetEnv `thenNF_Tc` \ (TcEnv ue te _ ie gtvs) ->
tcSetEnv (TcEnv ue te ve gtvs) scope tcSetEnv (TcEnv ue te ve ie gtvs) scope
-- Non-monadic version, environment given explicitly -- Non-monadic version, environment given explicitly
explicitLookupValueByKey :: ValueEnv -> Unique -> Id explicitLookupValueByKey :: ValueEnv -> Unique -> Id
...@@ -443,12 +455,7 @@ tcAddImportedIdInfo unf_env id ...@@ -443,12 +455,7 @@ tcAddImportedIdInfo unf_env id
-- ToDo: could check that types are the same -- ToDo: could check that types are the same
\end{code} \end{code}
Constructing new Ids
%************************************************************************
%* *
\subsection{Constructing new Ids}
%* *
%************************************************************************
\begin{code} \begin{code}
newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM s TcId newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM s TcId
...@@ -463,6 +470,274 @@ newSpecPragmaId name ty ...@@ -463,6 +470,274 @@ newSpecPragmaId name ty
\end{code} \end{code}
%************************************************************************
%* *
\subsection{The instance environment}
%* *
%************************************************************************
\begin{code}
tcGetInstEnv :: NF_TcM s InstEnv
tcGetInstEnv = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (_,gtvs)) ->
returnNF_Tc ie
tcSetInstEnv :: InstEnv -> TcM s a -> TcM s a
tcSetInstEnv ie scope
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve _ gtvs) ->
tcSetEnv (TcEnv ue te ve ie gtvs) scope
\end{code}
\begin{code}
type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class
type ClsInstEnv = [(TyVarSet, [Type], Id)] -- The instances for a particular class
classInstEnv :: InstEnv -> Class -> ClsInstEnv
classInstEnv env cls = lookupWithDefaultUFM env [] cls
\end{code}
A @ClsInstEnv@ lives inside a class, and identifies all the instances
of that class. The @Id@ inside a ClsInstEnv mapping is the dfun for
that instance.
If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then
forall a b, C t1 t2 t3 can be constructed by dfun
or, to put it another way, we have
instance (...) => C t1 t2 t3, witnessed by dfun
There is an important consistency constraint in the elements of a ClsInstEnv:
* [a,b] must be a superset of the free vars of [t1,t2,t3]
* The dfun must itself be quantified over [a,b]
Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry:
[a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
The "a" in the pattern must be one of the forall'd variables in
the dfun type.
Notes on overlapping instances
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In some ClsInstEnvs, overlap is prohibited; that is, no pair of templates unify.
In others, overlap is permitted, but only in such a way that one can make
a unique choice when looking up. That is, overlap is only permitted if
one template matches the other, or vice versa. So this is ok:
[a] [Int]
but this is not
(Int,a) (b,Int)
If overlap is permitted, the list is kept most specific first, so that
the first lookup is the right choice.
For now we just use association lists.
\subsection{Avoiding a problem with overlapping}
Consider this little program:
\begin{pseudocode}
class C a where c :: a
class C a => D a where d :: a
instance C Int where c = 17
instance D Int where d = 13
instance C a => C [a] where c = [c]
instance ({- C [a], -} D a) => D [a] where d = c
instance C [Int] where c = [37]
main = print (d :: [Int])
\end{pseudocode}
What do you think `main' prints (assuming we have overlapping instances, and
all that turned on)? Well, the instance for `D' at type `[a]' is defined to
be `c' at the same type, and we've got an instance of `C' at `[Int]', so the
answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because
the `C [Int]' instance is more specific).
Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong. That
was easy ;-) Let's just consult hugs for good measure. Wait - if I use old
hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it
doesn't even compile! What's going on!?
What hugs complains about is the `D [a]' instance decl.
\begin{pseudocode}
ERROR "mj.hs" (line 10): Cannot build superclass instance
*** Instance : D [a]
*** Context supplied : D a
*** Required superclass : C [a]
\end{pseudocode}
You might wonder what hugs is complaining about. It's saying that you
need to add `C [a]' to the context of the `D [a]' instance (as appears
in comments). But there's that `C [a]' instance decl one line above
that says that I can reduce the need for a `C [a]' instance to the
need for a `C a' instance, and in this case, I already have the
necessary `C a' instance (since we have `D a' explicitly in the
context, and `C' is a superclass of `D').
Unfortunately, the above reasoning indicates a premature commitment to the
generic `C [a]' instance. I.e., it prematurely rules out the more specific
instance `C [Int]'. This is the mistake that ghc-4.06 makes. The fix is to
add the context that hugs suggests (uncomment the `C [a]'), effectively
deferring the decision about which instance to use.
Now, interestingly enough, 4.04 has this same bug, but it's covered up
in this case by a little known `optimization' that was disabled in
4.06. Ghc-4.04 silently inserts any missing superclass context into
an instance declaration. In this case, it silently inserts the `C
[a]', and everything happens to work out.
(See `basicTypes/MkId:mkDictFunId' for the code in question. Search for
`Mark Jones', although Mark claims no credit for the `optimization' in
question, and would rather it stopped being called the `Mark Jones
optimization' ;-)
So, what's the fix? I think hugs has it right. Here's why. Let's try
something else out with ghc-4.04. Let's add the following line:
d' :: D a => [a]
d' = c
Everyone raise their hand who thinks that `d :: [Int]' should give a
different answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The
`optimization' only applies to instance decls, not to regular
bindings, giving inconsistent behavior.
Old hugs had this same bug. Here's how we fixed it: like GHC, the
list of instances for a given class is ordered, so that more specific
instances come before more generic ones. For example, the instance
list for C might contain:
..., C Int, ..., C a, ...
When we go to look for a `C Int' instance we'll get that one first.
But what if we go looking for a `C b' (`b' is unconstrained)? We'll
pass the `C Int' instance, and keep going. But if `b' is
unconstrained, then we don't know yet if the more specific instance
will eventually apply. GHC keeps going, and matches on the generic `C
a'. The fix is to, at each step, check to see if there's a reverse
match, and if so, abort the search. This prevents hugs from
prematurely chosing a generic instance when a more specific one
exists.
--Jeff
\begin{code}
emptyInstEnv :: InstEnv
emptyInstEnv = emptyUFM
\end{code}
@lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since
the env is kept ordered, the first match must be the only one. The
thing we are looking up can have an arbitrary "flexi" part.
\begin{code}
lookupInstEnv :: InstEnv -- The envt
-> Class -> [Type] -- Key
-> InstLookupResult
data InstLookupResult
= FoundInst -- There is a (template,substitution) pair
-- that makes the template match the key,
-- and no template is an instance of the key
TyVarSubstEnv Id
| NoMatch Bool -- Boolean is true iff there is at least one
-- template that matches the key.
-- (but there are other template(s) that are
-- instances of the key, so we don't report
-- FoundInst)
-- The NoMatch True case happens when we look up
-- Foo [a]
-- in an InstEnv that has entries for
-- Foo [Int]
-- Foo [b]
-- Then which we choose would depend on the way in which 'a'
-- is instantiated. So we say there is no match, but identify
-- it as ambiguous case in the hope of giving a better error msg.
-- See the notes above from Jeff Lewis
lookupInstEnv env key_cls key_tys
= find (classInstEnv env key_cls)
where
key_vars = tyVarsOfTypes key_tys
find [] = NoMatch False
find ((tpl_tyvars, tpl, val) : rest)
= case matchTys tpl_tyvars tpl key_tys of
Nothing ->
case matchTys key_vars key_tys tpl of
Nothing -> find rest
Just (_, _) -> NoMatch (any_match rest)
Just (subst, leftovers) -> ASSERT( null leftovers )
FoundInst subst val
any_match rest = or [ maybeToBool (matchTys tvs tpl key_tys)
| (tvs,tpl,_) <- rest
]
\end{code}
@addToClsInstEnv@ extends a @ClsInstEnv@, checking for overlaps.
A boolean flag controls overlap reporting.
True => overlap is permitted, but only if one template matches the other;
not if they unify but neither is
\begin{code}
addToInstEnv :: Bool -- True <=> overlap permitted
-> InstEnv -- Envt
-> Class -> [TyVar] -> [Type] -> Id -- New item
-> MaybeErr InstEnv -- Success...
([Type], Id) -- Failure: Offending overlap
addToInstEnv overlap_ok inst_env clas ins_tvs ins_tys value
= case insert_into (classInstEnv inst_env clas) of
Failed stuff -> Failed stuff
Succeeded new_env -> Succeeded (addToUFM inst_env clas new_env)
where
ins_tv_set = mkVarSet ins_tvs
ins_item = (ins_tv_set, ins_tys, value)
insert_into [] = returnMaB [ins_item]
insert_into env@(cur_item@(tpl_tvs, tpl_tys, val) : rest)
-- FAIL if:
-- (a) they are the same, or
-- (b) they unify, and any sort of overlap is prohibited,
-- (c) they unify but neither is more specific than t'other
| identical
|| (unifiable && not overlap_ok)
|| (unifiable && not (ins_item_more_specific || cur_item_more_specific))
= failMaB (tpl_tys, val)
-- New item is an instance of current item, so drop it here
| ins_item_more_specific = returnMaB (ins_item : env)
-- Otherwise carry on
| otherwise = insert_into rest `thenMaB` \ rest' ->
returnMaB (cur_item : rest')
where
unifiable = maybeToBool (unifyTyListsX (ins_tv_set `unionVarSet` tpl_tvs) tpl_tys ins_tys)
ins_item_more_specific = maybeToBool (matchTys tpl_tvs tpl_tys ins_tys)
cur_item_more_specific = maybeToBool (matchTys ins_tv_set ins_tys tpl_tys)
identical = ins_item_more_specific && cur_item_more_specific
\end{code}
%************************************************************************ %************************************************************************
%* * %* *
\subsection{Errors} \subsection{Errors}
......
ghc/compiler/typecheck/TcImprove.lhs
+ 32
− 36
View file @ 7bb06950
...@@ -4,17 +4,16 @@ module TcImprove ( tcImprove ) where ...@@ -4,17 +4,16 @@ module TcImprove ( tcImprove ) where
#include "HsVersions.h" #include "HsVersions.h"
import Name ( Name ) import Name ( Name )
import Class ( Class, FunDep, className, classInstEnv, classExtraBigSig ) import Class ( Class, FunDep, className, classExtraBigSig )
import Unify ( unifyTyListsX, matchTys ) import Unify ( unifyTyListsX, matchTys )
import Subst ( mkSubst, substTy ) import Subst ( mkSubst, substTy )
import TcEnv ( tcGetInstEnv, classInstEnv )
import TcMonad import TcMonad
import TcType ( TcType, TcTyVar, TcTyVarSet, zonkTcType, zonkTcTypes ) import TcType ( TcType, TcTyVar, TcTyVarSet, zonkTcType, zonkTcTypes )
import TcUnify ( unifyTauTyLists ) import TcUnify ( unifyTauTyLists )
import Inst ( LIE, Inst, LookupInstResult(..), import Inst ( LIE, Inst, LookupInstResult(..),
lookupInst, getFunDepsOfLIE, getIPsOfLIE, lookupInst, getFunDepsOfLIE, getIPsOfLIE,
zonkLIE, zonkFunDeps {- for debugging -} ) zonkLIE, zonkFunDeps {- for debugging -} )
import InstEnv ( InstEnv ) -- Reqd for 4.02; InstEnv is a synonym, and
-- 4.02 doesn't "see" it soon enough
import VarSet ( VarSet, emptyVarSet, unionVarSet ) import VarSet ( VarSet, emptyVarSet, unionVarSet )
import VarEnv ( emptyVarEnv ) import VarEnv ( emptyVarEnv )
import FunDeps ( instantiateFdClassTys ) import FunDeps ( instantiateFdClassTys )
...@@ -26,44 +25,41 @@ import List ( elemIndex, nub ) ...@@ -26,44 +25,41 @@ import List ( elemIndex, nub )
tcImprove :: LIE -> TcM s () tcImprove :: LIE -> TcM s ()
-- Do unifications based on functional dependencies in the LIE -- Do unifications based on functional dependencies in the LIE
tcImprove lie tcImprove lie
| null nfdss = returnTc () = tcGetInstEnv `thenNF_Tc` \ inst_env ->
| otherwise = iterImprove nfdss let
where
nfdss, clas_nfdss, inst_nfdss, ip_nfdss :: [(TcTyVarSet, Name, [FunDep TcType])] nfdss, clas_nfdss, inst_nfdss, ip_nfdss :: [(TcTyVarSet, Name, [FunDep TcType])]
nfdss = ip_nfdss ++ clas_nfdss ++ inst_nfdss nfdss = ip_nfdss ++ clas_nfdss ++ inst_nfdss
cfdss :: [(Class, [FunDep TcType])] cfdss :: [(Class, [FunDep TcType])]
cfdss = getFunDepsOfLIE lie cfdss = getFunDepsOfLIE lie
clas_nfdss = map (\(c, fds) -> (emptyVarSet, className c, fds)) cfdss clas_nfdss = [(emptyVarSet, className c, fds) | (c,fds) <- cfdss]
classes = nub (map fst cfdss)
inst_nfdss = [ (free, className c, instantiateFdClassTys c ts)
| c <- classes,
(free, ts, i) <- classInstEnv inst_env c
]
ip_nfdss = [(emptyVarSet, n, [([], [ty])]) | (n,ty) <- getIPsOfLIE lie]
{- Example: we have
class C a b c | a->b where ...
instance C Int Bool c
Given the LIE FD C (Int->t)
we get clas_nfdss = [({}, C, [Int->t, t->Int])
inst_nfdss = [({c}, C, [Int->Bool, Bool->Int])]
Another way would be to flatten a bit
we get clas_nfdss = [({}, C, Int->t), ({}, C, t->Int)]
inst_nfdss = [({c}, C, Int->Bool), ({c}, C, Bool->Int)]
iterImprove then matches up the C and Int, and unifies t <-> Bool
-}
in
iterImprove nfdss
classes = nub (map fst cfdss)
inst_nfdss = concatMap getInstNfdssOf classes
ips = getIPsOfLIE lie
ip_nfdss = map (\(n, ty) -> (emptyVarSet, n, [([], [ty])])) ips
{- Example: we have
class C a b c | a->b where ...
instance C Int Bool c
Given the LIE FD C (Int->t)
we get clas_nfdss = [({}, C, [Int->t, t->Int])
inst_nfdss = [({c}, C, [Int->Bool, Bool->Int])]
Another way would be to flatten a bit
we get clas_nfdss = [({}, C, Int->t), ({}, C, t->Int)]
inst_nfdss = [({c}, C, Int->Bool), ({c}, C, Bool->Int)]
iterImprove then matches up the C and Int, and unifies t <-> Bool
-}
getInstNfdssOf :: Class -> [(TcTyVarSet, Name, [FunDep TcType])]
getInstNfdssOf clas
= [ (free, nm, instantiateFdClassTys clas ts)
| (free, ts, i) <- classInstEnv clas
]
where
nm = className clas
iterImprove :: [(VarSet, Name, [FunDep TcType])] -> TcM s () iterImprove :: [(VarSet, Name, [FunDep TcType])] -> TcM s ()
iterImprove [] = returnTc () iterImprove [] = returnTc ()
......
ghc/compiler/typecheck/TcInstUtil.lhs
+ 8
− 33
View file @ 7bb06950
...@@ -8,7 +8,7 @@ The bits common to TcInstDcls and TcDeriv. ...@@ -8,7 +8,7 @@ The bits common to TcInstDcls and TcDeriv.
\begin{code} \begin{code}
module TcInstUtil ( module TcInstUtil (
InstInfo(..), InstInfo(..),
buildInstanceEnvs, buildInstanceEnv,
classDataCon classDataCon
) where ) where
...@@ -18,12 +18,10 @@ import RnHsSyn ( RenamedMonoBinds, RenamedSig ) ...@@ -18,12 +18,10 @@ import RnHsSyn ( RenamedMonoBinds, RenamedSig )
import CmdLineOpts ( opt_AllowOverlappingInstances ) import CmdLineOpts ( opt_AllowOverlappingInstances )
import TcMonad import TcMonad
import Inst ( InstanceMapper ) import TcEnv ( InstEnv, emptyInstEnv, addToInstEnv )
import Bag ( bagToList, Bag ) import Bag ( bagToList, Bag )
import Class ( Class ) import Class ( Class )
import Var ( TyVar, Id, idName ) import Var ( TyVar, Id, idName )
import InstEnv ( InstEnv, emptyInstEnv, addToInstEnv )
import Maybes ( MaybeErr(..), mkLookupFunDef ) import Maybes ( MaybeErr(..), mkLookupFunDef )
import Name ( getSrcLoc, nameModule, isLocallyDefined ) import Name ( getSrcLoc, nameModule, isLocallyDefined )
import SrcLoc ( SrcLoc ) import SrcLoc ( SrcLoc )
...@@ -77,32 +75,9 @@ classDataCon clas = case tyConDataCons (classTyCon clas) of ...@@ -77,32 +75,9 @@ classDataCon clas = case tyConDataCons (classTyCon clas) of
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
buildInstanceEnvs :: Bag InstInfo buildInstanceEnv :: Bag InstInfo -> NF_TcM s InstEnv
-> NF_TcM s InstanceMapper
buildInstanceEnvs info
= let
i_uniq :: InstInfo -> Unique
i_uniq (InstInfo c _ _ _ _ _ _ _) = getUnique c
info_by_class = equivClassesByUniq i_uniq (bagToList info)
in
mapNF_Tc buildInstanceEnv info_by_class `thenNF_Tc` \ inst_env_entries ->
let
class_lookup_fn = mkLookupFunDef (==) inst_env_entries emptyInstEnv
in
returnNF_Tc class_lookup_fn
\end{code}
\begin{code} buildInstanceEnv info = foldrNF_Tc addClassInstance emptyInstEnv (bagToList info)
buildInstanceEnv :: [InstInfo] -- Non-empty, and all for same class
-> NF_TcM s (Class, InstEnv)
buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _) : _)
= foldrNF_Tc addClassInstance
emptyInstEnv
inst_infos `thenNF_Tc` \ class_inst_env ->
returnNF_Tc (clas, class_inst_env)
\end{code} \end{code}
@addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@ @addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@
...@@ -118,16 +93,16 @@ addClassInstance ...@@ -118,16 +93,16 @@ addClassInstance
addClassInstance addClassInstance
(InstInfo clas inst_tyvars inst_tys _ (InstInfo clas inst_tyvars inst_tys _
dfun_id _ src_loc _) dfun_id _ src_loc _)
class_inst_env inst_env
= -- Add the instance to the class's instance environment = -- Add the instance to the class's instance environment
case addToInstEnv opt_AllowOverlappingInstances case addToInstEnv opt_AllowOverlappingInstances
class_inst_env inst_tyvars inst_tys dfun_id of inst_env clas inst_tyvars inst_tys dfun_id of
Failed (tys', dfun_id') -> addErrTc (dupInstErr clas (inst_tys, dfun_id) Failed (tys', dfun_id') -> addErrTc (dupInstErr clas (inst_tys, dfun_id)
(tys', dfun_id')) (tys', dfun_id'))
`thenNF_Tc_` `thenNF_Tc_`
returnNF_Tc class_inst_env returnNF_Tc inst_env
Succeeded class_inst_env' -> returnNF_Tc class_inst_env' Succeeded inst_env' -> returnNF_Tc inst_env'
\end{code} \end{code}
\begin{code} \begin{code}
......
ghc/compiler/typecheck/TcModule.lhs
+ 11
− 19
View file @ 7bb06950
...@@ -27,7 +27,7 @@ import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds ) ...@@ -27,7 +27,7 @@ import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds )
import TcDefaults ( tcDefaults ) import TcDefaults ( tcDefaults )
import TcEnv ( tcExtendGlobalValEnv, tcExtendTypeEnv, import TcEnv ( tcExtendGlobalValEnv, tcExtendTypeEnv,
getEnvTyCons, getEnvClasses, tcLookupValueByKeyMaybe, getEnvTyCons, getEnvClasses, tcLookupValueByKeyMaybe,
explicitLookupValueByKey, tcSetValueEnv, explicitLookupValueByKey, tcSetValueEnv, tcSetInstEnv,
initEnv, initEnv,
ValueEnv, TcTyThing(..) ValueEnv, TcTyThing(..)
) )
...@@ -36,7 +36,7 @@ import TcRules ( tcRules ) ...@@ -36,7 +36,7 @@ import TcRules ( tcRules )
import TcForeign ( tcForeignImports, tcForeignExports ) import TcForeign ( tcForeignImports, tcForeignExports )
import TcIfaceSig ( tcInterfaceSigs ) import TcIfaceSig ( tcInterfaceSigs )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
import TcInstUtil ( buildInstanceEnvs, classDataCon, InstInfo ) import TcInstUtil ( buildInstanceEnv, InstInfo )
import TcSimplify ( tcSimplifyTop ) import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls ) import TcTyClsDecls ( tcTyAndClassDecls )
import TcTyDecls ( mkImplicitDataBinds ) import TcTyDecls ( mkImplicitDataBinds )
...@@ -154,26 +154,19 @@ tcModule rn_name_supply fixities ...@@ -154,26 +154,19 @@ tcModule rn_name_supply fixities
-- unf_env is also used to get the pragam info -- unf_env is also used to get the pragam info
-- for imported dfuns and default methods -- for imported dfuns and default methods
-- The knot for instance information. This isn't used at all
-- till we type-check value declarations
fixTc ( \ ~(rec_inst_mapper, _, _, _) ->
-- Type-check the type and class decls -- Type-check the type and class decls
tcTyAndClassDecls unf_env rec_inst_mapper decls `thenTc` \ env -> tcTyAndClassDecls unf_env decls `thenTc` \ env ->
-- Typecheck the instance decls, includes deriving -- Typecheck the instance decls, includes deriving
tcSetEnv env ( tcSetEnv env $
tcInstDecls1 unf_env decls mod_name fixities rn_name_supply
) `thenTc` \ (inst_info, deriv_binds) -> tcInstDecls1 unf_env decls
mod_name fixities
buildInstanceEnvs inst_info `thenNF_Tc` \ inst_mapper -> rn_name_supply `thenTc` \ (inst_info, deriv_binds) ->
returnTc (inst_mapper, env, inst_info, deriv_binds)
-- End of inner fix loop
) `thenTc` \ (_, env, inst_info, deriv_binds) ->
tcSetEnv env ( buildInstanceEnv inst_info `thenNF_Tc` \ inst_env ->
tcSetInstEnv inst_env $
let let
tycons = getEnvTyCons env tycons = getEnvTyCons env
classes = getEnvClasses env classes = getEnvClasses env
...@@ -296,7 +289,6 @@ tcModule rn_name_supply fixities ...@@ -296,7 +289,6 @@ tcModule rn_name_supply fixities
tc_rules = rules', tc_rules = rules',
tc_env = really_final_env tc_env = really_final_env
})) }))
)
-- End of outer fix loop -- End of outer fix loop
) `thenTc` \ (final_env, stuff) -> ) `thenTc` \ (final_env, stuff) ->
......
ghc/compiler/typecheck/TcSimplify.lhs
+ 61
− 56
View file @ 7bb06950
...@@ -143,18 +143,19 @@ import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..), ...@@ -143,18 +143,19 @@ import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
mkLIE, emptyLIE, unitLIE, consLIE, plusLIE, mkLIE, emptyLIE, unitLIE, consLIE, plusLIE,
lieToList, listToLIE lieToList, listToLIE
) )
import TcEnv ( tcGetGlobalTyVars ) import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv,
InstEnv, lookupInstEnv, InstLookupResult(..)
)
import TcType ( TcType, TcTyVarSet, typeToTcType ) import TcType ( TcType, TcTyVarSet, typeToTcType )
import TcUnify ( unifyTauTy ) import TcUnify ( unifyTauTy )
import Id ( idType ) import Id ( idType )
import Class ( Class, classBigSig, classInstEnv ) import Class ( Class, classBigSig )
import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass ) import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass )
import Type ( Type, ThetaType, TauType, ClassContext, import Type ( Type, ThetaType, TauType, ClassContext,
mkTyVarTy, getTyVar, mkTyVarTy, getTyVar,
isTyVarTy, splitSigmaTy, tyVarsOfTypes isTyVarTy, splitSigmaTy, tyVarsOfTypes
) )
import InstEnv ( InstEnv, lookupInstEnv, InstEnvResult(..) )
import Subst ( mkTopTyVarSubst, substClasses ) import Subst ( mkTopTyVarSubst, substClasses )
import PprType ( pprConstraint ) import PprType ( pprConstraint )
import TysWiredIn ( unitTy ) import TysWiredIn ( unitTy )
...@@ -840,12 +841,11 @@ a,b,c are type variables. This is required for the context of ...@@ -840,12 +841,11 @@ a,b,c are type variables. This is required for the context of
instance declarations. instance declarations.
\begin{code} \begin{code}
tcSimplifyThetas :: (Class -> InstEnv) -- How to find the InstEnv tcSimplifyThetas :: ClassContext -- Wanted
-> ClassContext -- Wanted
-> TcM s ClassContext -- Needed -> TcM s ClassContext -- Needed
tcSimplifyThetas inst_mapper wanteds tcSimplifyThetas wanteds
= reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds -> = reduceSimple [] wanteds `thenNF_Tc` \ irreds ->
let let
-- For multi-param Haskell, check that the returned dictionaries -- For multi-param Haskell, check that the returned dictionaries
-- don't have any of the form (C Int Bool) for which -- don't have any of the form (C Int Bool) for which
...@@ -874,7 +874,7 @@ tcSimplifyCheckThetas :: ClassContext -- Given ...@@ -874,7 +874,7 @@ tcSimplifyCheckThetas :: ClassContext -- Given
-> TcM s () -> TcM s ()
tcSimplifyCheckThetas givens wanteds tcSimplifyCheckThetas givens wanteds
= reduceSimple classInstEnv givens wanteds `thenNF_Tc` \ irreds -> = reduceSimple givens wanteds `thenNF_Tc` \ irreds ->
if null irreds then if null irreds then
returnTc () returnTc ()
else else
...@@ -888,40 +888,38 @@ type AvailsSimple = FiniteMap (Class,[Type]) Bool ...@@ -888,40 +888,38 @@ type AvailsSimple = FiniteMap (Class,[Type]) Bool
-- True => irreducible -- True => irreducible
-- False => given, or can be derived from a given or from an irreducible -- False => given, or can be derived from a given or from an irreducible
reduceSimple :: (Class -> InstEnv) reduceSimple :: ClassContext -- Given
-> ClassContext -- Given
-> ClassContext -- Wanted -> ClassContext -- Wanted
-> NF_TcM s ClassContext -- Irreducible -> NF_TcM s ClassContext -- Irreducible
reduceSimple inst_mapper givens wanteds reduceSimple givens wanteds
= reduce_simple (0,[]) inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' -> = reduce_simple (0,[]) givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
returnNF_Tc [ct | (ct,True) <- fmToList givens_fm'] returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
where where
givens_fm = foldl addNonIrred emptyFM givens givens_fm = foldl addNonIrred emptyFM givens
reduce_simple :: (Int,ClassContext) -- Stack reduce_simple :: (Int,ClassContext) -- Stack
-> (Class -> InstEnv)
-> AvailsSimple -> AvailsSimple
-> ClassContext -> ClassContext
-> NF_TcM s AvailsSimple -> NF_TcM s AvailsSimple
reduce_simple (n,stack) inst_mapper avails wanteds reduce_simple (n,stack) avails wanteds
= go avails wanteds = go avails wanteds
where where
go avails [] = returnNF_Tc avails go avails [] = returnNF_Tc avails
go avails (w:ws) = reduce_simple_help (n+1,w:stack) inst_mapper avails w `thenNF_Tc` \ avails' -> go avails (w:ws) = reduce_simple_help (n+1,w:stack) avails w `thenNF_Tc` \ avails' ->
go avails' ws go avails' ws
reduce_simple_help stack inst_mapper givens wanted@(clas,tys) reduce_simple_help stack givens wanted@(clas,tys)
| wanted `elemFM` givens | wanted `elemFM` givens
= returnNF_Tc givens = returnNF_Tc givens
| otherwise | otherwise
= lookupSimpleInst (inst_mapper clas) clas tys `thenNF_Tc` \ maybe_theta -> = lookupSimpleInst clas tys `thenNF_Tc` \ maybe_theta ->
case maybe_theta of case maybe_theta of
Nothing -> returnNF_Tc (addIrred givens wanted) Nothing -> returnNF_Tc (addIrred givens wanted)
Just theta -> reduce_simple stack inst_mapper (addNonIrred givens wanted) theta Just theta -> reduce_simple stack (addNonIrred givens wanted) theta
addIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple addIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
addIrred givens ct@(clas,tys) addIrred givens ct@(clas,tys)
...@@ -1265,45 +1263,52 @@ addTopInstanceErr dict ...@@ -1265,45 +1263,52 @@ addTopInstanceErr dict
where where
(tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
-- The error message when we don't find a suitable instance
-- is complicated by the fact that sometimes this is because
-- there is no instance, and sometimes it's because there are
-- too many instances (overlap). See the comments in TcEnv.lhs
-- with the InstEnv stuff.
addNoInstanceErr str givens dict addNoInstanceErr str givens dict
= addInstErrTcM (instLoc dict) (tidy_env, doc) = tcGetInstEnv `thenNF_Tc` \ inst_env ->
where let
doc = vcat [herald <+> quotes (pprInst tidy_dict), doc = vcat [herald <+> quotes (pprInst tidy_dict),
nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens, nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens,
ambig_doc, ambig_doc,
ptext SLIT("Probable fix:"), ptext SLIT("Probable fix:"),
nest 4 fix1, nest 4 fix1,
nest 4 fix2] nest 4 fix2]
herald = ptext SLIT("Could not") <+> unambig_doc <+> ptext SLIT("deduce") herald = ptext SLIT("Could not") <+> unambig_doc <+> ptext SLIT("deduce")
unambig_doc | ambig_overlap = ptext SLIT("unambiguously") unambig_doc | ambig_overlap = ptext SLIT("unambiguously")
| otherwise = empty | otherwise = empty
ambig_doc ambig_doc
| not ambig_overlap = empty | not ambig_overlap = empty
| otherwise | otherwise
= vcat [ptext SLIT("The choice of (overlapping) instance declaration"), = vcat [ptext SLIT("The choice of (overlapping) instance declaration"),
nest 4 (ptext SLIT("depends on the instantiation of") <+> nest 4 (ptext SLIT("depends on the instantiation of") <+>
quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst tidy_dict))))] quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst tidy_dict))))]
fix1 = sep [ptext SLIT("Add") <+> quotes (pprInst tidy_dict), fix1 = sep [ptext SLIT("Add") <+> quotes (pprInst tidy_dict),
ptext SLIT("to the") <+> str] ptext SLIT("to the") <+> str]
fix2 | isTyVarDict dict || ambig_overlap fix2 | isTyVarDict dict || ambig_overlap
= empty = empty
| otherwise | otherwise
= ptext SLIT("Or add an instance declaration for") <+> quotes (pprInst tidy_dict) = ptext SLIT("Or add an instance declaration for") <+> quotes (pprInst tidy_dict)
(tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens) (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
-- Checks for the ambiguous case when we have overlapping instances -- Checks for the ambiguous case when we have overlapping instances
ambig_overlap | isClassDict dict ambig_overlap | isClassDict dict
= case lookupInstEnv (classInstEnv clas) tys of = case lookupInstEnv inst_env clas tys of
NoMatch ambig -> ambig NoMatch ambig -> ambig
other -> False other -> False
| otherwise = False | otherwise = False
where where
(clas,tys) = getDictClassTys dict (clas,tys) = getDictClassTys dict
in
addInstErrTcM (instLoc dict) (tidy_env, doc)
-- Used for the ...Thetas variants; all top level -- Used for the ...Thetas variants; all top level
addNoInstErr (c,ts) addNoInstErr (c,ts)
......
ghc/compiler/typecheck/TcTyClsDecls.lhs
+ 13
− 15
View file @ 7bb06950
...@@ -20,7 +20,6 @@ import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name ) ...@@ -20,7 +20,6 @@ import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name )
import BasicTypes ( RecFlag(..), NewOrData(..), Arity ) import BasicTypes ( RecFlag(..), NewOrData(..), Arity )
import TcMonad import TcMonad
import Inst ( InstanceMapper )
import TcClassDcl ( kcClassDecl, tcClassDecl1 ) import TcClassDcl ( kcClassDecl, tcClassDecl1 )
import TcEnv ( ValueEnv, TcTyThing(..), import TcEnv ( ValueEnv, TcTyThing(..),
tcExtendTypeEnv, getEnvAllTyCons tcExtendTypeEnv, getEnvAllTyCons
...@@ -54,22 +53,22 @@ import UniqFM ( listToUFM, lookupUFM ) ...@@ -54,22 +53,22 @@ import UniqFM ( listToUFM, lookupUFM )
The main function The main function
~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~
\begin{code} \begin{code}
tcTyAndClassDecls :: ValueEnv -> InstanceMapper -- Knot tying stuff tcTyAndClassDecls :: ValueEnv -- Knot tying stuff
-> [RenamedHsDecl] -> [RenamedHsDecl]
-> TcM s TcEnv -> TcM s TcEnv
tcTyAndClassDecls unf_env inst_mapper decls tcTyAndClassDecls unf_env decls
= sortByDependency decls `thenTc` \ groups -> = sortByDependency decls `thenTc` \ groups ->
tcGroups unf_env inst_mapper groups tcGroups unf_env groups
tcGroups unf_env inst_mapper [] tcGroups unf_env []
= tcGetEnv `thenNF_Tc` \ env -> = tcGetEnv `thenNF_Tc` \ env ->
returnTc env returnTc env
tcGroups unf_env inst_mapper (group:groups) tcGroups unf_env (group:groups)
= tcGroup unf_env inst_mapper group `thenTc` \ env -> = tcGroup unf_env group `thenTc` \ env ->
tcSetEnv env $ tcSetEnv env $
tcGroups unf_env inst_mapper groups tcGroups unf_env groups
\end{code} \end{code}
Dealing with a group Dealing with a group
...@@ -79,8 +78,8 @@ The knot-tying parameters: @rec_tyclss@ is an alist mapping @Name@s to ...@@ -79,8 +78,8 @@ The knot-tying parameters: @rec_tyclss@ is an alist mapping @Name@s to
@TcTyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s. @TcTyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
\begin{code} \begin{code}
tcGroup :: ValueEnv -> InstanceMapper -> SCC RenamedTyClDecl -> TcM s TcEnv tcGroup :: ValueEnv -> SCC RenamedTyClDecl -> TcM s TcEnv
tcGroup unf_env inst_mapper scc tcGroup unf_env scc
= -- Do kind checking = -- Do kind checking
mapNF_Tc getTyBinding1 decls `thenNF_Tc` \ ty_env_stuff1 -> mapNF_Tc getTyBinding1 decls `thenNF_Tc` \ ty_env_stuff1 ->
tcExtendTypeEnv ty_env_stuff1 (mapTc kcDecl decls) `thenTc_` tcExtendTypeEnv ty_env_stuff1 (mapTc kcDecl decls) `thenTc_`
...@@ -97,8 +96,7 @@ tcGroup unf_env inst_mapper scc ...@@ -97,8 +96,7 @@ tcGroup unf_env inst_mapper scc
-- Do type checking -- Do type checking
mapNF_Tc (getTyBinding2 rec_env) ty_env_stuff1 `thenNF_Tc` \ ty_env_stuff2 -> mapNF_Tc (getTyBinding2 rec_env) ty_env_stuff1 `thenNF_Tc` \ ty_env_stuff2 ->
tcExtendTypeEnv ty_env_stuff2 $ tcExtendTypeEnv ty_env_stuff2 $
mapTc (tcDecl is_rec_group unf_env inst_mapper rec_vrcs) decls mapTc (tcDecl is_rec_group unf_env rec_vrcs) decls `thenTc` \ tyclss ->
`thenTc` \ tyclss ->
tcGetEnv `thenTc` \ env -> tcGetEnv `thenTc` \ env ->
returnTc (tyclss, env) returnTc (tyclss, env)
...@@ -126,13 +124,13 @@ kcDecl decl ...@@ -126,13 +124,13 @@ kcDecl decl
kcTyDecl decl kcTyDecl decl
tcDecl :: RecFlag -- True => recursive group tcDecl :: RecFlag -- True => recursive group
-> ValueEnv -> InstanceMapper -> FiniteMap Name ArgVrcs -> ValueEnv -> FiniteMap Name ArgVrcs
-> RenamedTyClDecl -> TcM s (Name, TcTyThing) -> RenamedTyClDecl -> TcM s (Name, TcTyThing)
tcDecl is_rec_group unf_env inst_mapper vrcs_env decl tcDecl is_rec_group unf_env vrcs_env decl
= tcAddDeclCtxt decl $ = tcAddDeclCtxt decl $
if isClassDecl decl then if isClassDecl decl then
tcClassDecl1 unf_env inst_mapper vrcs_env decl tcClassDecl1 unf_env vrcs_env decl
else else
tcTyDecl is_rec_group vrcs_env decl tcTyDecl is_rec_group vrcs_env decl
......
ghc/compiler/types/Class.lhs
+ 2
− 7
View file @ 7bb06950
...@@ -9,14 +9,13 @@ module Class ( ...@@ -9,14 +9,13 @@ module Class (
mkClass, classTyVars, mkClass, classTyVars,
classKey, className, classSelIds, classTyCon, classKey, className, classSelIds, classTyCon,
classBigSig, classExtraBigSig, classInstEnv, classTvsFds classBigSig, classExtraBigSig, classTvsFds
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
import {-# SOURCE #-} TyCon ( TyCon ) import {-# SOURCE #-} TyCon ( TyCon )
import {-# SOURCE #-} TypeRep ( Type ) import {-# SOURCE #-} TypeRep ( Type )
import {-# SOURCE #-} InstEnv ( InstEnv )
import Var ( Id, TyVar ) import Var ( Id, TyVar )
import Name ( NamedThing(..), Name ) import Name ( NamedThing(..), Name )
...@@ -49,8 +48,6 @@ data Class ...@@ -49,8 +48,6 @@ data Class
classOpStuff :: [ClassOpItem], -- Ordered by tag classOpStuff :: [ClassOpItem], -- Ordered by tag
classInstEnv :: InstEnv, -- All the instances of this class
classTyCon :: TyCon -- The data type constructor for dictionaries classTyCon :: TyCon -- The data type constructor for dictionaries
} -- of this class } -- of this class
...@@ -74,11 +71,10 @@ mkClass :: Name -> [TyVar] ...@@ -74,11 +71,10 @@ mkClass :: Name -> [TyVar]
-> [(Class,[Type])] -> [Id] -> [(Class,[Type])] -> [Id]
-> [(Id, Id, Bool)] -> [(Id, Id, Bool)]
-> TyCon -> TyCon
-> InstEnv
-> Class -> Class
mkClass name tyvars fds super_classes superdict_sels mkClass name tyvars fds super_classes superdict_sels
op_stuff tycon class_insts op_stuff tycon
= Class { classKey = getUnique name, = Class { classKey = getUnique name,
className = name, className = name,
classTyVars = tyvars, classTyVars = tyvars,
...@@ -86,7 +82,6 @@ mkClass name tyvars fds super_classes superdict_sels ...@@ -86,7 +82,6 @@ mkClass name tyvars fds super_classes superdict_sels
classSCTheta = super_classes, classSCTheta = super_classes,
classSCSels = superdict_sels, classSCSels = superdict_sels,
classOpStuff = op_stuff, classOpStuff = op_stuff,
classInstEnv = class_insts,
classTyCon = tycon } classTyCon = tycon }
\end{code} \end{code}
......
ghc/compiler/types/InstEnv.hi-boot deleted 100644 → 0
+ 0
− 6
View file @ ec459c23
_interface_ InstEnv 1
_exports_
InstEnv InstEnv ;
_declarations_
1 data InstEnv ;
ghc/compiler/types/InstEnv.hi-boot-5 deleted 100644 → 0
+ 0
− 4
View file @ ec459c23
__interface InstEnv 1 0 where
__export InstEnv InstEnv ;
1 data InstEnv ;
ghc/compiler/types/InstEnv.lhs deleted 100644 → 0
+ 0
− 243
View file @ ec459c23
%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section{Class Instance environments}
\begin{code}
module InstEnv (
InstEnv, emptyInstEnv, addToInstEnv,
lookupInstEnv, InstEnvResult(..)
) where
#include "HsVersions.h"
import Var ( TyVar, Id )
import VarSet
import VarEnv ( TyVarSubstEnv )
import Type ( Type, tyVarsOfTypes )
import Unify ( unifyTyListsX, matchTys )
import Outputable
import Maybes
\end{code}
%************************************************************************
%* *
\section{InstEnv}
%* *
%************************************************************************
\begin{code}
type InstEnv = [(TyVarSet, [Type], Id)]
\end{code}
In some InstEnvs overlap is prohibited; that is, no pair of templates unify.
In others, overlap is permitted, but only in such a way that one can make
a unique choice when looking up. That is, overlap is only permitted if
one template matches the other, or vice versa. So this is ok:
[a] [Int]
but this is not
(Int,a) (b,Int)
If overlap is permitted, the list is kept most specific first, so that
the first lookup is the right choice.
For now we just use association lists.
\subsection{Avoiding a problem with overlapping}
Consider this little program:
\begin{pseudocode}
class C a where c :: a
class C a => D a where d :: a
instance C Int where c = 17
instance D Int where d = 13
instance C a => C [a] where c = [c]
instance ({- C [a], -} D a) => D [a] where d = c
instance C [Int] where c = [37]
main = print (d :: [Int])
\end{pseudocode}
What do you think `main' prints (assuming we have overlapping instances, and
all that turned on)? Well, the instance for `D' at type `[a]' is defined to
be `c' at the same type, and we've got an instance of `C' at `[Int]', so the
answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because
the `C [Int]' instance is more specific).
Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong. That
was easy ;-) Let's just consult hugs for good measure. Wait - if I use old
hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it
doesn't even compile! What's going on!?
What hugs complains about is the `D [a]' instance decl.
\begin{pseudocode}
ERROR "mj.hs" (line 10): Cannot build superclass instance
*** Instance : D [a]
*** Context supplied : D a
*** Required superclass : C [a]
\end{pseudocode}
You might wonder what hugs is complaining about. It's saying that you
need to add `C [a]' to the context of the `D [a]' instance (as appears
in comments). But there's that `C [a]' instance decl one line above
that says that I can reduce the need for a `C [a]' instance to the
need for a `C a' instance, and in this case, I already have the
necessary `C a' instance (since we have `D a' explicitly in the
context, and `C' is a superclass of `D').
Unfortunately, the above reasoning indicates a premature commitment to the
generic `C [a]' instance. I.e., it prematurely rules out the more specific
instance `C [Int]'. This is the mistake that ghc-4.06 makes. The fix is to
add the context that hugs suggests (uncomment the `C [a]'), effectively
deferring the decision about which instance to use.
Now, interestingly enough, 4.04 has this same bug, but it's covered up
in this case by a little known `optimization' that was disabled in
4.06. Ghc-4.04 silently inserts any missing superclass context into
an instance declaration. In this case, it silently inserts the `C
[a]', and everything happens to work out.
(See `basicTypes/MkId:mkDictFunId' for the code in question. Search for
`Mark Jones', although Mark claims no credit for the `optimization' in
question, and would rather it stopped being called the `Mark Jones
optimization' ;-)
So, what's the fix? I think hugs has it right. Here's why. Let's try
something else out with ghc-4.04. Let's add the following line:
d' :: D a => [a]
d' = c
Everyone raise their hand who thinks that `d :: [Int]' should give a
different answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The
`optimization' only applies to instance decls, not to regular
bindings, giving inconsistent behavior.
Old hugs had this same bug. Here's how we fixed it: like GHC, the
list of instances for a given class is ordered, so that more specific
instances come before more generic ones. For example, the instance
list for C might contain:
..., C Int, ..., C a, ...
When we go to look for a `C Int' instance we'll get that one first.
But what if we go looking for a `C b' (`b' is unconstrained)? We'll
pass the `C Int' instance, and keep going. But if `b' is
unconstrained, then we don't know yet if the more specific instance
will eventually apply. GHC keeps going, and matches on the generic `C
a'. The fix is to, at each step, check to see if there's a reverse
match, and if so, abort the search. This prevents hugs from
prematurely chosing a generic instance when a more specific one
exists.
--Jeff
\begin{code}
emptyInstEnv :: InstEnv
emptyInstEnv = []
isEmptyInstEnv env = null env
\end{code}
@lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since
the env is kept ordered, the first match must be the only one. The
thing we are looking up can have an arbitrary "flexi" part.
\begin{code}
lookupInstEnv :: InstEnv -- The envt
-> [Type] -- Key
-> InstEnvResult
data InstEnvResult
= FoundInst -- There is a (template,substitution) pair
-- that makes the template match the key,
-- and no template is an instance of the key
TyVarSubstEnv Id
| NoMatch Bool -- Boolean is true iff there is at least one
-- template that matches the key.
-- (but there are other template(s) that are
-- instances of the key, so we don't report
-- FoundInst)
-- The NoMatch True case happens when we look up
-- Foo [a]
-- in an InstEnv that has entries for
-- Foo [Int]
-- Foo [b]
-- Then which we choose would depend on the way in which 'a'
-- is instantiated. So we say there is no match, but identify
-- it as ambiguous case in the hope of giving a better error msg.
-- See the notes above from Jeff Lewis
lookupInstEnv env key
= find env
where
key_vars = tyVarsOfTypes key
find [] = NoMatch False
find ((tpl_tyvars, tpl, val) : rest)
= case matchTys tpl_tyvars tpl key of
Nothing ->
case matchTys key_vars key tpl of
Nothing -> find rest
Just (_, _) -> NoMatch (any_match rest)
Just (subst, leftovers) -> ASSERT( null leftovers )
FoundInst subst val
any_match rest = or [ maybeToBool (matchTys tvs tpl key)
| (tvs,tpl,_) <- rest
]
\end{code}
@addToInstEnv@ extends a @InstEnv@, checking for overlaps.
A boolean flag controls overlap reporting.
True => overlap is permitted, but only if one template matches the other;
not if they unify but neither is
\begin{code}
addToInstEnv :: Bool -- True <=> overlap permitted
-> InstEnv -- Envt
-> [TyVar] -> [Type] -> Id -- New item
-> MaybeErr InstEnv -- Success...
([Type], Id) -- Failure: Offending overlap
addToInstEnv overlap_ok env ins_tvs ins_tys value
= insert env
where
ins_tv_set = mkVarSet ins_tvs
ins_item = (ins_tv_set, ins_tys, value)
insert [] = returnMaB [ins_item]
insert env@(cur_item@(tpl_tvs, tpl_tys, val) : rest)
-- FAIL if:
-- (a) they are the same, or
-- (b) they unify, and any sort of overlap is prohibited,
-- (c) they unify but neither is more specific than t'other
| identical
|| (unifiable && not overlap_ok)
|| (unifiable && not (ins_item_more_specific || cur_item_more_specific))
= failMaB (tpl_tys, val)
-- New item is an instance of current item, so drop it here
| ins_item_more_specific = returnMaB (ins_item : env)
-- Otherwise carry on
| otherwise = insert rest `thenMaB` \ rest' ->
returnMaB (cur_item : rest')
where
unifiable = maybeToBool (unifyTyListsX (ins_tv_set `unionVarSet` tpl_tvs) tpl_tys ins_tys)
ins_item_more_specific = maybeToBool (matchTys tpl_tvs tpl_tys ins_tys)
cur_item_more_specific = maybeToBool (matchTys ins_tv_set ins_tys tpl_tys)
identical = ins_item_more_specific && cur_item_more_specific
\end{code}
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment