Running a "final" finaliser

[Adrian Hey]

Hello again,

I've tried the simplest possible reference counting approach which should
be OK if all finalisers are run eventually (as I think is the case currently
with ghc 6.2).

But I don't seem to be able to get it to work. I've attached the library
reference counting code (LibRef module) to the end of this message.

Intended use is something like this...

{-# notInline libXYZRef #-}
libXYZRef :: LibRef
libXYZRef = unsafePerformIO newLibRef

main :: IO ()
main = finally (initLibXYZ >> userMain) (killLibRef libXYZRef shutDownLibXYZ)
-- initLibXYZ and shutDownLibXYZ are Haskell bindings to functions supplied
-- by libXYZ

userMain :: IO ()
-- userMain creates ForeignPtrs to library objects using addLibRef  

I'm testing by creating 1 ForeignPtr reference using addLibRef and
dropping it immediately thereafter (so it's garbage, but not detected
as such immediately). Running with the -B rts option tells me when
garbage collection has occured.

The problem is I get a "fail: <<loop>>" error if no garbage collection
has occured when killLibRef is called (I.E. killLibRef saves shutDownLibXYZ
for later use because the reference count is non-zero).

But everything works fine if I wait for garbage collection to occur before
calling killLibRef.  

Does anybody have any idea what might be going wrong here?

Personally I'm a bit suspicious of the use of the cToH and hToC functions
in addLibRef, but I'm not aware of any alternative if you want to mix in
some Haskell code with a finaliser.

Thanks for any advice. LibRef code follows below..

module LibRef
        (LibRef      -- data LibRef
        ,newLibRef   -- IO LibRef
        ,addLibRef   -- LibRef -> FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
        ,killLibRef  -- LibRef -> IO () -> IO ()
        ) where

import Data.IORef
import Foreign.Ptr
import Foreign.ForeignPtr
import Control.Concurrent.MVar

foreign import ccall "dynamic" cToH :: FinalizerPtr a -> (Ptr a -> IO ())
foreign import ccall "wrapper" hToC :: (Ptr a -> IO ()) -> IO (FinalizerPtr a)

newtype LibRef = LibRef (MVar Int        -- Reference count (and lock)
                        ,IORef (IO ())   -- Shutdown action
                        )

-- Create a new LibRef
newLibRef :: IO LibRef
newLibRef = do
  countRef  <- newMVar 0                 -- No references
  killitRef <- newIORef $ return ()      -- No shutdown action initially
  return $ LibRef (countRef,killitRef) 

-- Similar to newForeignPtr. Creates a ForeignPtr reference to a library
-- object and increments the LibRef reference count. The actual finaliser
-- used runs the suppied finaliser (second arg) and then decrements the
-- LibRef reference count.
addLibRef :: LibRef -> FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
addLibRef libRef@(LibRef (countMVar,_)) finalise ptr = do
  finalise' <- hToC $ \p -> do cToH finalise p
                               decLibRef libRef
  count <- takeMVar countMVar           -- Read (and lock)
  putMVar countMVar $! (count+1)        -- Increment (and unlock)
  newForeignPtr finalise' ptr

-- Decrement a LibRef reference count. If the resulting reference
-- count is zero whatever action is stored in killitRef is executed
-- (and killitRef is reset to return ()) 
decLibRef :: LibRef -> IO ()
decLibRef (LibRef (countMVar,killitRef)) = do
  putStrLn "<decLibRef>"
  count <- takeMVar countMVar                -- Read and lock
  case count of
    0 -> error "decLibRef applied to zero reference count"
    1 -> do killit <- readIORef killitRef    -- Get configured kill
            writeIORef killitRef $ return () -- Reset killitRef 
            putMVar countMVar 0              -- Reset and unlock
            killit                           -- Kill it
            putStrLn "<No Refs>"
    _ -> putMVar countMVar $! (count-1)      -- Decrement and unlock

-- Call this when the library is no longer needed.
-- Second Arg is library shutdown action. This is performed immediately
-- if reference count == 0. Otherwise it is stored and executed by the
-- last finaliser (when reference count hits 0). 
killLibRef :: LibRef -> IO () -> IO ()
killLibRef (LibRef (countMVar,killitRef)) killit = do
  count <- takeMVar countMVar                            -- Read and lock
  if count == 0 then do writeIORef killitRef $ return () -- Reset killitRef
                        putMVar countMVar count          -- Unlock
                        killit                           -- Execute now
                        putStrLn "<Killed now>"                
                else do writeIORef killitRef killit      -- Save for later
                        putMVar countMVar count          -- Unlock
                        putStrLn "<Killed later>"

Regards
--
Adrian Hey