Commit 4287edeb authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Cross-module consistency check for family instances

parent 366e8db0
......@@ -238,9 +238,12 @@ loadInterface doc_str mod from
; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface)
; let { final_iface = iface { mi_decls = panic "No mi_decls in PIT",
mi_insts = panic "No mi_insts in PIT",
mi_rules = panic "No mi_rules in PIT" } }
; let { final_iface = iface {
mi_decls = panic "No mi_decls in PIT",
mi_insts = panic "No mi_insts in PIT",
mi_fam_insts = panic "No mi_fam_insts in PIT",
mi_rules = panic "No mi_rules in PIT"
} }
; updateEps_ $ \ eps ->
eps {
......@@ -252,6 +255,15 @@ loadInterface doc_str mod from
new_eps_insts,
eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)
new_eps_fam_insts,
eps_mod_fam_inst_env
= let
fam_inst_env =
extendFamInstEnvList emptyFamInstEnv
new_eps_fam_insts
in
extendModuleEnv (eps_mod_fam_inst_env eps)
mod
fam_inst_env,
eps_stats = addEpsInStats (eps_stats eps)
(length new_eps_decls)
(length new_eps_insts) (length new_eps_rules) }
......@@ -456,6 +468,8 @@ initExternalPackageState
eps_fam_inst_env = emptyFamInstEnv,
eps_rule_base = mkRuleBase builtinRules,
-- Initialise the EPS rule pool with the built-in rules
eps_mod_fam_inst_env
= emptyModuleEnv,
eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
, n_insts_in = 0, n_insts_out = 0
, n_rules_in = length builtinRules, n_rules_out = 0 }
......
......@@ -440,12 +440,12 @@ data ModIface
-- Should be able to construct ModDetails from mi_decls in ModIface
data ModDetails
= ModDetails {
-- The next three fields are created by the typechecker
md_exports :: [AvailInfo],
md_types :: !TypeEnv,
md_fam_insts :: ![FamInst], -- Cached value extracted from md_types
md_insts :: ![Instance], -- Dfun-ids for the instances in this module
md_rules :: ![CoreRule] -- Domain may include Ids from other modules
-- The next two fields are created by the typechecker
md_exports :: [AvailInfo],
md_types :: !TypeEnv,
md_insts :: ![Instance], -- Dfun-ids for the instances in this module
md_fam_insts :: ![FamInst],
md_rules :: ![CoreRule] -- Domain may include Ids from other modules
}
emptyModDetails = ModDetails { md_types = emptyTypeEnv,
......@@ -1008,6 +1008,9 @@ data ExternalPackageState
eps_fam_inst_env :: !PackageFamInstEnv,-- Ditto FamInstEnv
eps_rule_base :: !PackageRuleBase, -- Ditto RuleEnv
eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- identifies family
-- instances of each mod
eps_stats :: !EpsStats
}
......
......@@ -2,7 +2,7 @@ The @FamInst@ type: family instance heads
\begin{code}
module FamInst (
tcExtendLocalFamInstEnv
checkFamInstConsistency, tcExtendLocalFamInstEnv
) where
#include "HsVersions.h"
......@@ -15,21 +15,103 @@ import TcRnMonad
import TyCon
import Type
import Name
import Module
import SrcLoc
import Outputable
import FiniteMap
import Maybe
import Monad
\end{code}
%************************************************************************
%* *
Extending the family instance environment
Optimised overlap checking for family instances
%* *
%************************************************************************
For any two family instance modules that we import directly or indirectly, we
check whether the instances in the two modules are consistent, *unless* we can
be certain that the instances of the two modules have already been checked for
consistency during the compilation of modules that we import.
How do we know which pairs of modules have already been checked? Any pair of
modules where both modules occur in the `HscTypes.dep_finsts' set (of the
`HscTypes.Dependencies') of one of our directly imported modules must have
already been checked. Everything else, we check now. (So that we can be
certain that the modules in our `HscTypes.dep_finsts' are consistent.)
\begin{code}
-- The optimisation of overlap tests is based on determining pairs of modules
-- whose family instances need to be checked for consistency.
--
data ModulePair = ModulePair Module Module
-- canonical order of the components of a module pair
--
canon :: ModulePair -> (Module, Module)
canon (ModulePair m1 m2) | m1 < m2 = (m1, m2)
| otherwise = (m2, m1)
instance Eq ModulePair where
mp1 == mp2 = canon mp1 == canon mp2
instance Ord ModulePair where
mp1 `compare` mp2 = canon mp1 `compare` canon mp2
-- Sets of module pairs
--
type ModulePairSet = FiniteMap ModulePair ()
listToSet l = listToFM (zip l (repeat ()))
checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
checkFamInstConsistency famInstMods directlyImpMods
= do { dflags <- getDOpts
; (eps, hpt) <- getEpsAndHpt
; let { -- Fetch the iface of a given module. Must succeed as
-- all imported modules must already have been loaded.
modIface mod =
case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
Nothing -> panic "FamInst.checkFamInstConsistency"
Just iface -> iface
; modInstsEnv = eps_mod_fam_inst_env eps
; groups = map (dep_finsts . mi_deps . modIface)
directlyImpMods
; okPairs = listToSet $ concatMap allPairs groups
-- instances of okPairs are consistent
; criticalPairs = listToSet $ allPairs famInstMods
-- all pairs that we need to consider
; toCheckPairs = keysFM $ criticalPairs `minusFM` okPairs
-- the difference gives us the pairs we need to check now
}
; mapM_ (check modInstsEnv) toCheckPairs
}
where
allPairs [] = []
allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
-- Check the consistency of the family instances of the two modules.
check modInstsEnv (ModulePair m1 m2)
= let { instEnv1 = fromJust . lookupModuleEnv modInstsEnv $ m1
; instEnv2 = fromJust . lookupModuleEnv modInstsEnv $ m2
; insts1 = famInstEnvElts instEnv1
}
in
mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1
\end{code}
%************************************************************************
%* *
Extending the family instance environment
%* *
%************************************************************************
\begin{code}
-- Add new locally-defined family instances
tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
tcExtendLocalFamInstEnv fam_insts thing_inside
......@@ -37,52 +119,69 @@ tcExtendLocalFamInstEnv fam_insts thing_inside
; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts
; let env' = env { tcg_fam_insts = fam_insts ++ tcg_fam_insts env,
tcg_fam_inst_env = inst_env' }
; setGblEnv env' thing_inside }
; setGblEnv env' thing_inside
}
-- Check that the proposed new instance is OK,
-- and then add it to the home inst env
addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv
addLocalFamInst home_fie famInst
= do { -- To instantiate the family instance type, extend the instance
= do { -- Load imported instances, so that we report
-- overlaps correctly
; eps <- getEps
; let inst_envs = (eps_fam_inst_env eps, home_fie)
-- Check for conflicting instance decls
; checkForConflicts inst_envs famInst
-- OK, now extend the envt
; return (extendFamInstEnv home_fie famInst)
}
\end{code}
%************************************************************************
%* *
Checking an instance against conflicts with an instance env
%* *
%************************************************************************
Check whether a single family instance conflicts with those in two instance
environments (one for the EPS and one for the HPT).
\begin{code}
checkForConflicts :: (FamInstEnv, FamInstEnv) -> FamInst -> TcM ()
checkForConflicts inst_envs famInst
= do { -- To instantiate the family instance type, extend the instance
-- envt with completely fresh template variables
-- 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.
let tycon = famInstTyCon famInst
ty = case tyConFamInst_maybe tycon of
Nothing -> panic "FamInst.addLocalFamInst"
Just (tc, tys) -> tc `mkTyConApp` tys
; (tvs', _, tau') <- tcInstSkolType (FamInstSkol tycon) ty
; let (fam, tys') = tcSplitTyConApp tau'
-- Load imported instances, so that we report
-- overlaps correctly
; eps <- getEps
; let inst_envs = (eps_fam_inst_env eps, home_fie)
-- Check for conflicting instance decls
; let { matches = lookupFamInstEnvUnify inst_envs fam tys'
; conflicts = [ conflictingFamInst
| match@(_, conflictingFamInst) <- matches
, conflicting fam tys' tycon match
]
}
; unless (null conflicts) $
conflictInstErr famInst (head conflicts)
-- OK, now extend the envt
; return (extendFamInstEnv home_fie famInst)
}
; let { tycon = famInstTyCon famInst
; ty = case tyConFamInst_maybe tycon of
Nothing -> panic "FamInst.checkForConflicts"
Just (tc, tys) -> tc `mkTyConApp` tys
}
; (tvs', _, tau') <- tcInstSkolType (FamInstSkol tycon) ty
; let (fam, tys') = tcSplitTyConApp tau'
; let { matches = lookupFamInstEnvUnify inst_envs fam tys'
; conflicts = [ conflictingFamInst
| match@(_, conflictingFamInst) <- matches
, conflicting fam tys' tycon match
]
}
; unless (null conflicts) $
conflictInstErr famInst (head conflicts)
}
where
-- In the case of data/newtype instances, any overlap is a conflicts (as
-- In the case of data/newtype instances, any overlap is a conflict (as
-- these instances imply injective type mappings).
conflicting _ _ tycon _ | isAlgTyCon tycon = True
conflicting fam tys' tycon (subst, cFamInst) | otherwise =
panic "FamInst.addLocalFamInst: overlap check for indexed synonyms is still missing"
panic "FamInst.checkForConflicts: overlap check for indexed synonyms is still missing"
conflictInstErr famInst conflictingFamInst
= addFamInstLoc famInst $
......
......@@ -37,6 +37,7 @@ import TcExpr
import TcRnMonad
import TcType
import Inst
import FamInst
import InstEnv
import FamInstEnv
import TcBinds
......@@ -173,6 +174,12 @@ tcRnModule hsc_env hsc_src save_rn_syntax
loadOrphanModules (imp_orphs imports) False ;
loadOrphanModules (imp_finsts imports) True ;
let { directlyImpMods = map (\(mod, _, _) -> mod)
. moduleEnvElts
. imp_mods
$ imports } ;
checkFamInstConsistency (imp_finsts imports) directlyImpMods ;
traceRn (text "rn1a") ;
-- Rename and type check the declarations
tcg_env <- if isHsBoot hsc_src then
......
......@@ -469,7 +469,8 @@ of whether the imported things are actually used or not
It is used * when processing the export list
* when constructing usage info for the inteface file
* to identify the list of directly imported modules
for initialisation purposes
for initialisation purposes and
for optimsed overlap checking of family instances
* when figuring out what things are really unused
\begin{code}
......
Markdown is supported
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