diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/basicTypes/VarSet.hs | 11 | ||||
| -rw-r--r-- | compiler/typecheck/TcHsType.hs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcMType.hs | 44 | ||||
| -rw-r--r-- | compiler/typecheck/TcSimplify.hs | 39 | ||||
| -rw-r--r-- | compiler/typecheck/TcType.hs | 46 | ||||
| -rw-r--r-- | compiler/types/Type.hs | 13 | ||||
| -rw-r--r-- | compiler/types/Type.hs-boot | 4 | ||||
| -rw-r--r-- | compiler/utils/UniqDFM.hs | 12 | ||||
| -rw-r--r-- | compiler/utils/UniqDSet.hs | 8 | ||||
| -rw-r--r-- | compiler/utils/UniqFM.hs | 5 |
10 files changed, 139 insertions, 45 deletions
diff --git a/compiler/basicTypes/VarSet.hs b/compiler/basicTypes/VarSet.hs index 8ece555e5d..6021fdf2f9 100644 --- a/compiler/basicTypes/VarSet.hs +++ b/compiler/basicTypes/VarSet.hs @@ -34,9 +34,11 @@ module VarSet ( intersectDVarSet, intersectsDVarSet, disjointDVarSet, isEmptyDVarSet, delDVarSet, delDVarSetList, minusDVarSet, foldDVarSet, filterDVarSet, + dVarSetMinusVarSet, transCloDVarSet, sizeDVarSet, seqDVarSet, partitionDVarSet, + dVarSetToVarSet, ) where #include "HsVersions.h" @@ -47,7 +49,7 @@ import Name ( Name ) import UniqSet import UniqDSet import UniqFM( disjointUFM, pluralUFM, pprUFM ) -import UniqDFM( disjointUDFM ) +import UniqDFM( disjointUDFM, udfmToUfm ) import Outputable (SDoc) -- | A non-deterministic set of variables. @@ -248,6 +250,9 @@ delDVarSet = delOneFromUniqDSet minusDVarSet :: DVarSet -> DVarSet -> DVarSet minusDVarSet = minusUniqDSet +dVarSetMinusVarSet :: DVarSet -> VarSet -> DVarSet +dVarSetMinusVarSet = uniqDSetMinusUniqSet + foldDVarSet :: (Var -> a -> a) -> a -> DVarSet -> a foldDVarSet = foldUniqDSet @@ -272,6 +277,10 @@ seqDVarSet s = sizeDVarSet s `seq` () extendDVarSetList :: DVarSet -> [Var] -> DVarSet extendDVarSetList = addListToUniqDSet +-- | Convert a DVarSet to a VarSet by forgeting the order of insertion +dVarSetToVarSet :: DVarSet -> VarSet +dVarSetToVarSet = udfmToUfm + -- | transCloVarSet for DVarSet transCloDVarSet :: (DVarSet -> DVarSet) -- Map some variables in the set to diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 58f9ccce85..c5333994bb 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -1441,7 +1441,7 @@ kindGeneralize :: TcType -> TcM [KindVar] -- type variables. So in both cases, all the free vars are kind vars kindGeneralize kind_or_type = do { kvs <- zonkTcTypeAndFV kind_or_type - ; let dvs = DV { dv_kvs = kvs, dv_tvs = emptyVarSet } + ; let dvs = DV { dv_kvs = kvs, dv_tvs = emptyDVarSet } ; gbl_tvs <- tcGetGlobalTyCoVars -- Already zonked ; quantifyZonkedTyVars gbl_tvs dvs } diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index 69de710959..222a2e230a 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -831,6 +831,19 @@ has free vars {f,a}, but we must add 'k' as well! Hence step (3). * quantifyTyVars never quantifies over - a coercion variable - a runtime-rep variable + +Note [quantifyTyVars determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The results of quantifyTyVars are wrapped in a forall and can end up in the +interface file. One such example is inferred type signatures. They also affect +the results of optimizations, for example worker-wrapper. This means that to +get deterministic builds quantifyTyVars needs to be deterministic. + +To achieve this TcDepVars is backed by deterministic sets which allows them +to be later converted to a list in a deterministic order. + +For more information about deterministic sets see +Note [Deterministic UniqFM] in UniqDFM. -} quantifyTyVars, quantifyZonkedTyVars @@ -844,25 +857,25 @@ quantifyTyVars, quantifyZonkedTyVars -- The zonked variant assumes everything is already zonked. quantifyTyVars gbl_tvs (DV { dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs }) - = do { dep_tkvs <- zonkTyCoVarsAndFV dep_tkvs - ; nondep_tkvs <- (`minusVarSet` dep_tkvs) <$> - zonkTyCoVarsAndFV nondep_tkvs + = do { dep_tkvs <- zonkTyCoVarsAndFVDSet dep_tkvs + ; nondep_tkvs <- (`minusDVarSet` dep_tkvs) <$> + zonkTyCoVarsAndFVDSet nondep_tkvs ; gbl_tvs <- zonkTyCoVarsAndFV gbl_tvs ; quantifyZonkedTyVars gbl_tvs (DV { dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs }) } quantifyZonkedTyVars gbl_tvs (DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs }) - = do { let all_cvs = filterVarSet isCoVar dep_tkvs - dep_kvs = varSetElemsWellScoped $ - dep_tkvs `minusVarSet` gbl_tvs - `minusVarSet` closeOverKinds all_cvs - -- varSetElemsWellScoped: put the kind variables into + = do { let all_cvs = filterVarSet isCoVar $ dVarSetToVarSet dep_tkvs + dep_kvs = dVarSetElemsWellScoped $ + dep_tkvs `dVarSetMinusVarSet` gbl_tvs + `dVarSetMinusVarSet` closeOverKinds all_cvs + -- dVarSetElemsWellScoped: put the kind variables into -- well-scoped order. -- E.g. [k, (a::k)] not the other way roud -- closeOverKinds all_cvs: do not quantify over coercion -- variables, or any any tvs that a covar depends on - nondep_tvs = varSetElems $ - nondep_tkvs `minusVarSet` gbl_tvs + nondep_tvs = dVarSetElems $ + nondep_tkvs `dVarSetMinusVarSet` gbl_tvs -- No worry about dependent covars here; they are -- all in dep_tkvs -- No worry about scoping, becuase these are all @@ -1170,7 +1183,7 @@ tcGetGlobalTyCoVars zonkTcTypeInKnot :: TcType -> TcM TcType zonkTcTypeInKnot = mapType (zonkTcTypeMapper { tcm_smart = False }) () -zonkTcTypeAndFV :: TcType -> TcM TyCoVarSet +zonkTcTypeAndFV :: TcType -> TcM DTyCoVarSet -- Zonk a type and take its free variables -- With kind polymorphism it can be essential to zonk *first* -- so that we find the right set of free variables. Eg @@ -1180,7 +1193,7 @@ zonkTcTypeAndFV :: TcType -> TcM TyCoVarSet -- NB: This might be called from within the knot, so don't use -- smart constructors. See Note [Zonking within the knot] in TcHsType zonkTcTypeAndFV ty - = tyCoVarsOfType <$> zonkTcTypeInKnot ty + = tyCoVarsOfTypeDSet <$> zonkTcTypeInKnot ty -- | Zonk a type and call 'splitDepVarsOfType' on it. -- Works within the knot. @@ -1206,6 +1219,13 @@ zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv zonkTyCoVarsAndFV :: TyCoVarSet -> TcM TyCoVarSet zonkTyCoVarsAndFV tycovars = tyCoVarsOfTypes <$> mapM zonkTyCoVar (varSetElems tycovars) +-- Takes a deterministic set of TyCoVars, zonks them and returns a +-- deterministic set of their free variables. +-- See Note [quantifyTyVars determinism]. +zonkTyCoVarsAndFVDSet :: DTyCoVarSet -> TcM DTyCoVarSet +zonkTyCoVarsAndFVDSet tycovars = + tyCoVarsOfTypesDSet <$> mapM zonkTyCoVar (dVarSetElems tycovars) + zonkTcTyVars :: [TcTyVar] -> TcM [TcType] zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index f7344afdb9..4fce9de695 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -624,7 +624,9 @@ simplifyInfer rhs_tclvl apply_mr sigs name_taus wanteds -- so we must promote it! The inferred type is just -- f :: beta -> beta ; zonked_tau_tkvs <- TcM.zonkTyCoVarsAndFV $ - dv_kvs zonked_tau_dvs `unionVarSet` dv_tvs zonked_tau_dvs + dVarSetToVarSet (dv_kvs zonked_tau_dvs) + `unionVarSet` + dVarSetToVarSet (dv_tvs zonked_tau_dvs) -- decideQuantification turned some meta tyvars into -- quantified skolems, so we have to zonk again @@ -747,7 +749,8 @@ decideQuantification apply_mr sigs name_taus constraints zonked_dvs@(DV { dv_kvs = zonked_tau_kvs, dv_tvs = zonked_tau_tvs }) | apply_mr -- Apply the Monomorphism restriction = do { gbl_tvs <- tcGetGlobalTyCoVars - ; let zonked_tkvs = zonked_tau_kvs `unionVarSet` zonked_tau_tvs + ; let zonked_tkvs = dVarSetToVarSet zonked_tau_kvs `unionVarSet` + dVarSetToVarSet zonked_tau_tvs constrained_tvs = tyCoVarsOfTypes constraints `unionVarSet` filterVarSet isCoVar zonked_tkvs mono_tvs = gbl_tvs `unionVarSet` constrained_tvs @@ -771,7 +774,7 @@ decideQuantification apply_mr sigs name_taus constraints | otherwise = do { gbl_tvs <- tcGetGlobalTyCoVars ; let mono_tvs = growThetaTyVars equality_constraints gbl_tvs - tau_tvs_plus = growThetaTyVars constraints zonked_tau_tvs + tau_tvs_plus = growThetaTyVarsDSet constraints zonked_tau_tvs dvs_plus = DV { dv_kvs = zonked_tau_kvs, dv_tvs = tau_tvs_plus } ; qtvs <- quantify_tvs sigs mono_tvs dvs_plus -- We don't grow the kvs, as there's no real need to. Recall @@ -811,8 +814,8 @@ quantify_tvs sigs mono_tvs dep_tvs@(DV { dv_tvs = tau_tvs }) -- NB: don't use quantifyZonkedTyVars because the sig stuff might -- be unzonked = quantifyTyVars (mono_tvs `delVarSetList` sig_qtvs) - (dep_tvs { dv_tvs = tau_tvs `extendVarSetList` sig_qtvs - `extendVarSetList` sig_wcs }) + (dep_tvs { dv_tvs = tau_tvs `extendDVarSetList` sig_qtvs + `extendDVarSetList` sig_wcs }) -- NB: quantifyTyVars zonks its arguments where sig_qtvs = [ skol | sig <- sigs, (_, skol) <- sig_skols sig ] @@ -842,6 +845,32 @@ growThetaTyVars theta tvs where pred_tvs = tyCoVarsOfType pred +------------------ +growThetaTyVarsDSet :: ThetaType -> DTyCoVarSet -> DTyVarSet +-- See Note [Growing the tau-tvs using constraints] +-- NB: only returns tyvars, never covars +-- It takes a deterministic set of TyCoVars and returns a deterministic set +-- of TyVars. +-- The implementation mirrors growThetaTyVars, the only difference is that +-- it avoids unionDVarSet and uses more efficient extendDVarSetList. +growThetaTyVarsDSet theta tvs + | null theta = tvs_only + | otherwise = filterDVarSet isTyVar $ + transCloDVarSet mk_next seed_tvs + where + tvs_only = filterDVarSet isTyVar tvs + seed_tvs = tvs `extendDVarSetList` tyCoVarsOfTypesList ips + (ips, non_ips) = partition isIPPred theta + -- See Note [Inheriting implicit parameters] in TcType + + mk_next :: DVarSet -> DVarSet -- Maps current set to newly-grown ones + mk_next so_far = foldr (grow_one so_far) emptyDVarSet non_ips + grow_one so_far pred tvs + | any (`elemDVarSet` so_far) pred_tvs = tvs `extendDVarSetList` pred_tvs + | otherwise = tvs + where + pred_tvs = tyCoVarsOfTypeList pred + {- Note [Which type variables to quantify] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When choosing type variables to quantify, the basic plan is to diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index 83d491f3dc..230c5626fb 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -851,13 +851,14 @@ allBoundVariabless = mapUnionVarSet allBoundVariables * * ********************************************************************* -} -data TcDepVars -- See note [Dependent type variables] - = DV { dv_kvs :: TyCoVarSet -- "kind" variables (dependent) - , dv_tvs :: TyVarSet -- "type" variables (non-dependent) - -- The two are disjoint sets +data TcDepVars -- See Note [Dependent type variables] + -- See Note [TcDepVars determinism] + = DV { dv_kvs :: DTyCoVarSet -- "kind" variables (dependent) + , dv_tvs :: DTyVarSet -- "type" variables (non-dependent) + -- The two are disjoint sets } -depVarsTyVars :: TcDepVars -> TyVarSet +depVarsTyVars :: TcDepVars -> DTyVarSet depVarsTyVars = dv_tvs instance Outputable TcDepVars where @@ -895,13 +896,26 @@ Note that (k1 :: k2), (k2 :: *) The "type variables" do not depend on each other; if one did, it'd be classified as a kind variable! + +Note [TcDepVars determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we quantify over type variables we decide the order in which they +appear in the final type. Because the order of type variables in the type +can end up in the interface file and affects some optimizations like +worker-wrapper we want this order to be deterministic. + +To achieve that we use deterministic sets of variables that can be converted to +lists in a deterministic order. + +For more information about deterministic sets see +Note [Deterministic UniqFM] in UniqDFM. -} splitDepVarsOfType :: Type -> TcDepVars -- See Note [Dependent type variables] splitDepVarsOfType ty = DV { dv_kvs = dep_vars - , dv_tvs = nondep_vars `minusVarSet` dep_vars } + , dv_tvs = nondep_vars `minusDVarSet` dep_vars } where Pair dep_vars nondep_vars = split_dep_vars ty @@ -910,28 +924,30 @@ splitDepVarsOfTypes :: [Type] -> TcDepVars -- See Note [Dependent type variables] splitDepVarsOfTypes tys = DV { dv_kvs = dep_vars - , dv_tvs = nondep_vars `minusVarSet` dep_vars } + , dv_tvs = nondep_vars `minusDVarSet` dep_vars } where Pair dep_vars nondep_vars = foldMap split_dep_vars tys -- | Worker for 'splitDepVarsOfType'. This might output the same var -- in both sets, if it's used in both a type and a kind. -split_dep_vars :: Type -> Pair TyCoVarSet -- Pair kvs tvs +-- See Note [TcDepVars determinism] +split_dep_vars :: Type -> Pair DTyCoVarSet -- Pair kvs tvs split_dep_vars = go where - go (TyVarTy tv) = Pair (tyCoVarsOfType $ tyVarKind tv) - (unitVarSet tv) + go (TyVarTy tv) = Pair (tyCoVarsOfTypeDSet $ tyVarKind tv) + (unitDVarSet tv) go (AppTy t1 t2) = go t1 `mappend` go t2 go (TyConApp _ tys) = foldMap go tys go (ForAllTy (Anon arg) res) = go arg `mappend` go res go (ForAllTy (Named tv _) ty) = let Pair kvs tvs = go ty in - Pair (kvs `delVarSet` tv `unionVarSet` tyCoVarsOfType (tyVarKind tv)) - (tvs `delVarSet` tv) + Pair (kvs `delDVarSet` tv + `extendDVarSetList` tyCoVarsOfTypeList (tyVarKind tv)) + (tvs `delDVarSet` tv) go (LitTy {}) = mempty - go (CastTy ty co) = go ty `mappend` Pair (tyCoVarsOfCo co) - emptyVarSet - go (CoercionTy co) = Pair (tyCoVarsOfCo co) emptyVarSet + go (CastTy ty co) = go ty `mappend` Pair (tyCoVarsOfCoDSet co) + emptyDVarSet + go (CoercionTy co) = Pair (tyCoVarsOfCoDSet co) emptyDVarSet {- ************************************************************************ diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index 42f91101eb..49c72678d2 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -125,7 +125,7 @@ module Type ( typeSize, -- * Well-scoped lists of variables - varSetElemsWellScoped, toposortTyVars, tyCoVarsOfTypeWellScoped, + dVarSetElemsWellScoped, toposortTyVars, tyCoVarsOfTypeWellScoped, tyCoVarsOfTypesWellScoped, -- * Type comparison @@ -1867,9 +1867,14 @@ toposortTyVars tvs = reverse $ (tyCoVarsOfTypeList (tyVarKind tv)) ) | tv <- tvs ] --- | Extract a well-scoped list of variables from a set of variables. -varSetElemsWellScoped :: VarSet -> [Var] -varSetElemsWellScoped = toposortTyVars . varSetElems +-- | Extract a well-scoped list of variables from a deterministic set of +-- variables. The result is deterministic. +-- NB: There used to exist varSetElemsWellScoped :: VarSet -> [Var] which +-- took a non-deterministic set and produced a non-deterministic +-- well-scoped list. If you care about the list being well-scoped you also +-- most likely care about it being in deterministic order. +dVarSetElemsWellScoped :: DVarSet -> [Var] +dVarSetElemsWellScoped = toposortTyVars . dVarSetElems -- | Get the free vars of a type in scoped order tyCoVarsOfTypeWellScoped :: Type -> [TyVar] diff --git a/compiler/types/Type.hs-boot b/compiler/types/Type.hs-boot index aecfc7fa22..7c16bc08cc 100644 --- a/compiler/types/Type.hs-boot +++ b/compiler/types/Type.hs-boot @@ -1,7 +1,6 @@ module Type where import TyCon -import Var ( TyVar, TyCoVar ) -import VarSet ( TyCoVarSet ) +import Var ( TyVar ) import {-# SOURCE #-} TyCoRep( Type, Kind ) isPredTy :: Type -> Bool @@ -20,4 +19,3 @@ partitionInvisibles :: TyCon -> (a -> Type) -> [a] -> ([a], [a]) coreView :: Type -> Maybe Type tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] -varSetElemsWellScoped :: TyCoVarSet -> [TyCoVar] diff --git a/compiler/utils/UniqDFM.hs b/compiler/utils/UniqDFM.hs index c41e00469b..1b3cade93a 100644 --- a/compiler/utils/UniqDFM.hs +++ b/compiler/utils/UniqDFM.hs @@ -44,6 +44,7 @@ module UniqDFM ( intersectsUDFM, disjointUDFM, minusUDFM, + udfmMinusUFM, partitionUDFM, udfmToList, @@ -59,7 +60,7 @@ import Data.Typeable import Data.Data import Data.List (sortBy) import Data.Function (on) -import UniqFM (UniqFM, listToUFM_Directly, ufmToList) +import UniqFM (UniqFM, listToUFM_Directly, ufmToList, ufmToIntMap) -- Note [Deterministic UniqFM] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -239,6 +240,11 @@ minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i -- M.difference returns a subset of a left set, so `i` is a good upper -- bound. +udfmMinusUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1 +udfmMinusUFM (UDFM x i) y = UDFM (M.difference x (ufmToIntMap y)) i + -- M.difference returns a subset of a left set, so `i` is a good upper + -- bound. + -- | Partition UniqDFM into two UniqDFMs according to the predicate partitionUDFM :: (elt -> Bool) -> UniqDFM elt -> (UniqDFM elt, UniqDFM elt) partitionUDFM p (UDFM m i) = @@ -283,6 +289,10 @@ alterUDFM f (UDFM m i) k = mapUDFM :: (elt1 -> elt2) -> UniqDFM elt1 -> UniqDFM elt2 mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i +instance Monoid (UniqDFM a) where + mempty = emptyUDFM + mappend = plusUDFM + -- This should not be used in commited code, provided for convenience to -- make ad-hoc conversions when developing alwaysUnsafeUfmToUdfm :: UniqFM elt -> UniqDFM elt diff --git a/compiler/utils/UniqDSet.hs b/compiler/utils/UniqDSet.hs index 45ed241df1..90e9996d1a 100644 --- a/compiler/utils/UniqDSet.hs +++ b/compiler/utils/UniqDSet.hs @@ -19,7 +19,7 @@ module UniqDSet ( mkUniqDSet, addOneToUniqDSet, addListToUniqDSet, unionUniqDSets, unionManyUniqDSets, - minusUniqDSet, + minusUniqDSet, uniqDSetMinusUniqSet, intersectUniqDSets, intersectsUniqDSets, foldUniqDSet, @@ -33,6 +33,7 @@ module UniqDSet ( ) where import UniqDFM +import UniqSet import Unique type UniqDSet a = UniqDFM a @@ -65,9 +66,12 @@ unionManyUniqDSets :: [UniqDSet a] -> UniqDSet a unionManyUniqDSets [] = emptyUniqDSet unionManyUniqDSets sets = foldr1 unionUniqDSets sets -minusUniqDSet :: UniqDSet a -> UniqDSet a -> UniqDSet a +minusUniqDSet :: UniqDSet a -> UniqDSet a -> UniqDSet a minusUniqDSet = minusUDFM +uniqDSetMinusUniqSet :: UniqDSet a -> UniqSet a -> UniqDSet a +uniqDSetMinusUniqSet = udfmMinusUFM + intersectUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a intersectUniqDSets = intersectUDFM diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs index 3632926d91..10cc179910 100644 --- a/compiler/utils/UniqFM.hs +++ b/compiler/utils/UniqFM.hs @@ -66,7 +66,7 @@ module UniqFM ( lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, eltsUFM, keysUFM, splitUFM, ufmToSet_Directly, - ufmToList, + ufmToList, ufmToIntMap, joinUFM, pprUniqFM, pprUFM, pluralUFM ) where @@ -298,6 +298,9 @@ eltsUFM (UFM m) = M.elems m ufmToSet_Directly (UFM m) = M.keysSet m ufmToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m +ufmToIntMap :: UniqFM elt -> M.IntMap elt +ufmToIntMap (UFM m) = m + -- Hoopl joinUFM :: JoinFun v -> JoinFun (UniqFM v) joinUFM eltJoin l (OldFact old) (NewFact new) = foldUFM_Directly add (NoChange, old) new |