Use lifetimes to track arrays (a proper fix for #284)

Data/Array/Accelerate/Array/Data.hs

@@ -11,6 +11,7 @@
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE UnboxedTuples         #-}
+{-# LANGUAGE ViewPatterns          #-}
 {-# OPTIONS_GHC -fno-warn-missing-methods #-}
 {-# OPTIONS_GHC -fno-warn-orphans         #-}
 {-# OPTIONS_HADDOCK hide #-}
@@ -71,6 +72,7 @@ import Language.Haskell.TH
 import Prelude
 
 -- friends
+import Data.Array.Accelerate.Lifetime
 import Data.Array.Accelerate.Type
 
 -- Add needed Typeable instance for StorableArray
@@ -118,20 +120,21 @@ $( runQ [d| type HTYPE_CCHAR = $(
 -- this by attaching an Int to each array, the value of which we get from a
 -- global counter that we increment for every array construction.
 --
-data UniqueArray i e = UniqueArray {-# UNPACK #-} !Int {-# UNPACK #-} !(StorableArray i e)
+data UniqueArray i e = UniqueArray {-# UNPACK #-} !Int
+                                   {-# UNPACK #-} !(Lifetime (StorableArray i e))
 
 -- |Create a unique array from a storable array
 --
 {-# INLINE uniqueFromStorable #-}
 uniqueFromStorable :: StorableArray i a -> IO (UniqueArray i a)
 uniqueFromStorable sa = do
   i <- atomicModifyIORef' counter (\n -> (n+1,n))
-  return $ UniqueArray i sa
+  UniqueArray i <$> newLifetime sa
 
 -- |Get the storable array backing the unique array
 --
 {-# INLINE storableFromUnique #-}
-storableFromUnique :: UniqueArray i a -> StorableArray i a
+storableFromUnique :: UniqueArray i a -> Lifetime (StorableArray i a)
 storableFromUnique (UniqueArray _ sa) = sa
 
 -- |Get the unique identifier associated with the unique array
@@ -141,17 +144,17 @@ getUniqueId :: UniqueArray i a -> IO Int
 getUniqueId (UniqueArray n _) = return n
 
 instance Storable e => MArray UniqueArray e IO where
-  getBounds (UniqueArray _ sa) = getBounds sa
+  getBounds (UniqueArray _ sa) = getBounds (unsafeGetValue sa)
 
   newArray lu i = uniqueFromStorable =<< newArray lu i
 
   unsafeNewArray_ lu = uniqueFromStorable =<< unsafeNewArray_ lu
 
   newArray_ = unsafeNewArray_
 
-  unsafeRead (UniqueArray _ sa) = MArray.unsafeRead sa
+  unsafeRead (UniqueArray _ sa) = MArray.unsafeRead (unsafeGetValue sa)
 
-  unsafeWrite (UniqueArray _ sa) = MArray.unsafeWrite sa
+  unsafeWrite (UniqueArray _ sa) = MArray.unsafeWrite (unsafeGetValue sa)
 
 -- Array representation
 -- --------------------
@@ -669,13 +672,14 @@ unsafeWriteArray = MArray.unsafeWrite
 --
 {-# INLINE touchUniqueArray #-}
 touchUniqueArray :: UniqueArray i a -> IO ()
-touchUniqueArray (UniqueArray _ sa) = touchStorableArray sa
+touchUniqueArray (UniqueArray _ sa) = withLifetime sa touchStorableArray
 
 -- Obtains a pointer to the payload of an unique array.
 --
 {-# INLINE uniqueArrayPtr #-}
 uniqueArrayPtr :: UniqueArray i a -> Ptr a
-uniqueArrayPtr (UniqueArray _ (StorableArray _ _ _ fp)) = unsafeForeignPtrToPtr fp
+uniqueArrayPtr (UniqueArray _ (unsafeGetValue -> StorableArray _ _ _ fp))
+  = unsafeForeignPtrToPtr fp
 
 -- The global counter that gives new ids for unique arrays.
 {-# NOINLINE counter #-}

Data/Array/Accelerate/Array/Memory/Table.hs

@@ -65,6 +65,7 @@ import Data.Array.Accelerate.Array.Data                         ( ArrayData, GAr
                                                                   UniqueArray, storableFromUnique, getUniqueId )
 import Data.Array.Accelerate.Array.Memory                       ( RemoteMemory, RemotePointer, PrimElt )
 import Data.Array.Accelerate.Array.Memory.Nursery               ( Nursery(..) )
+import Data.Array.Accelerate.Lifetime
 import qualified Data.Array.Accelerate.Array.Memory             as M
 import qualified Data.Array.Accelerate.Array.Memory.Nursery     as N
 import qualified Data.Array.Accelerate.Debug                    as D
@@ -391,35 +392,11 @@ makeWeakArrayData ad c f = mw arrayElt ad
     mw ArrayEltRcuchar  (AD_CUChar ua)  = mkWeak' ua c f
     mw _                _               = error "Base eight is just like base ten really — if you're missing two fingers."
 
-    -- Note: [Weak Array pointers]
-    --
-    -- One of the unfortunate properties of GHC's weak pointers is that if a
-    -- weak pointer is created with a non-primitive object as key, there is
-    -- the possibility that the finalizer attached to the pointer may fire early.
-    -- The reason for this is that the optimiser, at compile time, and the GC, at
-    -- runtime, are free to create copies of the objects they are attached to.
-    -- This is less than ideal if we want to properly track when arrays are no
-    -- longer reachable.
-    --
-    -- The solution to this problem is to use a primitive object as a key for
-    -- any weak pointers we create. However, the obvious choice of primitive,
-    -- the `Addr#` that points to the pinned payload of the array, is not
-    -- suitable. Being a pointer into non-GHC managed memory, the rts won't let
-    -- us use it as a key. Instead we use the `MutVar#` contained within an
-    -- IORef, itself part of the ForeignPtr contained within a StorableArray.
-    -- This means that GHC is free to create as many copies of the container
-    -- and any finalizers will not fire until all copies have been made
-    -- unreachable
-    --
     mkWeak' :: UniqueArray i a -> c -> Maybe (IO ()) -> IO (Weak c)
-    mkWeak' (storableFromUnique -> StorableArray _ _ _ (ForeignPtr _ (MallocPtr _ (IORef (STRef r#))))) c (Just f)
-      = IO $ \s ->
-          case mkWeak# r# c f s of (# s1, w #) -> (# s1, Weak w #)
-    mkWeak' (storableFromUnique -> StorableArray _ _ _ (ForeignPtr _ (MallocPtr _ (IORef (STRef r#))))) c Nothing
-      = IO $ \s ->
-          case mkWeakNoFinalizer# r# c s of (# s1, w #) -> (# s1, Weak w #)
-    mkWeak' _                                                                     _ _
-      = $internalError "makeWeakArrayData" "Internal representation of Storable array has changed"
+    mkWeak' ua k Nothing = mkWeak (storableFromUnique ua) k
+    mkWeak' ua k (Just f) = do
+      addFinalizer (storableFromUnique ua) f
+      mkWeak (storableFromUnique ua) k
 
 
 -- Debug