From c4de6a7a5c6433ae8c4df8a9fa09fbd9f3bbd0bf Mon Sep 17 00:00:00 2001 From: Andreas Klebinger Date: Tue, 23 Jun 2020 15:01:25 +0200 Subject: Give Uniq[D]FM a phantom type for its key. This fixes #17667 and should help to avoid such issues going forward. The changes are mostly mechanical in nature. With two notable exceptions. * The register allocator. The register allocator references registers by distinct uniques. However they come from the types of VirtualReg, Reg or Unique in various places. As a result we sometimes cast the key type of the map and use functions which operate on the now typed map but take a raw Unique as actual key. The logic itself has not changed it just becomes obvious where we do so now. * Env Modules. As an example a ClassEnv is currently queried using the types `Class`, `Name`, and `TyCon`. This is safe since for a distinct class value all these expressions give the same unique. getUnique cls getUnique (classTyCon cls) getUnique (className cls) getUnique (tcName $ classTyCon cls) This is for the most part contained within the modules defining the interface. However it requires us to play dirty when we are given a `Name` to lookup in a `UniqFM Class a` map. But again the logic did not change and it's for the most part hidden behind the Env Module. Some of these cases could be avoided by refactoring but this is left for future work. We also bump the haddock submodule as it uses UniqFM. --- compiler/GHC/HsToCore/Monad.hs | 7 +++++-- compiler/GHC/HsToCore/PmCheck/Oracle.hs | 2 +- compiler/GHC/HsToCore/PmCheck/Ppr.hs | 2 +- compiler/GHC/HsToCore/PmCheck/Types.hs | 11 ++++++++--- 4 files changed, 15 insertions(+), 7 deletions(-) (limited to 'compiler/GHC/HsToCore') diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index 0cd715634a..f803939da6 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -86,7 +86,7 @@ import GHC.Types.Name.Env import GHC.Driver.Session import GHC.Utils.Error import GHC.Data.FastString -import GHC.Types.Unique.FM ( lookupWithDefaultUFM ) +import GHC.Types.Unique.FM ( lookupWithDefaultUFM_Directly ) import GHC.Types.Literal ( mkLitString ) import GHC.Types.CostCentre.State @@ -533,7 +533,10 @@ dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch] dsGetCompleteMatches tc = do eps <- getEps env <- getGblEnv - let lookup_completes ufm = lookupWithDefaultUFM ufm [] tc + -- We index into a UniqFM from Name -> elt, for tyCon it holds that + -- getUnique (tyConName tc) == getUnique tc. So we lookup using the + -- unique directly instead. + let lookup_completes ufm = lookupWithDefaultUFM_Directly ufm [] (getUnique tc) eps_matches_list = lookup_completes $ eps_complete_matches eps env_matches_list = lookup_completes $ ds_complete_matches env return $ eps_matches_list ++ env_matches_list diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs index 7a213ce7ef..361ea04971 100644 --- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs +++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs @@ -781,7 +781,7 @@ lookupRefuts :: Uniquable k => Delta -> k -> [PmAltCon] -- Unfortunately we need the extra bit of polymorphism and the unfortunate -- duplication of lookupVarInfo here. lookupRefuts MkDelta{ delta_tm_st = ts@(TmSt (SDIE env) _) } k = - case lookupUDFM env k of + case lookupUDFM_Directly env (getUnique k) of Nothing -> [] Just (Indirect y) -> pmAltConSetElems (vi_neg (lookupVarInfo ts y)) Just (Entry vi) -> pmAltConSetElems (vi_neg vi) diff --git a/compiler/GHC/HsToCore/PmCheck/Ppr.hs b/compiler/GHC/HsToCore/PmCheck/Ppr.hs index 5b1fe16ba1..e4358e78b6 100644 --- a/compiler/GHC/HsToCore/PmCheck/Ppr.hs +++ b/compiler/GHC/HsToCore/PmCheck/Ppr.hs @@ -98,7 +98,7 @@ substitution to the vectors before printing them out (see function `pprOne' in -- | Extract and assigns pretty names to constraint variables with refutable -- shapes. prettifyRefuts :: Delta -> DIdEnv SDoc -> DIdEnv (SDoc, [PmAltCon]) -prettifyRefuts delta = listToUDFM . map attach_refuts . udfmToList +prettifyRefuts delta = listToUDFM_Directly . map attach_refuts . udfmToList where attach_refuts (u, sdoc) = (u, (sdoc, lookupRefuts delta u)) diff --git a/compiler/GHC/HsToCore/PmCheck/Types.hs b/compiler/GHC/HsToCore/PmCheck/Types.hs index 9267555380..2d551fc1aa 100644 --- a/compiler/GHC/HsToCore/PmCheck/Types.hs +++ b/compiler/GHC/HsToCore/PmCheck/Types.hs @@ -6,6 +6,8 @@ Author: George Karachalias {-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ApplicativeDo #-} -- | Types used through-out pattern match checking. This module is mostly there -- to be imported from "GHC.Tc.Types". The exposed API is that of @@ -458,11 +460,14 @@ setEntrySDIE :: SharedDIdEnv a -> Id -> a -> SharedDIdEnv a setEntrySDIE sdie@(SDIE env) x a = SDIE $ extendDVarEnv env (fst (lookupReprAndEntrySDIE sdie x)) (Entry a) -traverseSDIE :: Applicative f => (a -> f b) -> SharedDIdEnv a -> f (SharedDIdEnv b) -traverseSDIE f = fmap (SDIE . listToUDFM) . traverse g . udfmToList . unSDIE +traverseSDIE :: forall a b f. Applicative f => (a -> f b) -> SharedDIdEnv a -> f (SharedDIdEnv b) +traverseSDIE f = fmap (SDIE . listToUDFM_Directly) . traverse g . udfmToList . unSDIE where + g :: (Unique, Shared a) -> f (Unique, Shared b) g (u, Indirect y) = pure (u,Indirect y) - g (u, Entry a) = (u,) . Entry <$> f a + g (u, Entry a) = do + a' <- f a + pure (u,Entry a') instance Outputable a => Outputable (Shared a) where ppr (Indirect x) = ppr x -- cgit v1.2.1