{-# LANGUAGE CPP                        #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_HADDOCK hide #-}
-- |
-- Module      : Data.Array.Accelerate.LLVM.State
-- Copyright   : [2014..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.LLVM.State
  where

-- library
import Control.Concurrent                               ( forkIO, threadDelay )
import Control.Monad.Catch                              ( MonadCatch, MonadThrow, MonadMask )
import Control.Monad.State                              ( StateT, MonadState, evalStateT )
import Control.Monad.Trans                              ( MonadIO )
import Prelude


-- Execution state
-- ===============

-- | The LLVM monad, for executing array computations. This consists of a stack
-- for the LLVM execution context as well as the per-execution target specific
-- state 'target'.
--
newtype LLVM target a = LLVM { LLVM target a -> StateT target IO a
runLLVM :: StateT target IO a }
  deriving (a -> LLVM target b -> LLVM target a
(a -> b) -> LLVM target a -> LLVM target b
(forall a b. (a -> b) -> LLVM target a -> LLVM target b)
-> (forall a b. a -> LLVM target b -> LLVM target a)
-> Functor (LLVM target)
forall a b. a -> LLVM target b -> LLVM target a
forall a b. (a -> b) -> LLVM target a -> LLVM target b
forall target a b. a -> LLVM target b -> LLVM target a
forall target a b. (a -> b) -> LLVM target a -> LLVM target b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> LLVM target b -> LLVM target a
$c<$ :: forall target a b. a -> LLVM target b -> LLVM target a
fmap :: (a -> b) -> LLVM target a -> LLVM target b
$cfmap :: forall target a b. (a -> b) -> LLVM target a -> LLVM target b
Functor, Functor (LLVM target)
a -> LLVM target a
Functor (LLVM target)
-> (forall a. a -> LLVM target a)
-> (forall a b.
    LLVM target (a -> b) -> LLVM target a -> LLVM target b)
-> (forall a b c.
    (a -> b -> c) -> LLVM target a -> LLVM target b -> LLVM target c)
-> (forall a b. LLVM target a -> LLVM target b -> LLVM target b)
-> (forall a b. LLVM target a -> LLVM target b -> LLVM target a)
-> Applicative (LLVM target)
LLVM target a -> LLVM target b -> LLVM target b
LLVM target a -> LLVM target b -> LLVM target a
LLVM target (a -> b) -> LLVM target a -> LLVM target b
(a -> b -> c) -> LLVM target a -> LLVM target b -> LLVM target c
forall target. Functor (LLVM target)
forall a. a -> LLVM target a
forall target a. a -> LLVM target a
forall a b. LLVM target a -> LLVM target b -> LLVM target a
forall a b. LLVM target a -> LLVM target b -> LLVM target b
forall a b. LLVM target (a -> b) -> LLVM target a -> LLVM target b
forall target a b. LLVM target a -> LLVM target b -> LLVM target a
forall target a b. LLVM target a -> LLVM target b -> LLVM target b
forall target a b.
LLVM target (a -> b) -> LLVM target a -> LLVM target b
forall a b c.
(a -> b -> c) -> LLVM target a -> LLVM target b -> LLVM target c
forall target a b c.
(a -> b -> c) -> LLVM target a -> LLVM target b -> LLVM target c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: LLVM target a -> LLVM target b -> LLVM target a
$c<* :: forall target a b. LLVM target a -> LLVM target b -> LLVM target a
*> :: LLVM target a -> LLVM target b -> LLVM target b
$c*> :: forall target a b. LLVM target a -> LLVM target b -> LLVM target b
liftA2 :: (a -> b -> c) -> LLVM target a -> LLVM target b -> LLVM target c
$cliftA2 :: forall target a b c.
(a -> b -> c) -> LLVM target a -> LLVM target b -> LLVM target c
<*> :: LLVM target (a -> b) -> LLVM target a -> LLVM target b
$c<*> :: forall target a b.
LLVM target (a -> b) -> LLVM target a -> LLVM target b
pure :: a -> LLVM target a
$cpure :: forall target a. a -> LLVM target a
$cp1Applicative :: forall target. Functor (LLVM target)
Applicative, Applicative (LLVM target)
a -> LLVM target a
Applicative (LLVM target)
-> (forall a b.
    LLVM target a -> (a -> LLVM target b) -> LLVM target b)
-> (forall a b. LLVM target a -> LLVM target b -> LLVM target b)
-> (forall a. a -> LLVM target a)
-> Monad (LLVM target)
LLVM target a -> (a -> LLVM target b) -> LLVM target b
LLVM target a -> LLVM target b -> LLVM target b
forall target. Applicative (LLVM target)
forall a. a -> LLVM target a
forall target a. a -> LLVM target a
forall a b. LLVM target a -> LLVM target b -> LLVM target b
forall a b. LLVM target a -> (a -> LLVM target b) -> LLVM target b
forall target a b. LLVM target a -> LLVM target b -> LLVM target b
forall target a b.
LLVM target a -> (a -> LLVM target b) -> LLVM target b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> LLVM target a
$creturn :: forall target a. a -> LLVM target a
>> :: LLVM target a -> LLVM target b -> LLVM target b
$c>> :: forall target a b. LLVM target a -> LLVM target b -> LLVM target b
>>= :: LLVM target a -> (a -> LLVM target b) -> LLVM target b
$c>>= :: forall target a b.
LLVM target a -> (a -> LLVM target b) -> LLVM target b
$cp1Monad :: forall target. Applicative (LLVM target)
Monad, Monad (LLVM target)
Monad (LLVM target)
-> (forall a. IO a -> LLVM target a) -> MonadIO (LLVM target)
IO a -> LLVM target a
forall target. Monad (LLVM target)
forall a. IO a -> LLVM target a
forall target a. IO a -> LLVM target a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> LLVM target a
$cliftIO :: forall target a. IO a -> LLVM target a
$cp1MonadIO :: forall target. Monad (LLVM target)
MonadIO, MonadState target, Monad (LLVM target)
e -> LLVM target a
Monad (LLVM target)
-> (forall e a. Exception e => e -> LLVM target a)
-> MonadThrow (LLVM target)
forall target. Monad (LLVM target)
forall e a. Exception e => e -> LLVM target a
forall target e a. Exception e => e -> LLVM target a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: e -> LLVM target a
$cthrowM :: forall target e a. Exception e => e -> LLVM target a
$cp1MonadThrow :: forall target. Monad (LLVM target)
MonadThrow, MonadThrow (LLVM target)
MonadThrow (LLVM target)
-> (forall e a.
    Exception e =>
    LLVM target a -> (e -> LLVM target a) -> LLVM target a)
-> MonadCatch (LLVM target)
LLVM target a -> (e -> LLVM target a) -> LLVM target a
forall target. MonadThrow (LLVM target)
forall e a.
Exception e =>
LLVM target a -> (e -> LLVM target a) -> LLVM target a
forall target e a.
Exception e =>
LLVM target a -> (e -> LLVM target a) -> LLVM target a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: LLVM target a -> (e -> LLVM target a) -> LLVM target a
$ccatch :: forall target e a.
Exception e =>
LLVM target a -> (e -> LLVM target a) -> LLVM target a
$cp1MonadCatch :: forall target. MonadThrow (LLVM target)
MonadCatch, MonadCatch (LLVM target)
MonadCatch (LLVM target)
-> (forall b.
    ((forall a. LLVM target a -> LLVM target a) -> LLVM target b)
    -> LLVM target b)
-> (forall b.
    ((forall a. LLVM target a -> LLVM target a) -> LLVM target b)
    -> LLVM target b)
-> (forall a b c.
    LLVM target a
    -> (a -> ExitCase b -> LLVM target c)
    -> (a -> LLVM target b)
    -> LLVM target (b, c))
-> MonadMask (LLVM target)
LLVM target a
-> (a -> ExitCase b -> LLVM target c)
-> (a -> LLVM target b)
-> LLVM target (b, c)
((forall a. LLVM target a -> LLVM target a) -> LLVM target b)
-> LLVM target b
((forall a. LLVM target a -> LLVM target a) -> LLVM target b)
-> LLVM target b
forall target. MonadCatch (LLVM target)
forall b.
((forall a. LLVM target a -> LLVM target a) -> LLVM target b)
-> LLVM target b
forall target b.
((forall a. LLVM target a -> LLVM target a) -> LLVM target b)
-> LLVM target b
forall a b c.
LLVM target a
-> (a -> ExitCase b -> LLVM target c)
-> (a -> LLVM target b)
-> LLVM target (b, c)
forall target a b c.
LLVM target a
-> (a -> ExitCase b -> LLVM target c)
-> (a -> LLVM target b)
-> LLVM target (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: LLVM target a
-> (a -> ExitCase b -> LLVM target c)
-> (a -> LLVM target b)
-> LLVM target (b, c)
$cgeneralBracket :: forall target a b c.
LLVM target a
-> (a -> ExitCase b -> LLVM target c)
-> (a -> LLVM target b)
-> LLVM target (b, c)
uninterruptibleMask :: ((forall a. LLVM target a -> LLVM target a) -> LLVM target b)
-> LLVM target b
$cuninterruptibleMask :: forall target b.
((forall a. LLVM target a -> LLVM target a) -> LLVM target b)
-> LLVM target b
mask :: ((forall a. LLVM target a -> LLVM target a) -> LLVM target b)
-> LLVM target b
$cmask :: forall target b.
((forall a. LLVM target a -> LLVM target a) -> LLVM target b)
-> LLVM target b
$cp1MonadMask :: forall target. MonadCatch (LLVM target)
MonadMask)

-- | Extract the execution state: 'gets llvmTarget'
--
llvmTarget :: t -> t
llvmTarget :: t -> t
llvmTarget = t -> t
forall a. a -> a
id

-- | Evaluate the given target with an LLVM context
--
evalLLVM :: t -> LLVM t a -> IO a
evalLLVM :: t -> LLVM t a -> IO a
evalLLVM t
target LLVM t a
acc =
  StateT t IO a -> t -> IO a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (LLVM t a -> StateT t IO a
forall target a. LLVM target a -> StateT target IO a
runLLVM LLVM t a
acc) t
target


-- | Make sure the GC knows that we want to keep this thing alive forever.
--
-- We may want to introduce some way to actually shut this down if, for example,
-- the object has not been accessed in a while (whatever that means).
--
-- Broken in ghci-7.6.1 Mac OS X due to bug #7299.
--
keepAlive :: a -> IO a
keepAlive :: a -> IO a
keepAlive a
x = IO () -> IO ThreadId
forkIO (a -> IO ()
forall t b. t -> IO b
caffeine a
x) IO ThreadId -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  where
    caffeine :: t -> IO b
caffeine t
hit = do Int -> IO ()
threadDelay (Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000) -- microseconds = 5 seconds
                      t -> IO b
caffeine t
hit