summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Feuer <david.feuer@gmail.com>2017-03-02 13:45:27 -0500
committerBen Gamari <ben@smart-cactus.org>2017-03-02 14:57:30 -0500
commitae67619853d029ea8049a114f44e59f4ca10b990 (patch)
treefc4e241b74248f72ba5d9a9e438eb3bb2d84e734
parent27a1b12f90b4b27763d22310215f0df34cbd702a (diff)
downloadhaskell-ae67619853d029ea8049a114f44e59f4ca10b990.tar.gz
Eliminate ListSetOps from imp_trust_pkgs
Eliminate ListSetOps from imp_trust_pkgs and imp_dep_pkgs Replace Map with NameEnv in TmOracle Reviewers: austin, dfeuer, bgamari Reviewed By: bgamari Subscribers: thomie Differential Revision: https://phabricator.haskell.org/D3113
-rw-r--r--compiler/deSugar/DsUsage.hs8
-rw-r--r--compiler/deSugar/TmOracle.hs14
-rw-r--r--compiler/main/GHC.hs3
-rw-r--r--compiler/main/HscMain.hs41
-rw-r--r--compiler/rename/RnNames.hs8
-rw-r--r--compiler/typecheck/TcRnDriver.hs5
-rw-r--r--compiler/typecheck/TcRnTypes.hs13
-rw-r--r--compiler/utils/ListSetOps.hs6
-rw-r--r--ghc/GHCi/UI.hs13
9 files changed, 58 insertions, 53 deletions
diff --git a/compiler/deSugar/DsUsage.hs b/compiler/deSugar/DsUsage.hs
index 8c4cf1205f..ec6fe81035 100644
--- a/compiler/deSugar/DsUsage.hs
+++ b/compiler/deSugar/DsUsage.hs
@@ -17,7 +17,6 @@ import Outputable
import Util
import UniqSet
import UniqDFM
-import ListSetOps
import Fingerprint
import Maybes
@@ -25,6 +24,7 @@ import Data.List
import Data.IORef
import Data.Map (Map)
import qualified Data.Map as Map
+import qualified Data.Set as Set
-- | Extract information from the rename and typecheck phases to produce
-- a dependencies information for the module being compiled.
@@ -46,14 +46,14 @@ mkDependencies
-- on M.hi-boot, and hence that we should do the hi-boot consistency
-- check.)
- pkgs | th_used = insertList (toInstalledUnitId thUnitId) (imp_dep_pkgs imports)
+ pkgs | th_used = Set.insert (toInstalledUnitId thUnitId) (imp_dep_pkgs imports)
| otherwise = imp_dep_pkgs imports
-- Set the packages required to be Safe according to Safe Haskell.
-- See Note [RnNames . Tracking Trust Transitively]
- sorted_pkgs = sort pkgs
+ sorted_pkgs = sort (Set.toList pkgs)
trust_pkgs = imp_trust_pkgs imports
- dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs
+ dep_pkgs' = map (\x -> (x, x `Set.member` trust_pkgs)) sorted_pkgs
return Deps { dep_mods = dep_mods,
dep_pkgs = dep_pkgs',
diff --git a/compiler/deSugar/TmOracle.hs b/compiler/deSugar/TmOracle.hs
index 64f20e2121..115c0a882f 100644
--- a/compiler/deSugar/TmOracle.hs
+++ b/compiler/deSugar/TmOracle.hs
@@ -32,7 +32,7 @@ import TcHsSyn
import MonadUtils
import Util
-import qualified Data.Map as Map
+import NameEnv
{-
%************************************************************************
@@ -43,7 +43,7 @@ import qualified Data.Map as Map
-}
-- | The type of substitutions.
-type PmVarEnv = Map.Map Name PmExpr
+type PmVarEnv = NameEnv PmExpr
-- | The environment of the oracle contains
-- 1. A Bool (are there any constraints we cannot handle? (PmExprOther)).
@@ -80,7 +80,7 @@ varIn x e = case e of
-- | Flatten the DAG (Could be improved in terms of performance.).
flattenPmVarEnv :: PmVarEnv -> PmVarEnv
-flattenPmVarEnv env = Map.map (exprDeepLookup env) env
+flattenPmVarEnv env = mapNameEnv (exprDeepLookup env) env
-- | The state of the term oracle (includes complex constraints that cannot
-- progress unless we get more information).
@@ -88,7 +88,7 @@ type TmState = ([ComplexEq], TmOracleEnv)
-- | Initial state of the oracle.
initialTmState :: TmState
-initialTmState = ([], (False, Map.empty))
+initialTmState = ([], (False, emptyNameEnv))
-- | Solve a complex equality (top-level).
solveOneEq :: TmState -> ComplexEq -> Maybe TmState
@@ -140,7 +140,7 @@ extendSubstAndSolve x e (standby, (unhandled, env))
-- had some progress. Careful about performance:
-- See Note [Representation of Term Equalities] in deSugar/Check.hs
(changed, unchanged) = partitionWith (substComplexEq x e) standby
- new_incr_state = (unchanged, (unhandled, Map.insert x e env))
+ new_incr_state = (unchanged, (unhandled, extendNameEnv env x e))
-- | When we know that a variable is fresh, we do not actually have to
-- check whether anything changes, we know that nothing does. Hence,
@@ -149,7 +149,7 @@ extendSubstAndSolve x e (standby, (unhandled, env))
extendSubst :: Id -> PmExpr -> TmState -> TmState
extendSubst y e (standby, (unhandled, env))
| isNotPmExprOther simpl_e
- = (standby, (unhandled, Map.insert x simpl_e env))
+ = (standby, (unhandled, extendNameEnv env x simpl_e))
| otherwise = (standby, (True, env))
where
x = idName y
@@ -219,7 +219,7 @@ applySubstComplexEq env (e1,e2) = (exprDeepLookup env e1, exprDeepLookup env e2)
-- | Apply an (un-flattened) substitution to a variable.
varDeepLookup :: PmVarEnv -> Name -> PmExpr
varDeepLookup env x
- | Just e <- Map.lookup x env = exprDeepLookup env e -- go deeper
+ | Just e <- lookupNameEnv env x = exprDeepLookup env e -- go deeper
| otherwise = PmExprVar x -- terminal
{-# INLINE varDeepLookup #-}
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index f8f3ba9678..adec051596 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -333,6 +333,7 @@ import qualified Parser
import Lexer
import ApiAnnotation
import qualified GHC.LanguageExtensions as LangExt
+import Data.Set (Set)
import System.Directory ( doesFileExist )
import Data.Maybe
@@ -1412,7 +1413,7 @@ isModuleTrusted m = withSession $ \hsc_env ->
liftIO $ hscCheckSafe hsc_env m noSrcSpan
-- | Return if a module is trusted and the pkgs it depends on to be trusted.
-moduleTrustReqs :: GhcMonad m => Module -> m (Bool, [InstalledUnitId])
+moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set InstalledUnitId)
moduleTrustReqs m = withSession $ \hsc_env ->
liftIO $ hscGetSafe hsc_env m noSrcSpan
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 6e6ac04e5e..839ecca8ee 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -137,7 +137,6 @@ import FamInstEnv
import Fingerprint ( Fingerprint )
import Hooks
import TcEnv
-import Maybes
import DynFlags
import ErrUtils
@@ -163,6 +162,8 @@ import System.FilePath as FilePath
import System.Directory
import System.IO (fixIO)
import qualified Data.Map as Map
+import qualified Data.Set as S
+import Data.Set (Set)
#include "HsVersions.h"
@@ -906,15 +907,15 @@ checkSafeImports dflags tcg_env
clearWarnings
-- Check safe imports are correct
- safePkgs <- mapM checkSafe safeImps
+ safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps
safeErrs <- getWarnings
clearWarnings
-- Check non-safe imports are correct if inferring safety
-- See the Note [Safe Haskell Inference]
(infErrs, infPkgs) <- case (safeInferOn dflags) of
- False -> return (emptyBag, [])
- True -> do infPkgs <- mapM checkSafe regImps
+ False -> return (emptyBag, S.empty)
+ True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps
infErrs <- getWarnings
clearWarnings
return (infErrs, infPkgs)
@@ -958,17 +959,19 @@ checkSafeImports dflags tcg_env
= return v1
-- easier interface to work with
+ checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId)
checkSafe (m, l, _) = fst `fmap` hscCheckSafe' dflags m l
-- what pkg's to add to our trust requirements
+ pkgTrustReqs :: Set InstalledUnitId -> Set InstalledUnitId -> Bool -> ImportAvails
pkgTrustReqs req inf infPassed | safeInferOn dflags
&& safeHaskell dflags == Sf_None && infPassed
= emptyImportAvails {
- imp_trust_pkgs = catMaybes req ++ catMaybes inf
+ imp_trust_pkgs = req `S.union` inf
}
pkgTrustReqs _ _ _ | safeHaskell dflags == Sf_Unsafe
= emptyImportAvails
- pkgTrustReqs req _ _ = emptyImportAvails { imp_trust_pkgs = catMaybes req }
+ pkgTrustReqs req _ _ = emptyImportAvails { imp_trust_pkgs = req }
-- | Check that a module is safe to import.
--
@@ -983,13 +986,13 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do
return $ isEmptyBag errs
-- | Return if a module is trusted and the pkgs it depends on to be trusted.
-hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [InstalledUnitId])
+hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId)
hscGetSafe hsc_env m l = runHsc hsc_env $ do
dflags <- getDynFlags
(self, pkgs) <- hscCheckSafe' dflags m l
good <- isEmptyBag `fmap` getWarnings
clearWarnings -- don't want them printed...
- let pkgs' | Just p <- self = p:pkgs
+ let pkgs' | Just p <- self = S.insert p pkgs
| otherwise = pkgs
return (good, pkgs')
@@ -997,7 +1000,7 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do
-- Return (regardless of trusted or not) if the trust type requires the modules
-- own package be trusted and a list of other packages required to be trusted
-- (these later ones haven't been checked) but the own package trust has been.
-hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe InstalledUnitId, [InstalledUnitId])
+hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
hscCheckSafe' dflags m l = do
(tw, pkgs) <- isModSafe m l
case tw of
@@ -1007,7 +1010,7 @@ hscCheckSafe' dflags m l = do
-- Not necessary if that is reflected in dependencies
| otherwise -> return (Just $ toInstalledUnitId (moduleUnitId m), pkgs)
where
- isModSafe :: Module -> SrcSpan -> Hsc (Bool, [InstalledUnitId])
+ isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId)
isModSafe m l = do
iface <- lookup' m
case iface of
@@ -1025,7 +1028,7 @@ hscCheckSafe' dflags m l = do
-- check package is trusted
safeP = packageTrusted trust trust_own_pkg m
-- pkg trust reqs
- pkgRs = map fst $ filter snd $ dep_pkgs $ mi_deps iface'
+ pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface'
-- General errors we throw but Safe errors we log
errs = case (safeM, safeP) of
(True, True ) -> emptyBag
@@ -1083,20 +1086,20 @@ hscCheckSafe' dflags m l = do
| otherwise = False
-- | Check the list of packages are trusted.
-checkPkgTrust :: DynFlags -> [InstalledUnitId] -> Hsc ()
+checkPkgTrust :: DynFlags -> Set InstalledUnitId -> Hsc ()
checkPkgTrust dflags pkgs =
case errors of
[] -> return ()
_ -> (liftIO . throwIO . mkSrcErr . listToBag) errors
where
- errors = catMaybes $ map go pkgs
- go pkg
+ errors = S.foldr go [] pkgs
+ go pkg acc
| trusted $ getInstalledPackageDetails dflags pkg
- = Nothing
+ = acc
| otherwise
- = Just $ mkErrMsg dflags noSrcSpan (pkgQual dflags)
- $ text "The package (" <> ppr pkg <> text ") is required" <>
- text " to be trusted but it isn't!"
+ = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual dflags)
+ $ text "The package (" <> ppr pkg <> text ") is required" <>
+ text " to be trusted but it isn't!"
-- | Set module to unsafe and (potentially) wipe trust information.
--
@@ -1125,7 +1128,7 @@ markUnsafeInfer tcg_env whyUnsafe = do
False -> return tcg_env
where
- wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] }
+ wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty }
pprMod = ppr $ moduleName $ tcg_mod tcg_env
whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"
, text "Reason:"
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index dc9cdd9063..87e041c659 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -55,8 +55,10 @@ import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Ord ( comparing )
import Data.List ( partition, (\\), find, sortBy )
+import qualified Data.Set as S
-- import qualified Data.Set as Set
import System.FilePath ((</>))
+
import System.IO
{-
@@ -397,15 +399,15 @@ calculateAvails dflags iface mod_safe' want_boot =
imp_orphs = orphans,
imp_finsts = finsts,
imp_dep_mods = mkModDeps dependent_mods,
- imp_dep_pkgs = map fst $ dependent_pkgs,
+ imp_dep_pkgs = S.fromList . map fst $ dependent_pkgs,
-- Add in the imported modules trusted package
-- requirements. ONLY do this though if we import the
-- module as a safe import.
-- See Note [Tracking Trust Transitively]
-- and Note [Trust Transitive Property]
imp_trust_pkgs = if mod_safe'
- then map fst $ filter snd dependent_pkgs
- else [],
+ then S.fromList . map fst $ filter snd dependent_pkgs
+ else S.empty,
-- Do we require our own pkg to be trusted?
-- See Note [Trust Own Package]
imp_trust_own_pkg = pkg_trust_req
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index d4a83f13de..fe0e908c47 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -124,8 +124,9 @@ import Util
import Bag
import Inst (tcGetInsts)
import qualified GHC.LanguageExtensions as LangExt
-import HsDumpAst
import Data.Data ( Data )
+import HsDumpAst
+import qualified Data.Set as S
import Control.Monad
@@ -2489,7 +2490,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
, text "Dependent modules:" <+>
pprUDFM (imp_dep_mods imports) ppr
, text "Dependent packages:" <+>
- ppr (sortBy compare $ imp_dep_pkgs imports)]
+ ppr (S.toList $ imp_dep_pkgs imports)]
where -- The use of sortBy is just to reduce unnecessary
-- wobbling in testsuite output
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 67eb982b91..8e526bc5b3 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -181,6 +181,7 @@ import Control.Monad (ap, liftM, msum)
import qualified Control.Monad.Fail as MonadFail
#endif
import Data.Set ( Set )
+import qualified Data.Set as S
import Data.Map ( Map )
import Data.Dynamic ( Dynamic )
@@ -1229,12 +1230,12 @@ data ImportAvails
-- compiling M might not need to consult X.hi, but X
-- is still listed in M's dependencies.
- imp_dep_pkgs :: [InstalledUnitId],
+ imp_dep_pkgs :: Set InstalledUnitId,
-- ^ Packages needed by the module being compiled, whether directly,
-- or via other modules in this package, or via modules imported
-- from other packages.
- imp_trust_pkgs :: [InstalledUnitId],
+ imp_trust_pkgs :: Set InstalledUnitId,
-- ^ This is strictly a subset of imp_dep_pkgs and records the
-- packages the current module needs to trust for Safe Haskell
-- compilation to succeed. A package is required to be trusted if
@@ -1269,8 +1270,8 @@ mkModDeps deps = foldl add emptyUDFM deps
emptyImportAvails :: ImportAvails
emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv,
imp_dep_mods = emptyUDFM,
- imp_dep_pkgs = [],
- imp_trust_pkgs = [],
+ imp_dep_pkgs = S.empty,
+ imp_trust_pkgs = S.empty,
imp_trust_own_pkg = False,
imp_orphs = [],
imp_finsts = [] }
@@ -1292,8 +1293,8 @@ plusImportAvails
imp_orphs = orphs2, imp_finsts = finsts2 })
= ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2,
imp_dep_mods = plusUDFM_C plus_mod_dep dmods1 dmods2,
- imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2,
- imp_trust_pkgs = tpkgs1 `unionLists` tpkgs2,
+ imp_dep_pkgs = dpkgs1 `S.union` dpkgs2,
+ imp_trust_pkgs = tpkgs1 `S.union` tpkgs2,
imp_trust_own_pkg = tself1 || tself2,
imp_orphs = orphs1 `unionLists` orphs2,
imp_finsts = finsts1 `unionLists` finsts2 }
diff --git a/compiler/utils/ListSetOps.hs b/compiler/utils/ListSetOps.hs
index 4113566001..eaa79bd7fb 100644
--- a/compiler/utils/ListSetOps.hs
+++ b/compiler/utils/ListSetOps.hs
@@ -8,7 +8,7 @@
{-# LANGUAGE CPP #-}
module ListSetOps (
- unionLists, minusList, insertList,
+ unionLists, minusList,
-- Association lists
Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,
@@ -41,10 +41,6 @@ getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs )
************************************************************************
-}
-insertList :: Eq a => a -> [a] -> [a]
--- Assumes the arg list contains no dups; guarantees the result has no dups
-insertList x xs | isIn "insert" x xs = xs
- | otherwise = x : xs
unionLists :: (Outputable a, Eq a) => [a] -> [a] -> [a]
-- Assumes that the arguments contain no duplicates
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 97f47397fe..6310e3ce32 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -96,6 +96,7 @@ import Data.Function
import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
partition, sort, sortBy )
+import qualified Data.Set as S
import Data.Maybe
import qualified Data.Map as M
import Data.Time.LocalTime ( getZonedTime )
@@ -2042,15 +2043,15 @@ isSafeModule m = do
-- print info to user...
liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"
liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")
- when (not $ null good)
+ when (not $ S.null good)
(liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++
- (intercalate ", " $ map (showPpr dflags) good))
- case msafe && null bad of
+ (intercalate ", " $ map (showPpr dflags) (S.toList good)))
+ case msafe && S.null bad of
True -> liftIO $ putStrLn $ mname ++ " is trusted!"
False -> do
when (not $ null bad)
(liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "
- ++ (intercalate ", " $ map (showPpr dflags) bad))
+ ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad)))
liftIO $ putStrLn $ mname ++ " is NOT trusted!"
where
@@ -2060,8 +2061,8 @@ isSafeModule m = do
| thisPackage dflags == moduleUnitId md = True
| otherwise = trusted $ getPackageDetails dflags (moduleUnitId md)
- tallyPkgs dflags deps | not (packageTrustOn dflags) = ([], [])
- | otherwise = partition part deps
+ tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty)
+ | otherwise = S.partition part deps
where part pkg = trusted $ getInstalledPackageDetails dflags pkg
-----------------------------------------------------------------------------