FastMutInt: Ensure that newFastMutInt initializes value

Updates haddock submodule.

7 files changed, 31 insertions, 38 deletions

diff --git a/compiler/GHC/Data/FastMutInt.hs b/compiler/GHC/Data/FastMutInt.hs
index 0cc26d793c..bc4c413bdc 100644
--- a/compiler/GHC/Data/FastMutInt.hs
+++ b/compiler/GHC/Data/FastMutInt.hs
@@ -17,21 +17,25 @@ import GHC.Prelude
 import Data.Bits
 import GHC.Base
 
-newFastMutInt :: IO FastMutInt
-readFastMutInt :: FastMutInt -> IO Int
-writeFastMutInt :: FastMutInt -> Int -> IO ()
-
-data FastMutInt = FastMutInt (MutableByteArray# RealWorld)
-
-newFastMutInt = IO $ \s ->
-  case newByteArray# size s of { (# s, arr #) ->
-  (# s, FastMutInt arr #) }
-  where !(I# size) = finiteBitSize (0 :: Int) `unsafeShiftR` 3
+data FastMutInt = FastMutInt !(MutableByteArray# RealWorld)
+
+newFastMutInt :: Int -> IO FastMutInt
+newFastMutInt n = do
+    x <- create
+    writeFastMutInt x n
+    return x
+  where
+    !(I# size) = finiteBitSize (0 :: Int) `unsafeShiftR` 3
+    create = IO $ \s ->
+      case newByteArray# size s of { (# s, arr #) ->
+        (# s, FastMutInt arr #) }
 
+readFastMutInt :: FastMutInt -> IO Int
 readFastMutInt (FastMutInt arr) = IO $ \s ->
   case readIntArray# arr 0# s of { (# s, i #) ->
   (# s, I# i #) }
 
+writeFastMutInt :: FastMutInt -> Int -> IO ()
 writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s ->
   case writeIntArray# arr 0# i s of { s ->
   (# s, () #) }
diff --git a/compiler/GHC/Data/FastString.hs b/compiler/GHC/Data/FastString.hs
index 1388563ca7..188c2166b3 100644
--- a/compiler/GHC/Data/FastString.hs
+++ b/compiler/GHC/Data/FastString.hs
@@ -300,13 +300,13 @@ and updates to multiple buckets with low synchronization overhead.
 See Note [Updating the FastString table] on how it's updated.
 -}
 data FastStringTable = FastStringTable
-  {-# UNPACK #-} !(IORef Int) -- the unique ID counter shared with all buckets
-  {-# UNPACK #-} !(IORef Int) -- number of computed z-encodings for all buckets
+  {-# UNPACK #-} !FastMutInt -- the unique ID counter shared with all buckets
+  {-# UNPACK #-} !FastMutInt -- number of computed z-encodings for all buckets
   (Array# (IORef FastStringTableSegment)) -- concurrent segments
 
 data FastStringTableSegment = FastStringTableSegment
-  {-# UNPACK #-} !(MVar ()) -- the lock for write in each segment
-  {-# UNPACK #-} !(IORef Int) -- the number of elements
+  {-# UNPACK #-} !(MVar ())  -- the lock for write in each segment
+  {-# UNPACK #-} !FastMutInt -- the number of elements
   (MutableArray# RealWorld [FastString]) -- buckets in this segment
 
 {-
@@ -367,7 +367,7 @@ stringTable = unsafePerformIO $ do
       loop a# i# s1#
         | isTrue# (i# ==# numSegments#) = s1#
         | otherwise = case newMVar () `unIO` s1# of
-            (# s2#, lock #) -> case newIORef 0 `unIO` s2# of
+            (# s2#, lock #) -> case newFastMutInt 0 `unIO` s2# of
               (# s3#, counter #) -> case newArray# initialNumBuckets# [] s3# of
                 (# s4#, buckets# #) -> case newIORef
                     (FastStringTableSegment lock counter buckets#) `unIO` s4# of
diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs
index e2a6f0a79b..c2276e2b01 100644
--- a/compiler/GHC/Iface/Binary.hs
+++ b/compiler/GHC/Iface/Binary.hs
@@ -217,14 +217,12 @@ putWithUserData traceBinIface bh payload = do
     symtab_p_p <- tellBin bh
     put_ bh symtab_p_p
     -- Make some initial state
-    symtab_next <- newFastMutInt
-    writeFastMutInt symtab_next 0
+    symtab_next <- newFastMutInt 0
     symtab_map <- newIORef emptyUFM
     let bin_symtab = BinSymbolTable {
                          bin_symtab_next = symtab_next,
                          bin_symtab_map  = symtab_map }
-    dict_next_ref <- newFastMutInt
-    writeFastMutInt dict_next_ref 0
+    dict_next_ref <- newFastMutInt 0
     dict_map_ref <- newIORef emptyUFM
     let bin_dict = BinDictionary {
                        bin_dict_next = dict_next_ref,
diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs
index 69aee26586..b118cd8da7 100644
--- a/compiler/GHC/Iface/Ext/Binary.hs
+++ b/compiler/GHC/Iface/Ext/Binary.hs
@@ -98,14 +98,12 @@ writeHieFile hie_file_path hiefile = do
   put_ bh0 symtab_p_p
 
   -- Make some initial state
-  symtab_next <- newFastMutInt
-  writeFastMutInt symtab_next 0
+  symtab_next <- newFastMutInt 0
   symtab_map <- newIORef emptyUFM :: IO (IORef (UniqFM Name (Int, HieName)))
   let hie_symtab = HieSymbolTable {
                       hie_symtab_next = symtab_next,
                       hie_symtab_map  = symtab_map }
-  dict_next_ref <- newFastMutInt
-  writeFastMutInt dict_next_ref 0
+  dict_next_ref <- newFastMutInt 0
   dict_map_ref <- newIORef emptyUFM
   let hie_dict = HieDictionary {
                       hie_dict_next = dict_next_ref,
diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs
index 5ee0806cc1..a925b0a999 100644
--- a/compiler/GHC/Utils/Binary.hs
+++ b/compiler/GHC/Utils/Binary.hs
@@ -134,10 +134,8 @@ instance Binary BinData where
 
 dataHandle :: BinData -> IO BinHandle
 dataHandle (BinData size bin) = do
-  ixr <- newFastMutInt
-  szr <- newFastMutInt
-  writeFastMutInt ixr 0
-  writeFastMutInt szr size
+  ixr <- newFastMutInt 0
+  szr <- newFastMutInt size
   binr <- newIORef bin
   return (BinMem noUserData ixr szr binr)
 
@@ -215,10 +213,8 @@ openBinMem size
  | otherwise = do
    arr <- mallocForeignPtrBytes size
    arr_r <- newIORef arr
-   ix_r <- newFastMutInt
-   writeFastMutInt ix_r 0
-   sz_r <- newFastMutInt
-   writeFastMutInt sz_r size
+   ix_r <- newFastMutInt 0
+   sz_r <- newFastMutInt size
    return (BinMem noUserData ix_r sz_r arr_r)
 
 tellBin :: BinHandle -> IO (Bin a)
@@ -251,10 +247,8 @@ readBinMem filename = do
        error ("Binary.readBinMem: only read " ++ show count ++ " bytes")
   hClose h
   arr_r <- newIORef arr
-  ix_r <- newFastMutInt
-  writeFastMutInt ix_r 0
-  sz_r <- newFastMutInt
-  writeFastMutInt sz_r filesize
+  ix_r <- newFastMutInt 0
+  sz_r <- newFastMutInt filesize
   return (BinMem noUserData ix_r sz_r arr_r)
 
 -- expand the size of the array to include a specified offset
@@ -896,7 +890,7 @@ lazyGet bh = do
     a <- unsafeInterleaveIO $ do
         -- NB: Use a fresh off_r variable in the child thread, for thread
         -- safety.
-        off_r <- newFastMutInt
+        off_r <- newFastMutInt 0
         getAt bh { _off_r = off_r } p_a
     seekBin bh p -- skip over the object for now
     return a
diff --git a/compiler/GHC/Utils/BufHandle.hs b/compiler/GHC/Utils/BufHandle.hs
index b0b829f96f..aed15610cb 100644
--- a/compiler/GHC/Utils/BufHandle.hs
+++ b/compiler/GHC/Utils/BufHandle.hs
@@ -46,8 +46,7 @@ data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8)
 newBufHandle :: Handle -> IO BufHandle
 newBufHandle hdl = do
   ptr <- mallocBytes buf_size
-  r <- newFastMutInt
-  writeFastMutInt r 0
+  r <- newFastMutInt 0
   return (BufHandle ptr r hdl)
 
 buf_size :: Int
diff --git a/utils/haddock b/utils/haddock
-Subproject bd206f09715420aaa62341c9a96411a684eee6e
+Subproject d1bf3e5030ebf0f8f7443b394abb96da2f216eb