Merge pull request #513 from IntersectMBO/jdral/release-reftracker-ex…

…ception Release a `RefTracker` even if the corresponding finaliser threw an error
IntersectMBO · Jan 7, 2025 · 0c74e7a · 0c74e7a
2 parents 5821748 + 2880e5e
commit 0c74e7a
Show file tree

Hide file tree

Showing 2 changed files with 10 additions and 1 deletion.
diff --git a/src-control/Control/RefCount.hs b/src-control/Control/RefCount.hs
@@ -245,8 +245,8 @@ releaseRef ::
   -> m ()
 releaseRef ref@Ref{refobj} = do
     assertNoDoubleRelease ref
-    decrementRefCounter (getRefCounter refobj)
     releaseRefTracker ref
+    decrementRefCounter (getRefCounter refobj)
 
 {-# COMPLETE DeRef #-}
 #if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)

diff --git a/test-control/Test/Control/RefCount.hs b/test-control/Test/Control/RefCount.hs
@@ -28,6 +28,7 @@ tests = testGroup "Control.RefCount" [
     , testProperty "prop_ref_never_released0" prop_ref_never_released0
     , testProperty "prop_ref_never_released1" prop_ref_never_released1
     , testProperty "prop_ref_never_released2" prop_ref_never_released2
+    , testProperty "prop_release_ref_exception" prop_release_ref_exception
 #endif
     ]
 
@@ -182,5 +183,13 @@ expectRefNeverReleased e@RefNeverReleased{} =
     return (tabulate "displayException" [displayException e] (property True))
 expectRefNeverReleased e =
     return (counterexample (displayException e) $ property False)
+
+-- | If a finaliser throws an exception, then the 'RefTracker' is still released
+prop_release_ref_exception :: Property
+prop_release_ref_exception = once $ ioProperty $ do
+    finalised <- newIORef False
+    ref  <- newRef (writeIORef finalised True >> error "oops") TestObject
+    _ <- try @SomeException (releaseRef ref)
+    checkForgottenRefs
 #endif