[GHC] #8793: Improve GHC.Event.IntTable performance

[GHC]

#8793: Improve GHC.Event.IntTable performance
-------------------------------------+-------------------------------------
        Reporter:  cdk               |                Owner:
            Type:  task              |               Status:  patch
        Priority:  normal            |            Milestone:  8.0.1
       Component:  Core Libraries    |              Version:  7.6.3
      Resolution:                    |             Keywords:
Operating System:  Unknown/Multiple  |         Architecture:
 Type of failure:  Runtime           |  Unknown/Multiple
  performance bug                    |            Test Case:
      Blocked By:                    |             Blocking:
 Related Tickets:                    |  Differential Rev(s):
       Wiki Page:                    |
-------------------------------------+-------------------------------------
Changes (by jscholl):

 * status:  infoneeded => patch


Comment:

 Okay, I just get {{{IndexError: pop from empty list}}} if I try to attach
 a file, so I put it here...

 Improving {{{lookup}}}:

 {{{
 --- a/GHC/Event/IntTable.hs
 +++ b/GHC/Event/IntTable.hs
 @@ -45,11 +45,12 @@
  lookup :: Int -> IntTable a -> IO (Maybe a)
  lookup k (IntTable ref) = do
    let go Bucket{..}
 -        | bucketKey == k = return (Just bucketValue)
 +        | bucketKey == k = Just bucketValue
          | otherwise      = go bucketNext
 -      go _ = return Nothing
 +      go _ = Nothing
    it at IT{..} <- readIORef ref
 -  go =<< Arr.read tabArr (indexOf k it)
 +  bkt <- Arr.read tabArr (indexOf k it)
 +  return (go bkt)

  new :: Int -> IO (IntTable a)
  new capacity = IntTable `liftM` (newIORef =<< new_ capacity)
 }}}

 Cleaning up {{{updateWith}}}:

 {{{
 --- a/GHC/Event/IntTable.hs
 +++ b/GHC/Event/IntTable.hs
 @@ -13,7 +13,7 @@

  import Data.Bits ((.&.), shiftL, shiftR)
  import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 -import Data.Maybe (Maybe(..), isJust, isNothing)
 +import Data.Maybe (Maybe(..), isJust)
  import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtr, withForeignPtr)
  import Foreign.Storable (peek, poke)
  import GHC.Base (Monad(..), (=<<), ($), const, liftM, otherwise, when)
 @@ -123,20 +123,17 @@
  updateWith f k (IntTable ref) = do
    it at IT{..} <- readIORef ref
    let idx = indexOf k it
 -      go changed bkt at Bucket{..}
 -        | bucketKey == k =
 -            let fbv = f bucketValue
 -                !nb = case fbv of
 -                        Just val -> bkt { bucketValue = val }
 -                        Nothing  -> bucketNext
 -            in (fbv, Just bucketValue, nb)
 -        | otherwise = case go changed bucketNext of
 +      go bkt at Bucket{..}
 +        | bucketKey == k = case f bucketValue of
 +            Just val -> let !nb = bkt { bucketValue = val } in (False,
 Just bucketValue, nb)
 +            Nothing  -> (True, Just bucketValue, bucketNext)
 +        | otherwise = case go bucketNext of
                          (fbv, ov, nb) -> (fbv, ov, bkt { bucketNext = nb
 })
 -      go _ e = (Nothing, Nothing, e)
 -  (fbv, oldVal, newBucket) <- go False `liftM` Arr.read tabArr idx
 +      go e = (True, Nothing, e)
 +  (del, oldVal, newBucket) <- go `liftM` Arr.read tabArr idx
    when (isJust oldVal) $ do
      Arr.write tabArr idx newBucket
 -    when (isNothing fbv) $
 +    when del $
        withForeignPtr tabSize $ \ptr -> do
          size <- peek ptr
          poke ptr (size - 1)

 }}}

--
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/8793#comment:10>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler