diff options
-rw-r--r-- | libraries/base/GHC/Event/IntTable.hs | 23 | ||||
-rw-r--r-- | libraries/base/GHC/Event/IntVar.hs | 31 | ||||
-rw-r--r-- | libraries/base/base.cabal | 2 |
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 |