diff options
24 files changed, 312 insertions, 20 deletions
diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs index ab44b3e30a..5d47613716 100644 --- a/compiler/basicTypes/Name.hs +++ b/compiler/basicTypes/Name.hs @@ -62,7 +62,8 @@ module Name ( isWiredInName, isBuiltInSyntax, isHoleName, wiredInNameTyThing_maybe, - nameIsLocalOrFrom, nameIsHomePackageImport, nameIsFromExternalPackage, + nameIsLocalOrFrom, nameIsHomePackage, + nameIsHomePackageImport, nameIsFromExternalPackage, stableNameCmp, -- * Class 'NamedThing' and overloaded friends @@ -269,6 +270,17 @@ nameIsLocalOrFrom from name | Just mod <- nameModule_maybe name = from == mod || isInteractiveModule mod | otherwise = True +nameIsHomePackage :: Module -> Name -> Bool +-- True if the Name is defined in module of this package +nameIsHomePackage this_mod + = \nm -> case n_sort nm of + External nm_mod -> moduleUnitId nm_mod == this_pkg + WiredIn nm_mod _ _ -> moduleUnitId nm_mod == this_pkg + Internal -> True + System -> False + where + this_pkg = moduleUnitId this_mod + nameIsHomePackageImport :: Module -> Name -> Bool -- True if the Name is defined in module of this package -- /other than/ the this_mod diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 581912d518..d729dcc002 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -830,7 +830,9 @@ data ModIface -- used when compiling this module mi_orphan :: !WhetherHasOrphans, -- ^ Whether this module has orphans - mi_finsts :: !WhetherHasFamInst, -- ^ Whether this module has family instances + mi_finsts :: !WhetherHasFamInst, + -- ^ Whether this module has family instances. + -- See Note [The type family instance consistency story]. mi_hsc_src :: !HscSource, -- ^ Boot? Signature? mi_deps :: Dependencies, @@ -2278,7 +2280,8 @@ data Dependencies -- ^ Transitive closure of depended upon modules which -- contain family instances (whether home or external). -- This is used by 'checkFamInstConsistency'. This - -- does NOT include us, unlike 'imp_finsts'. + -- does NOT include us, unlike 'imp_finsts'. See Note + -- [The type family instance consistency story]. } deriving( Eq ) -- Equality used only for old/new comparison in MkIface.addFingerprints diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs index 6a38f2f8d5..dd3d173a8e 100644 --- a/compiler/typecheck/FamInst.hs +++ b/compiler/typecheck/FamInst.hs @@ -50,6 +50,100 @@ import Data.List #include "HsVersions.h" {- + +Note [The type family instance consistency story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +To preserve type safety we must ensure that for any given module, all +the type family instances used either in that module or in any module +it directly or indirectly imports are consistent. For example, consider + + module F where + type family F a + + module A where + import F( F ) + type instance F Int = Bool + f :: F Int -> Bool + f x = x + + module B where + import F( F ) + type instance F Int = Char + g :: Char -> F Int + g x = x + + module Bad where + import A( f ) + import B( g ) + bad :: Char -> Int + bad c = f (g c) + +Even though module Bad never mentions the type family F at all, by +combining the functions f and g that were type checked in contradictory +type family instance environments, the function bad is able to coerce +from one type to another. So when we type check Bad we must verify that +the type family instances defined in module A are consistent with those +defined in module B. + +How do we ensure that we maintain the necessary consistency? + +* Call a module which defines at least one type family instance a +"family instance module". This flag `mi_finsts` is recorded in the +interface file. + +* For every module we calculate the set of all of its direct and +indirect dependencies that are family instance modules. This list +`dep_finsts` is also recorded in the interface file so we can compute +this list for a module from the lists for its direct dependencies. + +* When type checking a module M we check consistency of all the type +family instances that are either provided by its `dep_finsts` or +defined in the module M itself. This is a pairwise check, i.e., for +every pair of instances we must check that they are consistent. + +- For family instances coming from `dep_finsts`, this is checked in +checkFamInstConsistency, called from tcRnImports, and in +checkRecFamInstConsistency, called from tcTyClGroup. See Note +[Checking family instance consistency] for details on this check (and +in particular how we avoid having to do all these checks for every +module we compile). + +- That leaves checking the family instances defined in M itself +against instances defined in either M or its `dep_finsts`. This is +checked in `tcExtendLocalFamInstEnv'. + +There are two subtle points in this scheme which have not been +addressed yet. + +* We have checked consistency of the family instances *defined* by M +or its imports, but this is not by definition the same thing as the +family instances *used* by M or its imports. Specifically, we need to +ensure when we use a type family instance while compiling M that this +instance was really defined from either M or one of its imports, +rather than being an instance that we happened to know about from +reading an interface file in the course of compiling an unrelated +module. Otherwise, we'll end up with no record of the fact that M +depends on this family instance and type safety will be compromised. +See #13102. + +* It can also happen that M uses a function defined in another module +which is not transitively imported by M. Examples include the +desugaring of various overloaded constructs, and references inserted +by Template Haskell splices. If that function's definition makes use +of type family instances which are not checked against those visible +from M, type safety can again be compromised. See #13251. + +* When a module C imports a boot module B.hs-boot, we check that C's +type family instances are compatible with those visible from +B.hs-boot. However, C will eventually be linked against a different +module B.hs, which might define additional type family instances which +are inconsistent with C's. This can also lead to loss of type safety. +See #9562. + +-} + +{- ************************************************************************ * * Making a FamInst @@ -114,10 +208,14 @@ Why do we need to check? Consider Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char. Notice that neither instance is an orphan. -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 +How do we know which pairs of modules have already been checked? For each +module M we directly import, we look up the family instance modules that M +imports (directly or indirectly), say F1, ..., FN. For any two modules +among M, F1, ..., FN, we know that the family instances defined in those +two modules are consistent--because we checked that when we compiled M. + +For every other pair of family instance modules we import (directly or +indirectly), we check that they are consistent now. (So that we can be certain that the modules in our `HscTypes.dep_finsts' are consistent.) There is some fancy footwork regarding hs-boot module loops, see @@ -186,7 +284,8 @@ listToSet l = Set.fromList l -- modules which are already known to be consistent). -- -- See Note [Checking family instance consistency] for more --- details. +-- details, and Note [The type family instance consistency story] +-- for the big picture. -- -- This function doesn't check ALL instances for consistency, -- only ones that aren't involved in recursive knot-tying @@ -206,13 +305,16 @@ checkFamInstConsistency famInstMods directlyImpMods (ppr mod $$ pprHPT hpt) Just iface -> iface + -- Which modules were checked for consistency when we compiled + -- `mod`? Itself and its dep_finsts. + ; modConsistent mod = mod : (dep_finsts . mi_deps . modIface $ mod) + ; hmiModule = mi_module . hm_iface ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv . md_fam_insts . hm_details ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi) | hmi <- eltsHpt hpt] - ; groups = map (dep_finsts . mi_deps . modIface) - directlyImpMods + ; groups = map modConsistent directlyImpMods ; okPairs = listToSet $ concatMap allPairs groups -- instances of okPairs are consistent ; criticalPairs = listToSet $ allPairs famInstMods @@ -419,10 +521,42 @@ tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty ************************************************************************ -} --- Add new locally-defined family instances +-- Add new locally-defined family instances, checking consistency with +-- previous locally-defined family instances as well as all instances +-- available from imported modules. This requires loading all of our +-- imports that define family instances (if we haven't loaded them already). tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a + +-- If we weren't actually given any instances to add, then we don't want +-- to go to the bother of loading family instance module dependencies. +tcExtendLocalFamInstEnv [] thing_inside = thing_inside + +-- Otherwise proceed... tcExtendLocalFamInstEnv fam_insts thing_inside = do { env <- getGblEnv + ; let this_mod = tcg_mod env + imports = tcg_imports env + + -- Optimization: If we're only defining type family instances + -- for type families *defined in the home package*, then we + -- only have to load interface files that belong to the home + -- package. The reason is that there's no recursion between + -- packages, so modules in other packages can't possibly define + -- instances for our type families. + -- + -- (Within the home package, we could import a module M that + -- imports us via an hs-boot file, and thereby defines an + -- instance of a type family defined in this module. So we can't + -- apply the same logic to avoid reading any interface files at + -- all, when we define an instances for type family defined in + -- the current module.) + home_fams_only = all (nameIsHomePackage this_mod . fi_fam) fam_insts + want_module mod + | mod == this_mod = False + | home_fams_only = moduleUnitId mod == moduleUnitId this_mod + | otherwise = True + ; loadModuleInterfaces (text "Loading family-instance modules") + (filter want_module (imp_finsts imports)) ; (inst_env', fam_insts') <- foldlM addLocalFamInst (tcg_fam_inst_env env, tcg_fam_insts env) fam_insts @@ -449,8 +583,12 @@ addLocalFamInst (home_fie, my_fis) fam_inst ; mod <- getModule ; traceTc "alfi" (ppr mod) - -- Load imported instances, so that we report - -- overlaps correctly + -- Fetch imported instances, so that we report + -- overlaps correctly. + -- Really we ought to only check consistency with + -- those instances which are transitively imported + -- by the current module, rather than every instance + -- we've ever seen. Fixing this is part of #13102. ; eps <- getEps ; let inst_envs = (eps_fam_inst_env eps, home_fie) home_fie' = extendFamInstEnv home_fie fam_inst diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 9bb1bf8705..dcdff6f89b 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -343,14 +343,20 @@ tcRnImports hsc_env import_decls -- ; traceIf (text "rdr_env: " <+> ppr rdr_env) ; failIfErrsM - -- Load any orphan-module and family instance-module - -- interfaces, so that their rules and instance decls will be - -- found. But filter out a self hs-boot: these instances - -- will be checked when we define them locally. + -- Load any orphan-module (including orphan family + -- instance-module) interfaces, so that their rules and + -- instance decls will be found. But filter out a + -- self hs-boot: these instances will be checked when + -- we define them locally. + -- (We don't need to load non-orphan family instance + -- modules until we either try to use the instances they + -- define, or define our own family instances, at which + -- point we need to check them for consistency.) ; loadModuleInterfaces (text "Loading orphan modules") (filter (/= this_mod) (imp_orphs imports)) - -- Check type-family consistency + -- Check type-family consistency between imports. + -- See Note [The type family instance consistency story] ; traceRn "rn1: checking family instance consistency" empty ; let { dir_imp_mods = moduleEnvKeys . imp_mods diff --git a/testsuite/tests/ghci/scripts/T4175.stdout b/testsuite/tests/ghci/scripts/T4175.stdout index d96a2ef9eb..994886cc4a 100644 --- a/testsuite/tests/ghci/scripts/T4175.stdout +++ b/testsuite/tests/ghci/scripts/T4175.stdout @@ -28,9 +28,9 @@ instance Show () -- Defined in ‘GHC.Show’ type instance D () a = Bool -- Defined at T4175.hs:22:10 data instance B () = MkB -- Defined at T4175.hs:13:15 data Maybe a = Nothing | Just a -- Defined in ‘GHC.Base’ -instance Foldable Maybe -- Defined in ‘Data.Foldable’ instance Traversable Maybe -- Defined in ‘Data.Traversable’ instance Monoid a => Monoid (Maybe a) -- Defined in ‘GHC.Base’ +instance Foldable Maybe -- Defined in ‘Data.Foldable’ instance Read a => Read (Maybe a) -- Defined in ‘GHC.Read’ instance Applicative Maybe -- Defined in ‘GHC.Base’ instance Functor Maybe -- Defined in ‘GHC.Base’ diff --git a/testsuite/tests/indexed-types/should_compile/T13092b/Makefile b/testsuite/tests/indexed-types/should_compile/T13092b/Makefile new file mode 100644 index 0000000000..2b498980c4 --- /dev/null +++ b/testsuite/tests/indexed-types/should_compile/T13092b/Makefile @@ -0,0 +1,10 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +T13092b: + rm -f T13092b_[12].hi + '$(TEST_HC)' $(TEST_HC_OPTS) -c T13092b_1.hs -ddump-if-trace 2> if.out + grep 'Reading interface for .*:GHC.Generics' if.out > /dev/null + '$(TEST_HC)' $(TEST_HC_OPTS) -c T13092b_2.hs -ddump-if-trace 2> if.out + ! grep 'Reading interface for .*:GHC.Generics' if.out diff --git a/testsuite/tests/indexed-types/should_compile/T13092b/T13092b_1.hs b/testsuite/tests/indexed-types/should_compile/T13092b/T13092b_1.hs new file mode 100644 index 0000000000..4d13c1580d --- /dev/null +++ b/testsuite/tests/indexed-types/should_compile/T13092b/T13092b_1.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies, DeriveGeneric #-} + +module T13092b_1 where + +import GHC.Generics + +data X = X deriving (Generic) diff --git a/testsuite/tests/indexed-types/should_compile/T13092b/T13092b_2.hs b/testsuite/tests/indexed-types/should_compile/T13092b/T13092b_2.hs new file mode 100644 index 0000000000..14e1ff8dcc --- /dev/null +++ b/testsuite/tests/indexed-types/should_compile/T13092b/T13092b_2.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} + +module T13092b_2 where + +import T13092b_1 + +x :: X +x = X diff --git a/testsuite/tests/indexed-types/should_compile/T13092b/all.T b/testsuite/tests/indexed-types/should_compile/T13092b/all.T new file mode 100644 index 0000000000..a3047a60e5 --- /dev/null +++ b/testsuite/tests/indexed-types/should_compile/T13092b/all.T @@ -0,0 +1,5 @@ +# Test that we don't load all family instance interface files +# when importing a module that defines a family instance + +test('T13092b', ignore_stdout, + run_command, ['$MAKE -s --no-print-directory T13092b']) diff --git a/testsuite/tests/indexed-types/should_fail/T13092/A.hs b/testsuite/tests/indexed-types/should_fail/T13092/A.hs new file mode 100644 index 0000000000..a7acce648b --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T13092/A.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE TypeFamilies #-} +module A where +type family A a diff --git a/testsuite/tests/indexed-types/should_fail/T13092/B.hs b/testsuite/tests/indexed-types/should_fail/T13092/B.hs new file mode 100644 index 0000000000..f04248d4a1 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T13092/B.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} +module B (A, X) where +import A +data X +type instance A (X, b) = () diff --git a/testsuite/tests/indexed-types/should_fail/T13092/C.hs b/testsuite/tests/indexed-types/should_fail/T13092/C.hs new file mode 100644 index 0000000000..73beecf2e8 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T13092/C.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE RankNTypes #-} +module C (x) where +import Data.Proxy +import B +x :: Proxy b -> (forall t. Proxy t -> Bool -> A (t, b)) -> (Bool -> ()) +x _ f = f (undefined :: Proxy X) diff --git a/testsuite/tests/indexed-types/should_fail/T13092/Main.hs b/testsuite/tests/indexed-types/should_fail/T13092/Main.hs new file mode 100644 index 0000000000..ee62cf0cbb --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T13092/Main.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TypeFamilies #-} + +module Main where + +import Data.Proxy +import A +import C + +data Y +type instance A (a, Y) = Bool + +y :: Proxy a -> Bool -> A (a, Y) +y _ = id + +z :: Bool -> () +z = x (undefined :: Proxy Y) y + +main = print (z True) diff --git a/testsuite/tests/indexed-types/should_fail/T13092/Makefile b/testsuite/tests/indexed-types/should_fail/T13092/Makefile new file mode 100644 index 0000000000..8bd11ac3c2 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T13092/Makefile @@ -0,0 +1,9 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +T13092: + '$(TEST_HC)' $(TEST_HC_OPTS) -c A.hs + '$(TEST_HC)' $(TEST_HC_OPTS) -c B.hs + '$(TEST_HC)' $(TEST_HC_OPTS) -c C.hs + ! '$(TEST_HC)' $(TEST_HC_OPTS) -c Main.hs diff --git a/testsuite/tests/indexed-types/should_fail/T13092/T13092.stderr b/testsuite/tests/indexed-types/should_fail/T13092/T13092.stderr new file mode 100644 index 0000000000..9df66e7cd1 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T13092/T13092.stderr @@ -0,0 +1,5 @@ + +Main.hs:10:15: error: + Conflicting family instance declarations: + A (a, Y) = Bool -- Defined at Main.hs:10:15 + A (B.X, b) = () -- Defined in ‘B’ diff --git a/testsuite/tests/indexed-types/should_fail/T13092/all.T b/testsuite/tests/indexed-types/should_fail/T13092/all.T new file mode 100644 index 0000000000..090d10db96 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T13092/all.T @@ -0,0 +1,5 @@ +# Test that we check consistency of local type family instances +# with imported ones + +test('T13092', extra_files(['A.hs', 'B.hs', 'C.hs', 'Main.hs']), + run_command, ['$MAKE -s --no-print-directory T13092']) diff --git a/testsuite/tests/indexed-types/should_fail/T13092c/Makefile b/testsuite/tests/indexed-types/should_fail/T13092c/Makefile new file mode 100644 index 0000000000..29a3b104eb --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T13092c/Makefile @@ -0,0 +1,12 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +T13092c: + rm -f T13092c_[1234].hi + '$(TEST_HC)' $(TEST_HC_OPTS) -c T13092c_1.hs -ddump-if-trace > /dev/null 2> if.out + ! grep 'Reading interface for .*:GHC.Generics' if.out + '$(TEST_HC)' $(TEST_HC_OPTS) -c T13092c_2.hs -ddump-if-trace > /dev/null 2> if.out + ! grep 'Reading interface for .*:GHC.Generics' if.out + '$(TEST_HC)' $(TEST_HC_OPTS) -c T13092c_3.hs + ! '$(TEST_HC)' $(TEST_HC_OPTS) -c T13092c_4.hs diff --git a/testsuite/tests/indexed-types/should_fail/T13092c/T13092c.stderr b/testsuite/tests/indexed-types/should_fail/T13092c/T13092c.stderr new file mode 100644 index 0000000000..6676684ec1 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T13092c/T13092c.stderr @@ -0,0 +1,5 @@ + +T13092c_4.hs:7:15: error: + Conflicting family instance declarations: + F (a, Char) = String -- Defined at T13092c_4.hs:7:15 + F (T13092c_2.X, b) = Bool -- Defined in ‘T13092c_2’ diff --git a/testsuite/tests/indexed-types/should_fail/T13092c/T13092c_1.hs b/testsuite/tests/indexed-types/should_fail/T13092c/T13092c_1.hs new file mode 100644 index 0000000000..dbab1da195 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T13092c/T13092c_1.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} + +module T13092c_1 where + +type family F a +type instance F Int = () diff --git a/testsuite/tests/indexed-types/should_fail/T13092c/T13092c_2.hs b/testsuite/tests/indexed-types/should_fail/T13092c/T13092c_2.hs new file mode 100644 index 0000000000..0bbf97efdd --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T13092c/T13092c_2.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} + +module T13092c_2 (F) where + +import T13092c_1 + +data X +type instance F (X, b) = Bool diff --git a/testsuite/tests/indexed-types/should_fail/T13092c/T13092c_3.hs b/testsuite/tests/indexed-types/should_fail/T13092c/T13092c_3.hs new file mode 100644 index 0000000000..08bda736e5 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T13092c/T13092c_3.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} + +module T13092c_3 (F) where + +import T13092c_2 diff --git a/testsuite/tests/indexed-types/should_fail/T13092c/T13092c_4.hs b/testsuite/tests/indexed-types/should_fail/T13092c/T13092c_4.hs new file mode 100644 index 0000000000..a3273f9bfe --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T13092c/T13092c_4.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies #-} + +module T13092c_4 where + +import T13092c_3 + +type instance F (a, Char) = String diff --git a/testsuite/tests/indexed-types/should_fail/T13092c/all.T b/testsuite/tests/indexed-types/should_fail/T13092c/all.T new file mode 100644 index 0000000000..c4e38be054 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T13092c/all.T @@ -0,0 +1,8 @@ +# Test that we don't load family instance instance files from +# external packages when defining an instance for a type family +# defined in the home package, but do read instance files from +# the home package. (Instance in T13092c_2 overlaps with the one +# defined in T13092c_4, and would not be read otherwise.) + +test('T13092c', ignore_stdout, + run_command, ['$MAKE -s --no-print-directory T13092c']) diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 1df1eae0c0..0592bd6800 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -964,10 +964,11 @@ test('T13056', test('T12707', [ compiler_stats_num_field('bytes allocated', - [(wordsize(64), 1280336112, 5), + [(wordsize(64), 1310037632, 5), # initial: 1271577192 # 2017-01-22: 1348865648 Allow top-level strings in Core # 2017-01-31: 1280336112 Join points (#12988) + # 2017-02-11: 1310037632 Check local family instances vs imports ]), ], compile, |