[commit: packages/stm] master: mkWeak# now expects raw State# function (8fb3b33)

git at git.haskell.org git at git.haskell.org
Wed Sep 23 06:44:11 UTC 2015


Repository : ssh://git@git.haskell.org/stm

On branch  : master
Link       : http://git.haskell.org/packages/stm.git/commitdiff/8fb3b3336971d784c091dbca674ae1401e506e76

>---------------------------------------------------------------

commit 8fb3b3336971d784c091dbca674ae1401e506e76
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Wed Sep 23 01:26:31 2015 +0200

    mkWeak# now expects raw State# function
    
    Fallout from GHC Trac #10867.


>---------------------------------------------------------------

8fb3b3336971d784c091dbca674ae1401e506e76
 Control/Concurrent/STM/TMVar.hs | 5 ++++-
 Control/Concurrent/STM/TVar.hs  | 5 ++++-
 2 files changed, 8 insertions(+), 2 deletions(-)

diff --git a/Control/Concurrent/STM/TMVar.hs b/Control/Concurrent/STM/TMVar.hs
index e9477df..eed4a9b 100644
--- a/Control/Concurrent/STM/TMVar.hs
+++ b/Control/Concurrent/STM/TMVar.hs
@@ -160,5 +160,8 @@ isEmptyTMVar (TMVar t) = do
 -- @since 2.4.4
 mkWeakTMVar :: TMVar a -> IO () -> IO (Weak (TMVar a))
 mkWeakTMVar tmv@(TMVar (TVar t#)) f = IO $ \s ->
-    case mkWeak# t# tmv f s of (# s1, w #) -> (# s1, Weak w #)
+    case mkWeak# t# tmv finalizer s of (# s1, w #) -> (# s1, Weak w #)
+  where
+    finalizer :: State# RealWorld -> State# RealWorld
+    finalizer s' = case unIO f s' of (# s'', () #) -> s''
 #endif
diff --git a/Control/Concurrent/STM/TVar.hs b/Control/Concurrent/STM/TVar.hs
index 709a7ca..dbf5321 100644
--- a/Control/Concurrent/STM/TVar.hs
+++ b/Control/Concurrent/STM/TVar.hs
@@ -77,4 +77,7 @@ swapTVar var new = do
 -- @since 2.4.3
 mkWeakTVar :: TVar a -> IO () -> IO (Weak (TVar a))
 mkWeakTVar t@(TVar t#) f = IO $ \s ->
-    case mkWeak# t# t f s of (# s1, w #) -> (# s1, Weak w #)
+    case mkWeak# t# t finalizer s of (# s1, w #) -> (# s1, Weak w #)
+  where
+    finalizer :: State# RealWorld -> State# RealWorld
+    finalizer s' = case unIO f s' of (# s'', () #) -> s''



More information about the ghc-commits mailing list