Use better names for updated FastMutInt functions and provide documentation strings.wip/perf-fastint2

7 files changed, 101 insertions, 75 deletions

diff --git a/compiler/GHC/Data/FastMutInt.hs b/compiler/GHC/Data/FastMutInt.hs
index 3b2725d927..5502fbe16f 100644
--- a/compiler/GHC/Data/FastMutInt.hs
+++ b/compiler/GHC/Data/FastMutInt.hs
@@ -14,12 +14,14 @@ module GHC.Data.FastMutInt
   , FastMutInt2
   , newFastMutInt
   , newFastMutInt2
+  , readFirstFastMutInt
+  , readSecondFastMutInt
+  , writeFirstFastMutInt
+  , writeSecondFastMutInt
+  , atomicFetchAddFirstFastMut
+  , atomicFetchAddSecondFastMut
   , readFastMutInt
-  , readFastMutInt2
   , writeFastMutInt
-  , writeFastMutInt2
-  , atomicFetchAddFastMut
-  , atomicFetchAddFastMut2
   )
 where
 
@@ -27,68 +29,93 @@ import GHC.Prelude.Basic
 
 import GHC.Base
 
-data FastMutInts (n :: S) = FastMutInts !(MutableByteArray# RealWorld)
-data S = S1 | S2
+data FastMutInts (n :: VarCount) = FastMutInts !(MutableByteArray# RealWorld)
+-- It's likely possible to generalise this to n-variables, but no
+-- use cases exist so far in GHC, so we currently choose the simplicity
+-- of implementation.
+data VarCount = OneVar | TwoVars
 
-type FastMutInt  = FastMutInts 'S1
-type FastMutInt2 = FastMutInts 'S2
+type FastMutInt  = FastMutInts 'OneVar
+type FastMutInt2 = FastMutInts 'TwoVars
 
+
+-- Keep the old names around for Haddock:
+readFastMutInt :: FastMutInt -> IO Int
+readFastMutInt = readFirstFastMutInt
+
+writeFastMutInt :: FastMutInt -> Int -> IO ()
+writeFastMutInt = writeFirstFastMutInt
+
+
+-- | Allocate a single mutable int with an initial value.
 newFastMutInt :: Int -> IO FastMutInt
 {-# INLINE newFastMutInt #-}
 newFastMutInt n = do
     let size = finiteBitSize (0 :: Int) `unsafeShiftR` 3
     x <- createFastMutInt size
-    writeFastMutInt x n
+    writeFirstFastMutInt x n
     return x
 
+-- | Allocate a pair of mutable ints with initial values.
 newFastMutInt2 :: Int -> Int -> IO FastMutInt2
 {-# INLINE newFastMutInt2 #-}
 newFastMutInt2 n0 n1 = do
     let size = finiteBitSize (0 :: Int) `unsafeShiftR` 2
                   -- only "shiftR 2" to account for "times 2"
     x <- createFastMutInt size
-    writeFastMutInt x n0
-    writeFastMutInt2 x n1
+    writeFirstFastMutInt x n0
+    writeSecondFastMutInt x n1
     return x
 
+-- | Allocate space for n mutable ints.
 createFastMutInt :: Int -> IO (FastMutInts n)
 {-# INLINE createFastMutInt #-}
 createFastMutInt (I# size) = IO $ \s ->
   case newByteArray# size s of
     (# s, arr #) -> (# s, FastMutInts arr #)
 
-readFastMutInt :: FastMutInts n -> IO Int
-{-# INLINE readFastMutInt #-}
-readFastMutInt (FastMutInts arr) = IO $ \s ->
+-- | Read the first int from either a single or pair of
+-- mutable ints.
+readFirstFastMutInt :: FastMutInts n -> IO Int
+{-# INLINE readFirstFastMutInt #-}
+readFirstFastMutInt (FastMutInts arr) = IO $ \s ->
   case readIntArray# arr 0# s of
     (# s, i #) -> (# s, I# i #)
 
-readFastMutInt2 :: FastMutInt2 -> IO Int
-{-# INLINE readFastMutInt2 #-}
-readFastMutInt2 (FastMutInts arr) = IO $ \s ->
+-- | Read the second int from a pair of mutable ints.
+readSecondFastMutInt :: FastMutInt2 -> IO Int
+{-# INLINE readSecondFastMutInt #-}
+readSecondFastMutInt (FastMutInts arr) = IO $ \s ->
   case readIntArray# arr 1# s of
     (# s, i #) -> (# s, I# i #)
 
-writeFastMutInt :: FastMutInts n -> Int -> IO ()
-{-# INLINE writeFastMutInt #-}
-writeFastMutInt (FastMutInts arr) (I# i) = IO $ \s ->
+-- | Write to a single mutable int, or the first slot of
+-- a pair of mutable ints.
+writeFirstFastMutInt :: FastMutInts n -> Int -> IO ()
+{-# INLINE writeFirstFastMutInt #-}
+writeFirstFastMutInt (FastMutInts arr) (I# i) = IO $ \s ->
   case writeIntArray# arr 0# i s of
     s -> (# s, () #)
 
-writeFastMutInt2 :: FastMutInt2 -> Int -> IO ()
-{-# INLINE writeFastMutInt2 #-}
-writeFastMutInt2 (FastMutInts arr) (I# i) = IO $ \s ->
+-- | Write to the second slot of a pair of mutable ints.
+writeSecondFastMutInt :: FastMutInt2 -> Int -> IO ()
+{-# INLINE writeSecondFastMutInt #-}
+writeSecondFastMutInt (FastMutInts arr) (I# i) = IO $ \s ->
   case writeIntArray# arr 1# i s of
     s -> (# s, () #)
 
-atomicFetchAddFastMut :: FastMutInts n -> Int -> IO Int
-{-# INLINE atomicFetchAddFastMut #-}
-atomicFetchAddFastMut (FastMutInts arr) (I# i) = IO $ \s ->
+-- | Atomically modify a single mutable int, or the first slot
+-- of a pair of mutable ints, by the given value.
+atomicFetchAddFirstFastMut :: FastMutInts n -> Int -> IO Int
+{-# INLINE atomicFetchAddFirstFastMut #-}
+atomicFetchAddFirstFastMut (FastMutInts arr) (I# i) = IO $ \s ->
   case fetchAddIntArray# arr 0# i s of
     (# s, n #) -> (# s, I# n #)
 
-atomicFetchAddFastMut2 :: FastMutInt2 -> Int -> IO Int
-{-# INLINE atomicFetchAddFastMut2 #-}
-atomicFetchAddFastMut2 (FastMutInts arr) (I# i) = IO $ \s ->
+-- | Atomically modify the second slot of a pair of mutable ints
+-- by the given value.
+atomicFetchAddSecondFastMut :: FastMutInt2 -> Int -> IO Int
+{-# INLINE atomicFetchAddSecondFastMut #-}
+atomicFetchAddSecondFastMut (FastMutInts arr) (I# i) = IO $ \s ->
   case fetchAddIntArray# arr 1# i s of
     (# s, n #) -> (# s, I# n #)
diff --git a/compiler/GHC/Data/FastString.hs b/compiler/GHC/Data/FastString.hs
index 5b9baa5c82..22e00f8e2d 100644
--- a/compiler/GHC/Data/FastString.hs
+++ b/compiler/GHC/Data/FastString.hs
@@ -342,7 +342,7 @@ maybeResizeSegment segmentRef = do
   segment@(FastStringTableSegment lock counter old#) <- readIORef segmentRef
   let oldSize# = sizeofMutableArray# old#
       newSize# = oldSize# *# 2#
-  (I# n#) <- readFastMutInt counter
+  (I# n#) <- readFirstFastMutInt counter
   if isTrue# (n# <# newSize#) -- maximum load of 1
   then return segment
   else do
@@ -476,7 +476,7 @@ mkFastStringWith mk_fs sbs = do
       withMVar lock $ \_ -> insert new_fs
   where
     !(FastStringTable uid n_zencs segments#) = stringTable
-    get_uid = atomicFetchAddFastMut uid 1
+    get_uid = atomicFetchAddFirstFastMut uid 1
 
     !(I# hash#) = hashStr sbs
     (# segmentRef #) = indexArray# segments# (hashToSegment# hash#)
@@ -492,7 +492,7 @@ mkFastStringWith mk_fs sbs = do
           IO $ \s1# ->
             case writeArray# buckets# idx# (fs : bucket) s1# of
               s2# -> (# s2#, () #)
-          _ <- atomicFetchAddFastMut counter 1
+          _ <- atomicFetchAddFirstFastMut counter 1
           return fs
 
 bucket_match :: [FastString] -> ShortByteString -> Maybe FastString
@@ -552,7 +552,7 @@ mkFastStringByteList str = mkFastStringShortByteString (SBS.pack str)
 -- account the number of forced z-strings into the passed 'FastMutInt'.
 mkZFastString :: FastMutInt -> ShortByteString -> FastZString
 mkZFastString n_zencs sbs = unsafePerformIO $ do
-  _ <- atomicFetchAddFastMut n_zencs 1
+  _ <- atomicFetchAddFirstFastMut n_zencs 1
   return $ mkFastZStringString (zEncodeString (utf8DecodeShortByteString sbs))
 
 mkNewFastStringShortByteString :: ShortByteString -> Int
@@ -644,7 +644,7 @@ getFastStringTable =
     !(FastStringTable _ _ segments#) = stringTable
 
 getFastStringZEncCounter :: IO Int
-getFastStringZEncCounter = readFastMutInt n_zencs
+getFastStringZEncCounter = readFirstFastMutInt n_zencs
   where
     !(FastStringTable _ n_zencs _) = stringTable
 
diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs
index a1611fe263..03c9355819 100644
--- a/compiler/GHC/Iface/Binary.hs
+++ b/compiler/GHC/Iface/Binary.hs
@@ -242,7 +242,7 @@ putWithTables bh put_payload = do
       -- NB. write the dictionary after the symbol table, because
       -- writing the symbol table may create more dictionary entries.
       let put_symtab = do
-            name_count <- readFastMutInt symtab_next
+            name_count <- readFirstFastMutInt symtab_next
             symtab_map  <- readIORef symtab_map
             putSymbolTable bh_fs name_count symtab_map
             pure name_count
@@ -348,9 +348,9 @@ putName _dict BinSymbolTable{
        case lookupUFM symtab_map name of
          Just (off,_) -> put_ bh (fromIntegral off :: Word32)
          Nothing -> do
-            off <- readFastMutInt symtab_next
+            off <- readFirstFastMutInt symtab_next
             -- massert (off < 2^(30 :: Int))
-            writeFastMutInt symtab_next (off+1)
+            writeFirstFastMutInt symtab_next (off+1)
             writeIORef symtab_map_ref
                 $! addToUFM symtab_map name (off,name)
             put_ bh (fromIntegral off :: Word32)
diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs
index 6474fbeb8e..3e671e43c2 100644
--- a/compiler/GHC/Iface/Ext/Binary.hs
+++ b/compiler/GHC/Iface/Ext/Binary.hs
@@ -118,7 +118,7 @@ writeHieFile hie_file_path hiefile = do
   seekBin bh symtab_p
 
   -- write the symbol table itself
-  symtab_next' <- readFastMutInt symtab_next
+  symtab_next' <- readFirstFastMutInt symtab_next
   symtab_map'  <- readIORef symtab_map
   putSymbolTable bh symtab_next' symtab_map'
 
@@ -128,7 +128,7 @@ writeHieFile hie_file_path hiefile = do
   seekBin bh dict_p
 
   -- write the dictionary itself
-  dict_next <- readFastMutInt dict_next_ref
+  dict_next <- readFirstFastMutInt dict_next_ref
   dict_map  <- readIORef dict_map_ref
   putDictionary bh dict_next dict_map
 
@@ -256,9 +256,9 @@ putFastString HieDictionary { hie_dict_next = j_r,
     case lookupUFM_Directly out unique of
         Just (j, _)  -> put_ bh (fromIntegral j :: Word32)
         Nothing -> do
-           j <- readFastMutInt j_r
+           j <- readFirstFastMutInt j_r
            put_ bh (fromIntegral j :: Word32)
-           writeFastMutInt j_r (j + 1)
+           writeFirstFastMutInt j_r (j + 1)
            writeIORef out_r $! addToUFM_Directly out unique (j, f)
 
 putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,HieName) -> IO ()
@@ -297,8 +297,8 @@ putName (HieSymbolTable next ref) bh name = do
       put_ bh (fromIntegral off :: Word32)
     Just (off, _) -> put_ bh (fromIntegral off :: Word32)
     Nothing -> do
-        off <- readFastMutInt next
-        writeFastMutInt next (off+1)
+        off <- readFirstFastMutInt next
+        writeFirstFastMutInt next (off+1)
         writeIORef ref $! addToUFM symmap name (off, toHieName name)
         put_ bh (fromIntegral off :: Word32)
 
diff --git a/compiler/GHC/StgToJS/Ids.hs b/compiler/GHC/StgToJS/Ids.hs
index 5d28b511f6..83d5eae172 100644
--- a/compiler/GHC/StgToJS/Ids.hs
+++ b/compiler/GHC/StgToJS/Ids.hs
@@ -68,8 +68,8 @@ freshUnique = do
   id_gen <- State.gets gsId
   liftIO $ do
     -- no need for atomicFetchAdd as we don't use threads in G
-    v <- readFastMutInt id_gen
-    writeFastMutInt id_gen (v+1)
+    v <- readFirstFastMutInt id_gen
+    writeFirstFastMutInt id_gen (v+1)
     pure v
 
 -- | Get fresh local Ident of the form: h$$unit:module_uniq
diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs
index 0fa1708e96..511bcdbe3b 100644
--- a/compiler/GHC/Utils/Binary.hs
+++ b/compiler/GHC/Utils/Binary.hs
@@ -185,16 +185,16 @@ setUserData :: BinHandle -> UserData -> BinHandle
 setUserData bh us = bh { bh_usr = us }
 
 getBinIndex :: BinHandle -> IO Int
-getBinIndex (BinMem _ ints _) = readFastMutInt ints
+getBinIndex (BinMem _ ints _) = readFirstFastMutInt ints
 
 putBinIndex :: BinHandle -> Int -> IO ()
-putBinIndex (BinMem _ ints _) x = writeFastMutInt ints x
+putBinIndex (BinMem _ ints _) x = writeFirstFastMutInt ints x
 
 getArraySize :: BinHandle -> IO Int
-getArraySize (BinMem _ ints _) = readFastMutInt2 ints
+getArraySize (BinMem _ ints _) = readSecondFastMutInt ints
 
 putArraySize :: BinHandle -> Int -> IO ()
-putArraySize (BinMem _ ints _) x = writeFastMutInt2 ints x
+putArraySize (BinMem _ ints _) x = writeSecondFastMutInt ints x
 
 -- | Get access to the underlying buffer.
 withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a
@@ -205,10 +205,9 @@ withBinBuffer h@(BinMem _ _ arr_r) action = do
 
 unsafeUnpackBinBuffer :: ByteString -> IO BinHandle
 unsafeUnpackBinBuffer (BS.BS arr len) = do
-  arr_r <- newIORef arr
-  ix_r <- newFastMutInt 0
-  sz_r <- newFastMutInt len
-  return (BinMem noUserData ix_r sz_r arr_r)
+  arr_r   <- newIORef arr
+  ix_sz_r <- newFastMutInt2 0 len
+  return (BinMem noUserData ix_sz_r arr_r)
 
 ---------------------------------------------------------------
 -- Bin
@@ -264,11 +263,11 @@ seekBin h (BinPtr !p) = do
 
 -- | SeekBin but without calling expandBin
 seekBinNoExpand :: BinHandle -> Bin a -> IO ()
-seekBinNoExpand (BinMem _ ix_r sz_r _) (BinPtr !p) = do
-  sz <- readFastMutInt sz_r
+seekBinNoExpand (BinMem _ ix_sz_r _) (BinPtr !p) = do
+  sz <- readSecondFastMutInt ix_sz_r
   if (p >= sz)
         then panic "seekBinNoExpand: seek out of range"
-        else writeFastMutInt ix_r p
+        else writeFirstFastMutInt ix_sz_r p
 
 writeBinMem :: BinHandle -> FilePath -> IO ()
 writeBinMem bh@(BinMem _ _ arr_r) fn = do
@@ -1175,7 +1174,7 @@ initFSTable bh = do
         , fs_tab_map  = dict_map_ref
         }
   let put_dict = do
-        fs_count <- readFastMutInt dict_next_ref
+        fs_count <- readFirstFastMutInt dict_next_ref
         dict_map  <- readIORef dict_map_ref
         putDictionary bh fs_count dict_map
         pure fs_count
@@ -1199,8 +1198,8 @@ allocateFastString FSTable { fs_tab_next = j_r
     case lookupUFM_Directly out uniq of
         Just (j, _)  -> return (fromIntegral j :: Word32)
         Nothing -> do
-           j <- readFastMutInt j_r
-           writeFastMutInt j_r (j + 1)
+           j <- readFirstFastMutInt j_r
+           writeFirstFastMutInt j_r (j + 1)
            writeIORef out_r $! addToUFM_Directly out uniq (j, f)
            return (fromIntegral j :: Word32)
 
diff --git a/compiler/GHC/Utils/BufHandle.hs b/compiler/GHC/Utils/BufHandle.hs
index 79d2dbed60..0cc1d015b7 100644
--- a/compiler/GHC/Utils/BufHandle.hs
+++ b/compiler/GHC/Utils/BufHandle.hs
@@ -59,13 +59,13 @@ buf_size = 8192
 
 bPutChar :: BufHandle -> Char -> IO ()
 bPutChar b@(BufHandle buf r hdl) !c = do
-  i <- readFastMutInt r
+  i <- readFirstFastMutInt r
   if (i >= buf_size)
         then do hPutBuf hdl buf buf_size
-                writeFastMutInt r 0
+                writeFirstFastMutInt r 0
                 bPutChar b c
         else do pokeElemOff buf i (fromIntegral (ord c) :: Word8)
-                writeFastMutInt r (i+1)
+                writeFirstFastMutInt r (i+1)
 
 -- Equivalent of the text/str, text/unpackNBytes#, text/[] rules
 -- in GHC.Utils.Ppr.
@@ -85,9 +85,9 @@ bPutChar b@(BufHandle buf r hdl) !c = do
 
 bPutStr :: BufHandle -> String -> IO ()
 bPutStr (BufHandle buf r hdl) !str = do
-  i <- readFastMutInt r
+  i <- readFirstFastMutInt r
   loop str i
-  where loop "" !i = do writeFastMutInt r i; return ()
+  where loop "" !i = do writeFirstFastMutInt r i; return ()
         loop (c:cs) !i
            | i >= buf_size = do
                 hPutBuf hdl buf buf_size
@@ -107,46 +107,46 @@ bPutBS b bs = BS.unsafeUseAsCStringLen bs $ bPutCStringLen b
 
 bPutCStringLen :: BufHandle -> CStringLen -> IO ()
 bPutCStringLen b@(BufHandle buf r hdl) cstr@(ptr, len) = do
-  i <- readFastMutInt r
+  i <- readFirstFastMutInt r
   if (i + len) >= buf_size
         then do hPutBuf hdl buf i
-                writeFastMutInt r 0
+                writeFirstFastMutInt r 0
                 if (len >= buf_size)
                     then hPutBuf hdl ptr len
                     else bPutCStringLen b cstr
         else do
                 copyBytes (buf `plusPtr` i) ptr len
-                writeFastMutInt r (i + len)
+                writeFirstFastMutInt r (i + len)
 
 bPutPtrString :: BufHandle -> PtrString -> IO ()
 bPutPtrString b@(BufHandle buf r hdl) l@(PtrString a len) = l `seq` do
-  i <- readFastMutInt r
+  i <- readFirstFastMutInt r
   if (i+len) >= buf_size
         then do hPutBuf hdl buf i
-                writeFastMutInt r 0
+                writeFirstFastMutInt r 0
                 if (len >= buf_size)
                     then hPutBuf hdl a len
                     else bPutPtrString b l
         else do
                 copyBytes (buf `plusPtr` i) a len
-                writeFastMutInt r (i+len)
+                writeFirstFastMutInt r (i+len)
 
 -- | Replicate an 8-bit character
 bPutReplicate :: BufHandle -> Int -> Char -> IO ()
 bPutReplicate (BufHandle buf r hdl) len c = do
-  i <- readFastMutInt r
+  i <- readFirstFastMutInt r
   let oc = fromIntegral (ord c)
   if (i+len) < buf_size
     then do
       fillBytes (buf `plusPtr` i) oc len
-      writeFastMutInt r (i+len)
+      writeFirstFastMutInt r (i+len)
     else do
       -- flush the current buffer
       when (i /= 0) $ hPutBuf hdl buf i
       if (len < buf_size)
         then do
           fillBytes buf oc len
-          writeFastMutInt r len
+          writeFirstFastMutInt r len
         else do
           -- fill a full buffer
           fillBytes buf oc buf_size
@@ -154,12 +154,12 @@ bPutReplicate (BufHandle buf r hdl) len c = do
           let go n | n >= buf_size = do
                                        hPutBuf hdl buf buf_size
                                        go (n-buf_size)
-                   | otherwise     = writeFastMutInt r n
+                   | otherwise     = writeFirstFastMutInt r n
           go len
 
 bFlush :: BufHandle -> IO ()
 bFlush (BufHandle buf r hdl) = do
-  i <- readFastMutInt r
+  i <- readFirstFastMutInt r
   when (i > 0) $ hPutBuf hdl buf i
   free buf
   return ()