Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Fix a bunch of bugs and infelicities #9

Open
wants to merge 3 commits into
base: master
Choose a base branch
from
Open

Fix a bunch of bugs and infelicities #9

Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
64deaaa
Fix a bunch of bugs and infelicities
treeowl Jan 15, 2019
d48056c
Update Control/Concurrent/MVar/Strict.hs
treeowl Jan 8, 2022
e70503c
Update Control/Concurrent/MVar/Strict.hs
ygale Jan 9, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
88 changes: 29 additions & 59 deletions Control/Concurrent/MVar/Strict.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP, BangPatterns,
MagicHash, UnboxedTuples, ScopedTypeVariables #-}
{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module : Control.Concurrent.MVar.Strict
Expand Down Expand Up @@ -30,23 +29,26 @@ module Control.Concurrent.MVar.Strict
, swapMVar -- :: MVar a -> a -> IO a
, tryTakeMVar -- :: MVar a -> IO (Maybe a)
, tryPutMVar -- :: MVar a -> a -> IO Bool
#if !MIN_VERSION_base(4,7,0)
, tryReadMVar -- :: MVar a -> IO (Maybe a)
treeowl marked this conversation as resolved.
Show resolved Hide resolved
#endif
, isEmptyMVar -- :: MVar a -> IO Bool
, withMVar -- :: MVar a -> (a -> IO b) -> IO b
, modifyMVar_ -- :: MVar a -> (a -> IO a) -> IO ()
, modifyMVar -- :: MVar a -> (a -> IO (a,b)) -> IO b
, addMVarFinalizer -- :: MVar a -> IO () -> IO ()
) where

import Control.Concurrent.MVar ( newEmptyMVar, takeMVar,
tryTakeMVar, isEmptyMVar, addMVarFinalizer
)
import GHC.Exts
import GHC.Base
import GHC.MVar (MVar(MVar))
import Control.Concurrent.MVar
( MVar, newEmptyMVar, readMVar, takeMVar
, tryTakeMVar, isEmptyMVar, addMVarFinalizer, withMVar
)
import qualified Control.Concurrent.MVar as MV

import Control.Exception as Exception
-- import Control.Parallel.Strategies
import Control.DeepSeq
import Control.Monad ((>=>))

-- |Put a value into an 'MVar'. If the 'MVar' is currently full,
-- 'putMVar' will wait until it becomes empty.
Expand All @@ -63,22 +65,27 @@ import Control.DeepSeq
-- fairness properties of abstractions built using 'MVar's.
--
putMVar :: NFData a => MVar a -> a -> IO ()
#ifndef __HADDOCK__
putMVar (MVar mvar#) !x = rnf x `seq` IO $ \ s# -> -- strict!
case putMVar# mvar# x s# of
s2# -> (# s2#, () #)
#endif
putMVar !mv !x = rnf x `seq` MV.putMVar mv x
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Suggested change
putMVar !mv !x = rnf x `seq` MV.putMVar mv x
putMVar !mv x = rnf x `seq` MV.putMVar mv x

Gratuitous bang?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

That's needed to preserve the original behavior if rnf doesn't actually force anything.

instance NFData Foo where
  rnf _ = ()

Copy link
Contributor Author

@treeowl treeowl Jan 16, 2019 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

What we can do is change that to putMVar !mv x = force x `seq` MV.putMVar mv x. I guess that's better.

Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm afraid that subtlety is lost on me. force x is equivalent to rnf x `seq` x, and that's materially different from rnf x? I'll take your word for it.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Define

data Foo
instance NFData Foo where
  rnf _ = ()
f, g :: Foo -> ()
f x = force x `seq` ()
g x = rnf x `seq` ()

Then f undefined = undefined, but g undefined = ().

Whether this is the "right" decision is somewhat unclear to me, but it matches the previous behavior.

Copy link

@crockeea crockeea Jan 16, 2019 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Thanks for that example. The documentation for rnf says:

rnf should reduce its argument to normal form (that is, fully evaluate all sub-components), and then return '()'.

so doesn't your instance violate that? At any rate, this is indeed a pathological corner case, and I have no opinion.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

There are special circumstances when you might conceivably want rnf to do nothing, as a generic way to force the spine of a data structure but not its leaves. Do we want to worry about that?


-- | A non-blocking version of 'putMVar'. The 'tryPutMVar' function
-- attempts to put the value @a@ into the 'MVar', returning 'True' if
-- it was successful, or 'False' otherwise.
--
tryPutMVar :: NFData a => MVar a -> a -> IO Bool
#ifndef __HADDOCK__
tryPutMVar (MVar mvar#) !x = IO $ \ s# -> -- strict!
case tryPutMVar# mvar# x s# of
(# s, 0# #) -> (# s, False #)
(# s, _ #) -> (# s, True #)
tryPutMVar !mv !x = rnf x `seq` MV.tryPutMVar mv x
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Gratuitous bang?

Suggested change
tryPutMVar !mv !x = rnf x `seq` MV.tryPutMVar mv x
tryPutMVar !mv x = rnf x `seq` MV.tryPutMVar mv x

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Again, needed if we want to force to WHNF if rnf does nothing.


#if !MIN_VERSION_base(4,7,0)
-- |A non-blocking version of 'readMVar'. The 'tryReadMVar' function
-- returns immediately, with 'Nothing' if the 'MVar' was empty, or
-- @'Just' a@ if the 'MVar' was full with contents @a@.
tryReadMVar :: MVar a -> IO (Maybe a)
-- This is a best-effort compatibility shim for really old GHC versions.
-- It's not really what you'd call *right*.
tryReadMVar !m = uninterruptibleMask $ \_ -> do
Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Actually, mask should be enough, since nothing in here is interruptible. An earlier draft used putMVar. I'm not sure which version makes the least nonsense. But ultimately, it doesn't really matter much, since this is a half-broken shim. (readMVar itself should be considered half-broken for earlier base versions, since it used to be non-atomic and potentially disruptive.)

mv <- tryTakeMVar m
case mv of
Nothing -> return Nothing
Just v -> MV.tryPutMVar m v >> return mv
#endif

-- |Create an 'MVar' which contains the supplied value.
Expand All @@ -88,68 +95,31 @@ newMVar value =
putMVar mvar value >>
return mvar

{-|
This is a combination of 'takeMVar' and 'putMVar'; ie. it takes the value
from the 'MVar', puts it back, and also returns it.
-}
readMVar :: NFData a => MVar a -> IO a
readMVar m = mask $ \_ -> do
a <- takeMVar m
putMVar m a
return a

{-|
Take a value from an 'MVar', put a new value into the 'MVar' and
return the value taken. Note that there is a race condition whereby
another process can put something in the 'MVar' after the take
happens but before the put does.
-}
swapMVar :: NFData a => MVar a -> a -> IO a
swapMVar mvar new = mask $ \_ -> do
swapMVar !mvar new = seq (force new) $ mask $ \_ -> do
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Shouldn't the local putMVar suffice, like the original version?

Copy link
Contributor Author

@treeowl treeowl Jan 16, 2019 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I believe we want to force before we take the MVar. That way we don't hold the MVar any longer than necessary. We also avoid problems if the forcing throws an exception. Once we've forced manually, we don't want to do it again implicitly, because that would be a waste of time.

old <- takeMVar mvar
putMVar mvar new
MV.putMVar mvar new
return old

{-|
'withMVar' is a safe wrapper for operating on the contents of an
'MVar'. This operation is exception-safe: it will replace the
original contents of the 'MVar' if an exception is raised (see
"Control.Exception").
-}
{-# INLINE withMVar #-}
-- inlining has been reported to have dramatic effects; see
-- http://www.haskell.org//pipermail/haskell/2006-May/017907.html
withMVar :: NFData a => MVar a -> (a -> IO b) -> IO b
withMVar m io = mask $ \unmask -> do
a <- takeMVar m
b <- Exception.catch (unmask (io a))
(\(e :: SomeException) -> do putMVar m a; throw e)
putMVar m a
return b

{-|
A safe wrapper for modifying the contents of an 'MVar'. Like 'withMVar',
'modifyMVar' will replace the original contents of the 'MVar' if an
exception is raised during the operation.
-}
{-# INLINE modifyMVar_ #-}
modifyMVar_ :: NFData a => MVar a -> (a -> IO a) -> IO ()
modifyMVar_ m io = mask $ \unmask -> do
a <- takeMVar m
a' <- Exception.catch (unmask (io a))
(\(e :: SomeException) -> do putMVar m a; throw e)
putMVar m a'
modifyMVar_ m io = MV.modifyMVar_ m $ io >=> \p -> force p `seq` return p
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Bang on m?

Suggested change
modifyMVar_ m io = MV.modifyMVar_ m $ io >=> \p -> force p `seq` return p
modifyMVar_ !m io = MV.modifyMVar_ m $ io >=> \p -> force p `seq` return p

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

No need. MV.modifyMVar_ does that for us.


{-|
A slight variation on 'modifyMVar_' that allows a value to be
returned (@b@) in addition to the modified value of the 'MVar'.
-}
{-# INLINE modifyMVar #-}
modifyMVar :: NFData a => MVar a -> (a -> IO (a,b)) -> IO b
modifyMVar m io = mask $ \unmask -> do
a <- takeMVar m
(a',b) <- Exception.catch (unmask (io a))
(\(e :: SomeException) -> do putMVar m a; throw e)
putMVar m a'
return b

modifyMVar m io = MV.modifyMVar m $ io >=> \pq -> force (fst pq) `seq` return pq
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Bang on m?

Suggested change
modifyMVar m io = MV.modifyMVar m $ io >=> \pq -> force (fst pq) `seq` return pq
modifyMVar !m io = MV.modifyMVar m $ io >=> \pq -> force (fst pq) `seq` return pq

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Again, no need.