From bb404f27c6cbadbba51794a0dcc9125d873e70e2 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Tue, 18 Aug 2009 19:29:03 +0000 Subject: [PATCH] Put a newtype wrapper around ModuleEnv --- compiler/basicTypes/Module.lhs | 111 ++++++++++++++++++++++++---------------- compiler/iface/MkIface.lhs | 3 +- compiler/main/Finder.lhs | 8 +-- 3 files changed, 72 insertions(+), 50 deletions(-) diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index 2eebf65..77aa5ad 100644 --- a/compiler/basicTypes/Module.lhs +++ b/compiler/basicTypes/Module.lhs @@ -58,7 +58,8 @@ module Module extendModuleEnvList_C, plusModuleEnv_C, delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv, lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv, - moduleEnvKeys, moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, + moduleEnvKeys, moduleEnvElts, moduleEnvToList, + unitModuleEnv, isEmptyModuleEnv, foldModuleEnv, extendModuleEnv_C, filterModuleEnv, -- * ModuleName mappings @@ -342,51 +343,71 @@ mainPackageId = fsToPackageId (fsLit "main") \begin{code} -- | A map keyed off of 'Module's -type ModuleEnv elt = FiniteMap Module elt - -emptyModuleEnv :: ModuleEnv a -mkModuleEnv :: [(Module, a)] -> ModuleEnv a -unitModuleEnv :: Module -> a -> ModuleEnv a -extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a -extendModuleEnv_C :: (a->a->a) -> ModuleEnv a -> Module -> a -> ModuleEnv a -plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a -extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a -extendModuleEnvList_C :: (a->a->a) -> ModuleEnv a -> [(Module, a)] -> ModuleEnv a - -delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a -delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a -plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a -mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b -moduleEnvKeys :: ModuleEnv a -> [Module] -moduleEnvElts :: ModuleEnv a -> [a] - -isEmptyModuleEnv :: ModuleEnv a -> Bool -lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a +newtype ModuleEnv elt = ModuleEnv (FiniteMap Module elt) + +filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a +filterModuleEnv f (ModuleEnv e) = ModuleEnv (filterFM f e) + +elemModuleEnv :: Module -> ModuleEnv a -> Bool +elemModuleEnv m (ModuleEnv e) = elemFM m e + +extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a +extendModuleEnv (ModuleEnv e) m x = ModuleEnv (addToFM e m x) + +extendModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> Module -> a -> ModuleEnv a +extendModuleEnv_C f (ModuleEnv e) m x = ModuleEnv (addToFM_C f e m x) + +extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a +extendModuleEnvList (ModuleEnv e) xs = ModuleEnv (addListToFM e xs) + +extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)] + -> ModuleEnv a +extendModuleEnvList_C f (ModuleEnv e) xs = ModuleEnv (addListToFM_C f e xs) + +plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a +plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (plusFM_C f e1 e2) + +delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a +delModuleEnvList (ModuleEnv e) ms = ModuleEnv (delListFromFM e ms) + +delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a +delModuleEnv (ModuleEnv e) m = ModuleEnv (delFromFM e m) + +plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a +plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (plusFM e1 e2) + +lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a +lookupModuleEnv (ModuleEnv e) m = lookupFM e m + lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a -elemModuleEnv :: Module -> ModuleEnv a -> Bool -foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b -filterModuleEnv :: (a -> Bool) -> ModuleEnv a -> ModuleEnv a - -filterModuleEnv f = filterFM (\_ v -> f v) -elemModuleEnv = elemFM -extendModuleEnv = addToFM -extendModuleEnv_C = addToFM_C -extendModuleEnvList = addListToFM -extendModuleEnvList_C = addListToFM_C -plusModuleEnv_C = plusFM_C -delModuleEnvList = delListFromFM -delModuleEnv = delFromFM -plusModuleEnv = plusFM -lookupModuleEnv = lookupFM -lookupWithDefaultModuleEnv = lookupWithDefaultFM -mapModuleEnv f = mapFM (\_ v -> f v) -mkModuleEnv = listToFM -emptyModuleEnv = emptyFM -moduleEnvKeys = keysFM -moduleEnvElts = eltsFM -unitModuleEnv = unitFM -isEmptyModuleEnv = isEmptyFM -foldModuleEnv f = foldFM (\_ v -> f v) +lookupWithDefaultModuleEnv (ModuleEnv e) x m = lookupWithDefaultFM e x m + +mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b +mapModuleEnv f (ModuleEnv e) = ModuleEnv (mapFM (\_ v -> f v) e) + +mkModuleEnv :: [(Module, a)] -> ModuleEnv a +mkModuleEnv xs = ModuleEnv (listToFM xs) + +emptyModuleEnv :: ModuleEnv a +emptyModuleEnv = ModuleEnv emptyFM + +moduleEnvKeys :: ModuleEnv a -> [Module] +moduleEnvKeys (ModuleEnv e) = keysFM e + +moduleEnvElts :: ModuleEnv a -> [a] +moduleEnvElts (ModuleEnv e) = eltsFM e + +moduleEnvToList :: ModuleEnv a -> [(Module, a)] +moduleEnvToList (ModuleEnv e) = fmToList e + +unitModuleEnv :: Module -> a -> ModuleEnv a +unitModuleEnv m x = ModuleEnv (unitFM m x) + +isEmptyModuleEnv :: ModuleEnv a -> Bool +isEmptyModuleEnv (ModuleEnv e) = isEmptyFM e + +foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b +foldModuleEnv f x (ModuleEnv e) = foldFM (\_ v -> f v) x e \end{code} \begin{code} diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 7b30a19..4de3a6f 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -915,7 +915,8 @@ mkIfaceExports :: [AvailInfo] -- Group by module and sort by occurrence mkIfaceExports exports = [ (mod, eltsFM avails) - | (mod, avails) <- sortBy (stableModuleCmp `on` fst) (fmToList groupFM) + | (mod, avails) <- sortBy (stableModuleCmp `on` fst) + (moduleEnvToList groupFM) -- NB. the fmToList is in a random order, -- because Ord Module is not a predictable -- ordering. Hence we perform a final sort diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs index 17299fb..ad163f2 100644 --- a/compiler/main/Finder.lhs +++ b/compiler/main/Finder.lhs @@ -78,7 +78,7 @@ flushFinderCaches hsc_env = do flushModLocationCache :: PackageId -> IORef ModLocationCache -> IO () flushModLocationCache this_pkg ref = do - atomicModifyIORef ref $ \fm -> (filterFM is_ext fm, ()) + atomicModifyIORef ref $ \fm -> (filterModuleEnv is_ext fm, ()) _ <- evaluate =<< readIORef ref return () where is_ext mod _ | modulePackageId mod /= this_pkg = True @@ -90,7 +90,7 @@ addToFinderCache ref key val = addToModLocationCache :: IORef ModLocationCache -> Module -> ModLocation -> IO () addToModLocationCache ref key val = - atomicModifyIORef ref $ \c -> (addToFM c key val, ()) + atomicModifyIORef ref $ \c -> (extendModuleEnv c key val, ()) removeFromFinderCache :: IORef FinderCache -> ModuleName -> IO () removeFromFinderCache ref key = @@ -98,7 +98,7 @@ removeFromFinderCache ref key = removeFromModLocationCache :: IORef ModLocationCache -> Module -> IO () removeFromModLocationCache ref key = - atomicModifyIORef ref $ \c -> (delFromFM c key, ()) + atomicModifyIORef ref $ \c -> (delModuleEnv c key, ()) lookupFinderCache :: IORef FinderCache -> ModuleName -> IO (Maybe FindResult) lookupFinderCache ref key = do @@ -109,7 +109,7 @@ lookupModLocationCache :: IORef ModLocationCache -> Module -> IO (Maybe ModLocation) lookupModLocationCache ref key = do c <- readIORef ref - return $! lookupFM c key + return $! lookupModuleEnv c key -- ----------------------------------------------------------------------------- -- The two external entry points -- 1.7.10.4