base: Eliminate pinned allocations from IntTable

This replaces the ForeignPtr used to track IntTable's pointer size with
a single-entry mutable ByteArray#, eliminating the fragmentation noted
in #19171.

Fixes #19171.

3 files changed, 43 insertions, 13 deletions

diff --git a/libraries/base/GHC/Event/IntTable.hs b/libraries/base/GHC/Event/IntTable.hs
index a821cfdf07..870d0386b4 100644
--- a/libraries/base/GHC/Event/IntTable.hs
+++ b/libraries/base/GHC/Event/IntTable.hs
@@ -17,11 +17,10 @@ module GHC.Event.IntTable
 import Data.Bits ((.&.), shiftL, shiftR)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import Data.Maybe (Maybe(..), isJust)
-import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtr, withForeignPtr)
-import Foreign.Storable (peek, poke)
 import GHC.Base (Monad(..), (=<<), ($), ($!), const, liftM, otherwise, when)
 import GHC.Classes (Eq(..), Ord(..))
 import GHC.Event.Arr (Arr)
+import GHC.Event.IntVar
 import GHC.Num (Num(..))
 import GHC.Prim (seq)
 import GHC.Types (Bool(..), IO(..), Int(..))
@@ -35,7 +34,7 @@ newtype IntTable a = IntTable (IORef (IT a))
 
 data IT a = IT {
       tabArr  :: {-# UNPACK #-} !(Arr (Bucket a))
-    , tabSize :: {-# UNPACK #-} !(ForeignPtr Int)
+    , tabSize :: {-# UNPACK #-} !IntVar
     }
 
 data Bucket a = Empty
@@ -61,8 +60,7 @@ new capacity = IntTable `liftM` (newIORef =<< new_ capacity)
 new_ :: Int -> IO (IT a)
 new_ capacity = do
   arr <- Arr.new Empty capacity
-  size <- mallocForeignPtr
-  withForeignPtr size $ \ptr -> poke ptr 0
+  size <- newIntVar 0
   return IT { tabArr = arr
             , tabSize = size
             }
@@ -81,7 +79,7 @@ grow oldit ref size = do
                 copyBucket (m+1) bucketNext
           copyBucket n =<< Arr.read (tabArr oldit) i
   copySlot 0 0
-  withForeignPtr (tabSize newit) $ \ptr -> poke ptr size
+  writeIntVar (tabSize newit) size
   writeIORef ref newit
 
 -- | @insertWith f k v table@ inserts @k@ into @table@ with value @v@.
@@ -100,13 +98,13 @@ insertWith f k v inttable@(IntTable ref) = do
           Arr.write tabArr idx (Bucket k v' next)
           return (Just bucketValue)
         | otherwise = go bkt { bucketNext = seen } bucketNext
-      go seen _ = withForeignPtr tabSize $ \ptr -> do
-        size <- peek ptr
+      go seen _ = do
+        size <- readIntVar tabSize
         if size + 1 >= Arr.size tabArr - (Arr.size tabArr `shiftR` 2)
           then grow it ref size >> insertWith f k v inttable
           else do
             v `seq` Arr.write tabArr idx (Bucket k v seen)
-            poke ptr (size + 1)
+            writeIntVar tabSize (size + 1)
             return Nothing
   go Empty =<< Arr.read tabArr idx
 {-# INLINABLE insertWith #-}
@@ -138,9 +136,8 @@ updateWith f k (IntTable ref) = do
   (del, oldVal, newBucket) <- go `liftM` Arr.read tabArr idx
   when (isJust oldVal) $ do
     Arr.write tabArr idx newBucket
-    when del $
-      withForeignPtr tabSize $ \ptr -> do
-        size <- peek ptr
-        poke ptr (size - 1)
+    when del $ do
+      size <- readIntVar tabSize
+      writeIntVar tabSize (size - 1)
   return oldVal
 
diff --git a/libraries/base/GHC/Event/IntVar.hs b/libraries/base/GHC/Event/IntVar.hs
new file mode 100644
index 0000000000..f52deebd00
--- /dev/null
+++ b/libraries/base/GHC/Event/IntVar.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude, UnboxedTuples #-}
+
+module GHC.Event.IntVar
+    ( IntVar
+    , newIntVar
+    , readIntVar
+    , writeIntVar
+    ) where
+
+import GHC.Base
+
+data IntVar = IntVar (MutableByteArray# RealWorld)
+
+newIntVar :: Int -> IO IntVar
+newIntVar n = do
+  iv <- IO $ \s ->
+    case newByteArray# 1# s of
+      (# s', mba #) -> (# s', IntVar mba #)
+  writeIntVar iv n
+  return iv
+
+readIntVar :: IntVar -> IO Int
+readIntVar (IntVar mba) = IO $ \s ->
+  case readIntArray# mba 0# s of
+    (# s', n #) -> (# s', I# n #)
+
+writeIntVar :: IntVar -> Int -> IO ()
+writeIntVar (IntVar mba) (I# n) = IO $ \s ->
+  case writeIntArray# mba 0# n s of
+    s' -> (# s', () #)
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index f620affcbf..36642abea4 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -405,6 +405,7 @@ Library
             GHC.Event.Arr
             GHC.Event.Array
             GHC.Event.IntTable
+            GHC.Event.IntVar
             GHC.Event.PSQ
             GHC.Event.Unique
             System.CPUTime.Windows
@@ -422,6 +423,7 @@ Library
             GHC.Event.Control
             GHC.Event.EPoll
             GHC.Event.IntTable
+            GHC.Event.IntVar
             GHC.Event.Internal
             GHC.Event.KQueue
             GHC.Event.Manager