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

11 files changed, 32 insertions, 40 deletions

diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 3b176a5847..439d052496 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -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
diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index e5d021d30d..5b1b33795a 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -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)])
 
diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs
index efd4956b70..f647e35707 100644
--- a/compiler/iface/IfaceEnv.hs
+++ b/compiler/iface/IfaceEnv.hs
@@ -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
diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs
index 71b4e97b39..2bfb2833b6 100644
--- a/compiler/main/Finder.hs
+++ b/compiler/main/Finder.hs
@@ -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
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index cd670b36cd..a698f50c74 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -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.
diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index a1209c77ca..56eba69333 100644
--- a/compiler/main/SysTools.hs
+++ b/compiler/main/SysTools.hs
@@ -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
diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs
index a616dde373..4940f9d76e 100644
--- a/compiler/main/TidyPgm.hs
+++ b/compiler/main/TidyPgm.hs
@@ -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"
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index ca04a71132..cd283529e6 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -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)
diff --git a/compiler/utils/FastString.hs b/compiler/utils/FastString.hs
index 9607d24823..40c3882b87 100644
--- a/compiler/utils/FastString.hs
+++ b/compiler/utils/FastString.hs
@@ -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)
diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs
index 46f6e467c1..fd98bad213 100644
--- a/compiler/utils/IOEnv.hs
+++ b/compiler/utils/IOEnv.hs
@@ -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
diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs
index a1dacb45e5..ddcfe1117b 100644
--- a/compiler/utils/Util.hs
+++ b/compiler/utils/Util.hs
@@ -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)