{-# LANGUAGE MagicHash     #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UnboxedTuples #-}
{-# OPTIONS_HADDOCK hide #-}
-- |
-- Module      : Data.Array.Accelerate.Lifetime
-- Copyright   : [2015..2020] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--

module Data.Array.Accelerate.Lifetime (

  Lifetime(..),
  newLifetime, withLifetime, touchLifetime,
  addFinalizer, finalize, mkWeak, mkWeakPtr,

  unsafeGetValue,

) where

import Data.Function                ( on )
import Data.IORef                   ( mkWeakIORef, atomicModifyIORef' )
import Prelude

import GHC.Base                     ( touch#, IO(..))
import GHC.IORef                    ( IORef(.. ), newIORef )
import GHC.Prim                     ( mkWeak# )
import GHC.STRef                    ( STRef(..) )
import GHC.Weak                     ( Weak(..) )


-- | A lifetime represents a value with attached finalizers. This is similar to
-- the functionality provided by "System.Mem.Weak", but has the following
-- stronger properties:
--
-- * Unless explicitly forced, finalizers will not fire until after the
--   'Lifetime' has become unreachable, where \"reachability\" is the same as
--   defined in "System.Mem.Weak". That is to say, there is no issue with
--   creating a 'Lifetime' for a non-primitve type and finalizers firing while
--   an object is still reachable.
--
-- * Finalizers are fired sequentially in reverse of the order in which they
--   were attached.
--
-- * As the finalizers are attached to the 'Lifetime' and not the underlying
--   value, there is no danger in storing it UNPACKED as part of another
--   structure.
--
type LTF        = IORef [IO ()]
data Lifetime a = Lifetime {-# UNPACK #-} !LTF
                           {-# UNPACK #-} !(Weak LTF)
                           {- LAZY -}     a

instance Eq a => Eq (Lifetime a) where
  == :: Lifetime a -> Lifetime a -> Bool
(==) = a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) (a -> a -> Bool)
-> (Lifetime a -> a) -> Lifetime a -> Lifetime a -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Lifetime a -> a
forall a. Lifetime a -> a
unsafeGetValue

-- | Construct a new 'Lifetime' from the given value.
--
{-# INLINE newLifetime #-}
newLifetime :: a -> IO (Lifetime a)
newLifetime :: a -> IO (Lifetime a)
newLifetime a
a = do
  IORef [IO ()]
ref  <- [IO ()] -> IO (IORef [IO ()])
forall a. a -> IO (IORef a)
newIORef []
  Weak (IORef [IO ()])
weak <- IORef [IO ()] -> IO () -> IO (Weak (IORef [IO ()]))
forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef IORef [IO ()]
ref (IORef [IO ()] -> IO ()
finalizer IORef [IO ()]
ref)
  Lifetime a -> IO (Lifetime a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Lifetime a -> IO (Lifetime a)) -> Lifetime a -> IO (Lifetime a)
forall a b. (a -> b) -> a -> b
$! IORef [IO ()] -> Weak (IORef [IO ()]) -> a -> Lifetime a
forall a. IORef [IO ()] -> Weak (IORef [IO ()]) -> a -> Lifetime a
Lifetime IORef [IO ()]
ref Weak (IORef [IO ()])
weak a
a

-- | This provides a way of looking at the value inside a 'Lifetime'. The
-- supplied function is executed immediately and the 'Lifetime' kept alive
-- throughout its execution. It is important to not let the value /leak/ outside
-- the function, either by returning it or by lazy IO.
--
{-# INLINE withLifetime #-}
withLifetime :: Lifetime a -> (a -> IO b) -> IO b
withLifetime :: Lifetime a -> (a -> IO b) -> IO b
withLifetime (Lifetime IORef [IO ()]
ref Weak (IORef [IO ()])
_ a
a) a -> IO b
f = do
  b
r <- a -> IO b
f a
a
  IORef [IO ()] -> IO ()
forall a. IORef a -> IO ()
touchIORef IORef [IO ()]
ref
  b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
r

-- | Ensure that the lifetime is alive at the given place in a sequence of IO
-- actions. Does not force the payload.
--
{-# INLINE touchLifetime #-}
touchLifetime :: Lifetime a -> IO ()
touchLifetime :: Lifetime a -> IO ()
touchLifetime (Lifetime IORef [IO ()]
ref Weak (IORef [IO ()])
_ a
_) = IORef [IO ()] -> IO ()
forall a. IORef a -> IO ()
touchIORef IORef [IO ()]
ref

-- | Attaches a finalizer to a 'Lifetime'. Like in "System.Mem.Weak", there is
-- no guarantee that the finalizers will eventually run. If they do run,
-- they will be executed in the order in which they were supplied.
--
addFinalizer :: Lifetime a -> IO () -> IO ()
addFinalizer :: Lifetime a -> IO () -> IO ()
addFinalizer (Lifetime IORef [IO ()]
ref Weak (IORef [IO ()])
_ a
_) IO ()
f =
  IORef [IO ()] -> ([IO ()] -> ([IO ()], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
ref (\[IO ()]
fs -> (IO ()
fIO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
:[IO ()]
fs,()))

-- | Causes any finalizers associated with the given lifetime to be run
-- immediately on the calling thread.
--
-- Because the finalizer is run on the calling thread. Care should be taken to
-- ensure that the it does not try to acquire any locks the calling thread might
-- already possess. This can result in deadlock and is in contrast to calling
-- 'System.Mem.Weak.finalize' on 'System.Mem.Weak.Weak'.
--
finalize :: Lifetime a -> IO ()
finalize :: Lifetime a -> IO ()
finalize (Lifetime IORef [IO ()]
ref Weak (IORef [IO ()])
_ a
_) = IORef [IO ()] -> IO ()
finalizer IORef [IO ()]
ref

-- | Create a weak pointer from a 'Lifetime' to the supplied value.
--
-- Because weak pointers have their own concept of finalizers, it is important
-- to note these behaviours:
--
-- * Calling 'System.Mem.Weak.finalize' causes the finalizers attached to the
--   lifetime to be scheduled, and run in the correct order, but does not
--   guarantee they will execute on the calling thread.
--
-- * If 'deRefWeak' returns Nothing, there is no guarantee that the finalizers
--   have already run.
--
mkWeak :: Lifetime k -> v -> IO (Weak v)
mkWeak :: Lifetime k -> v -> IO (Weak v)
mkWeak (Lifetime ref :: IORef [IO ()]
ref@(IORef (STRef MutVar# RealWorld [IO ()]
r#)) Weak (IORef [IO ()])
_ k
_) v
v = IO () -> IO (Weak v)
forall c. IO c -> IO (Weak v)
go (IORef [IO ()] -> IO ()
finalizer IORef [IO ()]
ref)
  where
    go :: IO c -> IO (Weak v)
go (IO State# RealWorld -> (# State# RealWorld, c #)
f) =  -- GHC-8.x
      (State# RealWorld -> (# State# RealWorld, Weak v #)) -> IO (Weak v)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Weak v #))
 -> IO (Weak v))
-> (State# RealWorld -> (# State# RealWorld, Weak v #))
-> IO (Weak v)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case MutVar# RealWorld [IO ()]
-> v
-> (State# RealWorld -> (# State# RealWorld, c #))
-> State# RealWorld
-> (# State# RealWorld, Weak# v #)
forall a b c.
a
-> b
-> (State# RealWorld -> (# State# RealWorld, c #))
-> State# RealWorld
-> (# State# RealWorld, Weak# b #)
mkWeak# MutVar# RealWorld [IO ()]
r# v
v State# RealWorld -> (# State# RealWorld, c #)
f State# RealWorld
s of
                   (# State# RealWorld
s', Weak# v
w# #) -> (# State# RealWorld
s', Weak# v -> Weak v
forall v. Weak# v -> Weak v
Weak Weak# v
w# #)

-- A specialised version of 'mkWeak' where the key and value are the same
-- 'Lifetime'.
--
-- > mkWeakPtr key = mkWeak key key
--
mkWeakPtr :: Lifetime a -> IO (Weak (Lifetime a))
mkWeakPtr :: Lifetime a -> IO (Weak (Lifetime a))
mkWeakPtr Lifetime a
l = Lifetime a -> Lifetime a -> IO (Weak (Lifetime a))
forall k v. Lifetime k -> v -> IO (Weak v)
mkWeak Lifetime a
l Lifetime a
l

-- | Retrieve the value from a lifetime. This is unsafe because, unless the
-- 'Lifetime' is still reachable, the finalizers may fire, potentially
-- invalidating the value.
--
{-# INLINE unsafeGetValue #-}
unsafeGetValue :: Lifetime a -> a
unsafeGetValue :: Lifetime a -> a
unsafeGetValue (Lifetime IORef [IO ()]
_ Weak (IORef [IO ()])
_ a
a) = a
a

-- The actual finalizer for 'Lifetime's.
--
finalizer :: IORef [IO ()] -> IO ()
finalizer :: IORef [IO ()] -> IO ()
finalizer IORef [IO ()]
ref = do
  [IO ()]
fins <- IORef [IO ()] -> ([IO ()] -> ([IO ()], [IO ()])) -> IO [IO ()]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
ref ([],)
  [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
fins

-- Touch an 'IORef', ensuring that it is alive at this point in a sequence of IO
-- actions.
--
{-# INLINE touchIORef #-}
touchIORef :: IORef a -> IO ()
touchIORef :: IORef a -> IO ()
touchIORef IORef a
r = (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case IORef a -> State# RealWorld -> State# RealWorld
forall a. a -> State# RealWorld -> State# RealWorld
touch# IORef a
r State# RealWorld
s of State# RealWorld
s' -> (# State# RealWorld
s', () #)