ForeignPtr touched in FFI wrapper is never discarded

If a ForeignPtr is touched in an FFI wrapper (foreign import ccall "wrapper"), it appears to never be discarded. For example, the program below demonstrates a space leak due to multiple mallocForeignPtrBytes results hanging around forever.

import Control.Concurrent (threadDelay)
import Foreign.ForeignPtr
import Foreign.Marshal.Utils (fillBytes)
import Foreign.Ptr (FunPtr)

foreign import ccall "wrapper" wrap :: IO () -> IO (FunPtr (IO ()))

main :: IO ()
main = flip mapM_ [0..50] $ \_ -> do
   let len = 30 * 2^20
   fp <- mallocForeignPtrBytes len
   withForeignPtr fp $ \p -> fillBytes p 0 len
   _ <- wrap $ touchForeignPtr fp
   threadDelay 100000

Each of the 50 iterations allocates 30 megabytes of memory via mallocForeignPtrBytes. None of those allocations is ever freed, resulting in around 1.5 gigabytes of memory use by the time the program terminates.

(Neither fillBytes nor threadDelay are required to reproduce the issue: they are there to respectively touch the memory so that it's fully allocated by the OS and to slow the program down so that one can view the memory usage gradually increasing e.g. with top.)

Example run, with almost 1.6 gigabytes of memory usage reported by GNU time (the "maxresident" bit):

$ ghc --make asdf.hs
[1 of 1] Compiling Main             ( asdf.hs, asdf.o )
Linking asdf ...
$ /usr/bin/time ./asdf
0.12user 0.54system 0:05.77elapsed 11%CPU (0avgtext+0avgdata 1587300maxresident)k
0inputs+0outputs (0major+138078minor)pagefaults 0swaps

People bitten by this can probably work around it without too much trouble by either:

1. Simply avoiding the trigger, i.e. touchForeignPtr in a wrapper. In my case, that amounts to changing some functions to take Ptr a instead of ForeignPtr a and moving some withForeignPtr calls around, possibly adding manual touchForeignPtr calls somewhere.
2. Switching to manual memory management with functions like mallocBytes and free.

But the issue seems rather nasty regardless. (At least it took me a while to pin down.) Hopefully it can be fixed without too much trouble.

Trac metadata

Trac field	Value
Version	7.10.1
Type	Bug
TypeOfFailure	OtherFailure
Priority	normal
Resolution	Unresolved
Component	Compiler
Test case
Differential revisions
BlockedBy
Related
Blocking
CC
Operating system
Architecture