Commit 07ee96fa authored by Edward Z. Yang's avatar Edward Z. Yang

Use strict atomicModifyIORef' (added in GHC 7.6).

Summary: Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: austin, hvr

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D635
parent 276da792
......@@ -63,7 +63,7 @@ import Outputable
import FastString
import IdInfo
import Data.IORef ( atomicModifyIORef, modifyIORef )
import Data.IORef ( atomicModifyIORef', modifyIORef )
import Control.Monad
import GHC.Fingerprint
......@@ -973,7 +973,7 @@ mkSptEntryName loc = do
let -- Note [Generating fresh names for ccall wrapper]
-- in compiler/typecheck/TcEnv.hs
wrapperRef = nextWrapperNum dflags
wrapperNum <- liftIO $ atomicModifyIORef wrapperRef $ \mod_env ->
wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->
let num = lookupWithDefaultModuleEnv mod_env 0 thisMod
in (extendModuleEnv mod_env thisMod (num+1), num)
return $ mkVarOcc $ what ++ ":" ++ show wrapperNum
......@@ -142,7 +142,7 @@ bindSuspensions t = do
return (RefWrap ty term, names)
}
doSuspension freeNames ct ty hval _name = do
name <- atomicModifyIORef freeNames (\x->(tail x, head x))
name <- atomicModifyIORef' freeNames (\x->(tail x, head x))
n <- newGrimName name
return (Suspension ct ty hval (Just n), [(n,ty,hval)])
......
......@@ -34,9 +34,8 @@ import SrcLoc
import Util
import Outputable
import Exception ( evaluate )
import Data.IORef ( atomicModifyIORef, readIORef )
import Data.IORef ( atomicModifyIORef' )
{-
*********************************************************
......@@ -233,9 +232,7 @@ newtype NameCacheUpdater = NCU { updateNameCache :: forall c. (NameCache -> (Nam
mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater
mkNameCacheUpdater = do
nc_var <- hsc_NC `fmap` getTopEnv
let update_nc f = do r <- atomicModifyIORef nc_var f
_ <- evaluate =<< readIORef nc_var
return r
let update_nc f = atomicModifyIORef' nc_var f
return (NCU update_nc)
initNameCache :: UniqSupply -> [Name] -> NameCache
......
......@@ -40,9 +40,8 @@ import DynFlags
import Outputable
import UniqFM
import Maybes ( expectJust )
import Exception ( evaluate )
import Data.IORef ( IORef, writeIORef, readIORef, atomicModifyIORef )
import Data.IORef ( IORef, writeIORef, readIORef, atomicModifyIORef' )
import System.Directory
import System.FilePath
import Control.Monad
......@@ -80,27 +79,26 @@ flushFinderCaches hsc_env = do
flushModLocationCache :: PackageKey -> IORef ModLocationCache -> IO ()
flushModLocationCache this_pkg ref = do
atomicModifyIORef ref $ \fm -> (filterModuleEnv is_ext fm, ())
_ <- evaluate =<< readIORef ref
atomicModifyIORef' ref $ \fm -> (filterModuleEnv is_ext fm, ())
return ()
where is_ext mod _ | modulePackageKey mod /= this_pkg = True
| otherwise = False
addToFinderCache :: IORef FinderCache -> ModuleName -> FindResult -> IO ()
addToFinderCache ref key val =
atomicModifyIORef ref $ \c -> (addToUFM c key val, ())
atomicModifyIORef' ref $ \c -> (addToUFM c key val, ())
addToModLocationCache :: IORef ModLocationCache -> Module -> ModLocation -> IO ()
addToModLocationCache ref key val =
atomicModifyIORef ref $ \c -> (extendModuleEnv c key val, ())
atomicModifyIORef' ref $ \c -> (extendModuleEnv c key val, ())
removeFromFinderCache :: IORef FinderCache -> ModuleName -> IO ()
removeFromFinderCache ref key =
atomicModifyIORef ref $ \c -> (delFromUFM c key, ())
atomicModifyIORef' ref $ \c -> (delFromUFM c key, ())
removeFromModLocationCache :: IORef ModLocationCache -> Module -> IO ()
removeFromModLocationCache ref key =
atomicModifyIORef ref $ \c -> (delModuleEnv c key, ())
atomicModifyIORef' ref $ \c -> (delModuleEnv c key, ())
lookupFinderCache :: IORef FinderCache -> ModuleName -> IO (Maybe FindResult)
lookupFinderCache ref key = do
......
......@@ -853,7 +853,7 @@ parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do
where
writeLogQueue :: LogQueue -> Maybe (Severity,SrcSpan,PprStyle,MsgDoc) -> IO ()
writeLogQueue (LogQueue ref sem) msg = do
atomicModifyIORef ref $ \msgs -> (msg:msgs,())
atomicModifyIORef' ref $ \msgs -> (msg:msgs,())
_ <- tryPutMVar sem ()
return ()
......@@ -869,7 +869,7 @@ parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do
printLogs !dflags (LogQueue ref sem) = read_msgs
where read_msgs = do
takeMVar sem
msgs <- atomicModifyIORef ref $ \xs -> ([], reverse xs)
msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs)
print_loop msgs
print_loop [] = read_msgs
......@@ -1021,7 +1021,7 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags cleanup par_sem
-- Prune the old HPT unless this is an hs-boot module.
unless (isBootSummary mod) $
atomicModifyIORef old_hpt_var $ \old_hpt ->
atomicModifyIORef' old_hpt_var $ \old_hpt ->
(delFromUFM old_hpt this_mod, ())
-- Update and fetch the global HscEnv.
......
......@@ -1034,7 +1034,7 @@ cleanTempDirs dflags
= unless (gopt Opt_KeepTmpFiles dflags)
$ mask_
$ do let ref = dirsToClean dflags
ds <- atomicModifyIORef ref $ \ds -> (Map.empty, ds)
ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds)
removeTmpDirs dflags (Map.elems ds)
cleanTempFiles :: DynFlags -> IO ()
......@@ -1042,7 +1042,7 @@ cleanTempFiles dflags
= unless (gopt Opt_KeepTmpFiles dflags)
$ mask_
$ do let ref = filesToClean dflags
fs <- atomicModifyIORef ref $ \fs -> ([],fs)
fs <- atomicModifyIORef' ref $ \fs -> ([],fs)
removeTmpFiles dflags fs
cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
......@@ -1050,7 +1050,7 @@ cleanTempFilesExcept dflags dont_delete
= unless (gopt Opt_KeepTmpFiles dflags)
$ mask_
$ do let ref = filesToClean dflags
to_delete <- atomicModifyIORef ref $ \files ->
to_delete <- atomicModifyIORef' ref $ \files ->
let (to_keep,to_delete) = partition (`elem` dont_delete) files
in (to_keep,to_delete)
removeTmpFiles dflags to_delete
......@@ -1058,7 +1058,7 @@ cleanTempFilesExcept dflags dont_delete
-- Return a unique numeric temp file suffix
newTempSuffix :: DynFlags -> IO Int
newTempSuffix dflags = atomicModifyIORef (nextTempSuffix dflags) $ \n -> (n+1,n)
newTempSuffix dflags = atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n)
-- Find a temporary name that doesn't already exist.
newTempName :: DynFlags -> Suffix -> IO FilePath
......@@ -1120,7 +1120,7 @@ getTempDir dflags = do
-- 2. Update the dirsToClean mapping unless an entry already exists
-- (i.e. unless another thread beat us to it).
their_dir <- atomicModifyIORef dir_ref $ \mapping ->
their_dir <- atomicModifyIORef' dir_ref $ \mapping ->
case Map.lookup tmp_dir mapping of
Just dir -> (mapping, Just dir)
Nothing -> (Map.insert tmp_dir our_dir mapping, Nothing)
......@@ -1141,7 +1141,7 @@ getTempDir dflags = do
addFilesToClean :: DynFlags -> [FilePath] -> IO ()
-- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
addFilesToClean dflags new_files
= atomicModifyIORef (filesToClean dflags) $ \files -> (new_files++files, ())
= atomicModifyIORef' (filesToClean dflags) $ \files -> (new_files++files, ())
removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
removeTmpDirs dflags ds
......
......@@ -63,7 +63,7 @@ import qualified ErrUtils as Err
import Control.Monad
import Data.Function
import Data.List ( sortBy )
import Data.IORef ( atomicModifyIORef )
import Data.IORef ( atomicModifyIORef' )
{-
Constructing the TypeEnv, Instances, Rules, VectInfo from which the
......@@ -1018,7 +1018,7 @@ tidyTopName mod nc_var maybe_ref occ_env id
-- Now we get to the real reason that all this is in the IO Monad:
-- we have to update the name cache in a nice atomic fashion
| local && internal = do { new_local_name <- atomicModifyIORef nc_var mk_new_local
| local && internal = do { new_local_name <- atomicModifyIORef' nc_var mk_new_local
; return (occ_env', new_local_name) }
-- Even local, internal names must get a unique occurrence, because
-- if we do -split-objs we externalise the name later, in the code generator
......@@ -1026,7 +1026,7 @@ tidyTopName mod nc_var maybe_ref occ_env id
-- Similarly, we must make sure it has a system-wide Unique, because
-- the byte-code generator builds a system-wide Name->BCO symbol table
| local && external = do { new_external_name <- atomicModifyIORef nc_var mk_new_external
| local && external = do { new_external_name <- atomicModifyIORef' nc_var mk_new_external
; return (occ_env', new_external_name) }
| otherwise = panic "tidyTopName"
......
......@@ -843,7 +843,7 @@ mkWrapperName what nameBase
wrapperRef = nextWrapperNum dflags
pkg = packageKeyString (modulePackageKey thisMod)
mod = moduleNameString (moduleName thisMod)
wrapperNum <- liftIO $ atomicModifyIORef wrapperRef $ \mod_env ->
wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->
let num = lookupWithDefaultModuleEnv mod_env 0 thisMod
mod_env' = extendModuleEnv mod_env thisMod (num+1)
in (mod_env', num)
......
......@@ -109,7 +109,7 @@ import ExtsCompat46
import System.IO
import System.IO.Unsafe ( unsafePerformIO )
import Data.Data
import Data.IORef ( IORef, newIORef, readIORef, atomicModifyIORef )
import Data.IORef ( IORef, newIORef, readIORef, atomicModifyIORef' )
import Data.Maybe ( isJust )
import Data.Char
import Data.List ( elemIndex )
......@@ -340,7 +340,7 @@ mkFastStringWith mk_fs !ptr !len = do
n <- get_uid
new_fs <- mk_fs n
atomicModifyIORef bucket $ \ls2 ->
atomicModifyIORef' bucket $ \ls2 ->
-- Note [Double-checking the bucket]
let delta_ls = case ls1 of
[] -> ls2
......@@ -357,7 +357,7 @@ mkFastStringWith mk_fs !ptr !len = do
where
!(FastStringTable uid _arr) = string_table
get_uid = atomicModifyIORef uid $ \n -> (n+1,n)
get_uid = atomicModifyIORef' uid $ \n -> (n+1,n)
mkFastStringBytes :: Ptr Word8 -> Int -> FastString
mkFastStringBytes !ptr !len =
......@@ -502,7 +502,7 @@ zEncodeFS fs@(FastString _ _ _ ref) =
case m of
Just zfs -> return zfs
Nothing -> do
atomicModifyIORef ref $ \m' -> case m' of
atomicModifyIORef' ref $ \m' -> case m' of
Nothing -> let zfs = mkZFastString (zEncodeString (unpackFS fs))
in (Just zfs, zfs)
Just zfs -> (m', zfs)
......
......@@ -38,7 +38,7 @@ import Module
import Panic
import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef,
atomicModifyIORef )
atomicModifyIORef, atomicModifyIORef' )
import Data.Typeable
import System.IO.Unsafe ( unsafeInterleaveIO )
import System.IO ( fixIO )
......@@ -194,10 +194,7 @@ atomicUpdMutVar var upd = liftIO (atomicModifyIORef var upd)
-- | Strict variant of 'atomicUpdMutVar'.
atomicUpdMutVar' :: IORef a -> (a -> (a, b)) -> IOEnv env b
atomicUpdMutVar' var upd = do
r <- atomicUpdMutVar var upd
_ <- liftIO . evaluate =<< readMutVar var
return r
atomicUpdMutVar' var upd = liftIO (atomicModifyIORef' var upd)
----------------------------------------------------------------------
-- Accessing the environment
......
......@@ -107,7 +107,7 @@ import Exception
import Panic
import Data.Data
import Data.IORef ( IORef, newIORef, atomicModifyIORef )
import Data.IORef ( IORef, newIORef, atomicModifyIORef' )
import System.IO.Unsafe ( unsafePerformIO )
import Data.List hiding (group)
......@@ -808,7 +808,7 @@ global a = unsafePerformIO (newIORef a)
consIORef :: IORef [a] -> a -> IO ()
consIORef var x = do
atomicModifyIORef var (\xs -> (x:xs,()))
atomicModifyIORef' var (\xs -> (x:xs,()))
globalM :: IO a -> IORef a
globalM ma = unsafePerformIO (ma >>= newIORef)
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment