{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Data.Array.Accelerate.LLVM.Native (
Acc, Arrays,
Afunction, AfunctionR,
run, runWith,
run1, run1With,
runN, runNWith,
stream, streamWith,
Async,
wait, poll, cancel,
runAsync, runAsyncWith,
run1Async, run1AsyncWith,
runNAsync, runNAsyncWith,
runQ, runQWith,
runQAsync, runQAsyncWith,
Native,
createTarget,
) where
import Data.Array.Accelerate.AST ( PreOpenAfun(..), arraysR, liftALeftHandSide )
import Data.Array.Accelerate.AST.LeftHandSide
import Data.Array.Accelerate.Async ( Async, async, wait, poll, cancel )
import Data.Array.Accelerate.Representation.Array ( liftArraysR )
import Data.Array.Accelerate.Smart ( Acc )
import Data.Array.Accelerate.Sugar.Array ( Arrays, toArr, fromArr, ArraysR )
import Data.Array.Accelerate.Trafo
import Data.Array.Accelerate.Trafo.Sharing ( Afunction(..), AfunctionRepr(..), afunctionRepr )
import qualified Data.Array.Accelerate.Sugar.Array as Sugar
import Data.Array.Accelerate.LLVM.Native.Array.Data ( useRemoteAsync )
import Data.Array.Accelerate.LLVM.Native.Compile ( CompiledOpenAfun, compileAcc, compileAfun )
import Data.Array.Accelerate.LLVM.Native.Embed ( embedOpenAcc )
import Data.Array.Accelerate.LLVM.Native.Execute ( executeAcc, executeOpenAcc )
import Data.Array.Accelerate.LLVM.Native.Execute.Async ( Par, evalPar, getArrays )
import Data.Array.Accelerate.LLVM.Native.Execute.Environment ( Val, ValR(..), push )
import Data.Array.Accelerate.LLVM.Native.Link ( ExecOpenAfun, linkAcc, linkAfun )
import Data.Array.Accelerate.LLVM.Native.State
import Data.Array.Accelerate.LLVM.Native.Target
import Data.Array.Accelerate.LLVM.Native.Debug as Debug
import Control.Monad.Trans
import System.IO.Unsafe
import Text.Printf
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
run :: Arrays a => Acc a -> a
run :: Acc a -> a
run = Native -> Acc a -> a
forall a. Arrays a => Native -> Acc a -> a
runWith Native
defaultTarget
runWith :: Arrays a => Native -> Acc a -> a
runWith :: Native -> Acc a -> a
runWith Native
target Acc a
a = IO a -> a
forall a. IO a -> a
unsafePerformIO (Native -> Acc a -> IO a
forall a. Arrays a => Native -> Acc a -> IO a
runWithIO Native
target Acc a
a)
runAsync :: Arrays a => Acc a -> IO (Async a)
runAsync :: Acc a -> IO (Async a)
runAsync = Native -> Acc a -> IO (Async a)
forall a. Arrays a => Native -> Acc a -> IO (Async a)
runAsyncWith Native
defaultTarget
runAsyncWith :: Arrays a => Native -> Acc a -> IO (Async a)
runAsyncWith :: Native -> Acc a -> IO (Async a)
runAsyncWith Native
target Acc a
a = IO a -> IO (Async a)
forall a. IO a -> IO (Async a)
async (Native -> Acc a -> IO a
forall a. Arrays a => Native -> Acc a -> IO a
runWithIO Native
target Acc a
a)
runWithIO :: Arrays a => Native -> Acc a -> IO a
runWithIO :: Native -> Acc a -> IO a
runWithIO Native
target Acc a
a = IO a
execute
where
!acc :: DelayedAcc (ArraysR a)
acc = Acc a -> DelayedAcc (ArraysR a)
forall arrs. Acc arrs -> DelayedAcc (ArraysR arrs)
convertAcc Acc a
a
execute :: IO a
execute = do
DelayedAcc (ArraysR a) -> IO ()
forall (m :: * -> *) g. (MonadIO m, PrettyGraph g) => g -> m ()
dumpGraph DelayedAcc (ArraysR a)
acc
Native -> LLVM Native a -> IO a
forall a. Native -> LLVM Native a -> IO a
evalNative Native
target (LLVM Native a -> IO a) -> LLVM Native a -> IO a
forall a b. (a -> b) -> a -> b
$ do
CompiledAcc Native (ArraysR a)
build <- String
-> (Double -> Double -> String)
-> LLVM Native (CompiledAcc Native (ArraysR a))
-> LLVM Native (CompiledAcc Native (ArraysR a))
forall (m :: * -> *) a.
MonadIO m =>
String -> (Double -> Double -> String) -> m a -> m a
phase String
"compile" Double -> Double -> String
elapsedS (DelayedAcc (ArraysR a)
-> LLVM Native (CompiledAcc Native (ArraysR a))
forall arch a.
(HasCallStack, Compile arch) =>
DelayedAcc a -> LLVM arch (CompiledAcc arch a)
compileAcc DelayedAcc (ArraysR a)
acc) LLVM Native (CompiledAcc Native (ArraysR a))
-> (CompiledAcc Native (ArraysR a)
-> LLVM Native (CompiledAcc Native (ArraysR a)))
-> LLVM Native (CompiledAcc Native (ArraysR a))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CompiledAcc Native (ArraysR a)
-> LLVM Native (CompiledAcc Native (ArraysR a))
forall (m :: * -> *) a. MonadIO m => a -> m a
dumpStats
ExecAcc Native (ArraysR a)
exec <- String
-> (Double -> Double -> String)
-> LLVM Native (ExecAcc Native (ArraysR a))
-> LLVM Native (ExecAcc Native (ArraysR a))
forall (m :: * -> *) a.
MonadIO m =>
String -> (Double -> Double -> String) -> m a -> m a
phase String
"link" Double -> Double -> String
elapsedS (CompiledAcc Native (ArraysR a)
-> LLVM Native (ExecAcc Native (ArraysR a))
forall arch a.
Link arch =>
CompiledAcc arch a -> LLVM arch (ExecAcc arch a)
linkAcc CompiledAcc Native (ArraysR a)
build)
ArraysR a
res <- String
-> (Double -> Double -> String)
-> LLVM Native (ArraysR a)
-> LLVM Native (ArraysR a)
forall (m :: * -> *) a.
MonadIO m =>
String -> (Double -> Double -> String) -> m a -> m a
phase String
"execute" Double -> Double -> String
elapsedP (Par Native (ArraysR a) -> LLVM Native (ArraysR a)
forall a. Par Native a -> LLVM Native a
evalPar (ExecAcc Native (ArraysR a)
-> Par Native (FutureArraysR Native (ArraysR a))
forall arch a.
Execute arch =>
ExecAcc arch a -> Par arch (FutureArraysR arch a)
executeAcc ExecAcc Native (ArraysR a)
exec Par Native (FutureArraysR Native (ArraysR a))
-> (FutureArraysR Native (ArraysR a) -> Par Native (ArraysR a))
-> Par Native (ArraysR a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ArraysR (ArraysR a)
-> FutureArraysR Native (ArraysR a) -> Par Native (ArraysR a)
forall arch a.
Async arch =>
ArraysR a -> FutureArraysR arch a -> Par arch a
getArrays (ExecAcc Native (ArraysR a) -> ArraysR (ArraysR a)
forall (f :: * -> * -> *) aenv a.
HasArraysR f =>
f aenv a -> ArraysR a
arraysR ExecAcc Native (ArraysR a)
exec)))
a -> LLVM Native a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> LLVM Native a) -> a -> LLVM Native a
forall a b. (a -> b) -> a -> b
$ ArraysR a -> a
forall a. Arrays a => ArraysR a -> a
toArr ArraysR a
res
run1 :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> b
run1 :: (Acc a -> Acc b) -> a -> b
run1 = Native -> (Acc a -> Acc b) -> a -> b
forall a b.
(Arrays a, Arrays b) =>
Native -> (Acc a -> Acc b) -> a -> b
run1With Native
defaultTarget
run1With :: (Arrays a, Arrays b) => Native -> (Acc a -> Acc b) -> a -> b
run1With :: Native -> (Acc a -> Acc b) -> a -> b
run1With = Native -> (Acc a -> Acc b) -> a -> b
forall f. Afunction f => Native -> f -> AfunctionR f
runNWith
runN :: Afunction f => f -> AfunctionR f
runN :: f -> AfunctionR f
runN = Native -> f -> AfunctionR f
forall f. Afunction f => Native -> f -> AfunctionR f
runNWith Native
defaultTarget
runNWith :: forall f. Afunction f => Native -> f -> AfunctionR f
runNWith :: Native -> f -> AfunctionR f
runNWith Native
target f
f = AfunctionRepr f (AfunctionR f) (ArraysFunctionR f)
-> ExecOpenAfun Native () (ArraysFunctionR f)
-> Par Native (Val ())
-> AfunctionR f
forall t aenv.
AfunctionRepr t (AfunctionR t) (ArraysFunctionR t)
-> ExecOpenAfun Native aenv (ArraysFunctionR t)
-> Par Native (Val aenv)
-> AfunctionR t
go ((Afunction f, HasCallStack) =>
AfunctionRepr f (AfunctionR f) (ArraysFunctionR f)
forall f.
(Afunction f, HasCallStack) =>
AfunctionRepr f (AfunctionR f) (ArraysFunctionR f)
afunctionRepr @f) ExecOpenAfun Native () (ArraysFunctionR f)
afun (Val () -> Par Native (Val ())
forall (m :: * -> *) a. Monad m => a -> m a
return Val ()
forall arch. ValR arch ()
Empty)
where
!acc :: DelayedAfun (ArraysFunctionR f)
acc = f -> DelayedAfun (ArraysFunctionR f)
forall f. Afunction f => f -> DelayedAfun (ArraysFunctionR f)
convertAfun f
f
!afun :: ExecOpenAfun Native () (ArraysFunctionR f)
afun = IO (ExecOpenAfun Native () (ArraysFunctionR f))
-> ExecOpenAfun Native () (ArraysFunctionR f)
forall a. IO a -> a
unsafePerformIO (IO (ExecOpenAfun Native () (ArraysFunctionR f))
-> ExecOpenAfun Native () (ArraysFunctionR f))
-> IO (ExecOpenAfun Native () (ArraysFunctionR f))
-> ExecOpenAfun Native () (ArraysFunctionR f)
forall a b. (a -> b) -> a -> b
$ do
DelayedAfun (ArraysFunctionR f) -> IO ()
forall (m :: * -> *) g. (MonadIO m, PrettyGraph g) => g -> m ()
dumpGraph DelayedAfun (ArraysFunctionR f)
acc
Native
-> LLVM Native (ExecOpenAfun Native () (ArraysFunctionR f))
-> IO (ExecOpenAfun Native () (ArraysFunctionR f))
forall a. Native -> LLVM Native a -> IO a
evalNative Native
target (LLVM Native (ExecOpenAfun Native () (ArraysFunctionR f))
-> IO (ExecOpenAfun Native () (ArraysFunctionR f)))
-> LLVM Native (ExecOpenAfun Native () (ArraysFunctionR f))
-> IO (ExecOpenAfun Native () (ArraysFunctionR f))
forall a b. (a -> b) -> a -> b
$ do
CompiledAfun Native (ArraysFunctionR f)
build <- String
-> (Double -> Double -> String)
-> LLVM Native (CompiledAfun Native (ArraysFunctionR f))
-> LLVM Native (CompiledAfun Native (ArraysFunctionR f))
forall (m :: * -> *) a.
MonadIO m =>
String -> (Double -> Double -> String) -> m a -> m a
phase String
"compile" Double -> Double -> String
elapsedS (DelayedAfun (ArraysFunctionR f)
-> LLVM Native (CompiledAfun Native (ArraysFunctionR f))
forall arch f.
(HasCallStack, Compile arch) =>
DelayedAfun f -> LLVM arch (CompiledAfun arch f)
compileAfun DelayedAfun (ArraysFunctionR f)
acc) LLVM Native (CompiledAfun Native (ArraysFunctionR f))
-> (CompiledAfun Native (ArraysFunctionR f)
-> LLVM Native (CompiledAfun Native (ArraysFunctionR f)))
-> LLVM Native (CompiledAfun Native (ArraysFunctionR f))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CompiledAfun Native (ArraysFunctionR f)
-> LLVM Native (CompiledAfun Native (ArraysFunctionR f))
forall (m :: * -> *) a. MonadIO m => a -> m a
dumpStats
ExecOpenAfun Native () (ArraysFunctionR f)
link <- String
-> (Double -> Double -> String)
-> LLVM Native (ExecOpenAfun Native () (ArraysFunctionR f))
-> LLVM Native (ExecOpenAfun Native () (ArraysFunctionR f))
forall (m :: * -> *) a.
MonadIO m =>
String -> (Double -> Double -> String) -> m a -> m a
phase String
"link" Double -> Double -> String
elapsedS (CompiledAfun Native (ArraysFunctionR f)
-> LLVM Native (ExecOpenAfun Native () (ArraysFunctionR f))
forall arch f.
Link arch =>
CompiledAfun arch f -> LLVM arch (ExecAfun arch f)
linkAfun CompiledAfun Native (ArraysFunctionR f)
build)
ExecOpenAfun Native () (ArraysFunctionR f)
-> LLVM Native (ExecOpenAfun Native () (ArraysFunctionR f))
forall (m :: * -> *) a. Monad m => a -> m a
return ExecOpenAfun Native () (ArraysFunctionR f)
link
go :: AfunctionRepr t (AfunctionR t) (ArraysFunctionR t)
-> ExecOpenAfun Native aenv (ArraysFunctionR t)
-> Par Native (Val aenv)
-> AfunctionR t
go :: AfunctionRepr t (AfunctionR t) (ArraysFunctionR t)
-> ExecOpenAfun Native aenv (ArraysFunctionR t)
-> Par Native (Val aenv)
-> AfunctionR t
go (AfunctionReprLam AfunctionRepr b br breprr
repr) (Alam ALeftHandSide a aenv aenv'
lhs PreOpenAfun (ExecOpenAcc Native) aenv' t1
l) Par Native (Val aenv)
k = \(a
arrs :: a) ->
let k' :: Par Native (ValR Native aenv')
k' = do Val aenv
aenv <- Par Native (Val aenv)
k
FutureArraysR Native (ArraysR a)
a <- ArraysR (ArraysR a)
-> ArraysR a -> Par Native (FutureArraysR Native (ArraysR a))
forall arch arrs.
Remote arch =>
ArraysR arrs -> arrs -> Par arch (FutureArraysR arch arrs)
useRemoteAsync (Arrays a => ArraysR (ArraysR a)
forall a. Arrays a => ArraysR (ArraysR a)
Sugar.arraysR @a) (ArraysR a -> Par Native (FutureArraysR Native (ArraysR a)))
-> ArraysR a -> Par Native (FutureArraysR Native (ArraysR a))
forall a b. (a -> b) -> a -> b
$ a -> ArraysR a
forall a. Arrays a => a -> ArraysR a
fromArr a
arrs
ValR Native aenv' -> Par Native (ValR Native aenv')
forall (m :: * -> *) a. Monad m => a -> m a
return (Val aenv
aenv Val aenv
-> (ALeftHandSide a aenv aenv', FutureArraysR Native a)
-> ValR Native aenv'
forall arch env t env'.
ValR arch env
-> (ALeftHandSide t env env', FutureArraysR arch t)
-> ValR arch env'
`push` (ALeftHandSide a aenv aenv'
lhs, FutureArraysR Native a
FutureArraysR Native (ArraysR a)
a))
in AfunctionRepr b (AfunctionR b) (ArraysFunctionR b)
-> ExecOpenAfun Native aenv' (ArraysFunctionR b)
-> Par Native (ValR Native aenv')
-> AfunctionR b
forall t aenv.
AfunctionRepr t (AfunctionR t) (ArraysFunctionR t)
-> ExecOpenAfun Native aenv (ArraysFunctionR t)
-> Par Native (Val aenv)
-> AfunctionR t
go AfunctionRepr b br breprr
AfunctionRepr b (AfunctionR b) (ArraysFunctionR b)
repr PreOpenAfun (ExecOpenAcc Native) aenv' t1
ExecOpenAfun Native aenv' (ArraysFunctionR b)
l Par Native (ValR Native aenv')
k'
go AfunctionRepr t (AfunctionR t) (ArraysFunctionR t)
AfunctionReprBody (Abody ExecOpenAcc Native aenv (ArraysFunctionR t)
b) Par Native (Val aenv)
k = IO (AfunctionR t) -> AfunctionR t
forall a. IO a -> a
unsafePerformIO (IO (AfunctionR t) -> AfunctionR t)
-> (Par Native (AfunctionR t) -> IO (AfunctionR t))
-> Par Native (AfunctionR t)
-> AfunctionR t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> (Double -> Double -> String)
-> IO (AfunctionR t)
-> IO (AfunctionR t)
forall (m :: * -> *) a.
MonadIO m =>
String -> (Double -> Double -> String) -> m a -> m a
phase String
"execute" Double -> Double -> String
elapsedP (IO (AfunctionR t) -> IO (AfunctionR t))
-> (Par Native (AfunctionR t) -> IO (AfunctionR t))
-> Par Native (AfunctionR t)
-> IO (AfunctionR t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Native -> LLVM Native (AfunctionR t) -> IO (AfunctionR t)
forall a. Native -> LLVM Native a -> IO a
evalNative Native
target (LLVM Native (AfunctionR t) -> IO (AfunctionR t))
-> (Par Native (AfunctionR t) -> LLVM Native (AfunctionR t))
-> Par Native (AfunctionR t)
-> IO (AfunctionR t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Par Native (AfunctionR t) -> LLVM Native (AfunctionR t)
forall a. Par Native a -> LLVM Native a
evalPar (Par Native (AfunctionR t) -> AfunctionR t)
-> Par Native (AfunctionR t) -> AfunctionR t
forall a b. (a -> b) -> a -> b
$ do
Val aenv
aenv <- Par Native (Val aenv)
k
FutureArraysR Native (ArraysR (AfunctionR t))
res <- ExecOpenAcc Native aenv (ArraysR (AfunctionR t))
-> Val aenv
-> Par Native (FutureArraysR Native (ArraysR (AfunctionR t)))
forall arch aenv arrs.
Execute arch =>
ExecOpenAcc arch aenv arrs
-> ValR arch aenv -> Par arch (FutureArraysR arch arrs)
executeOpenAcc ExecOpenAcc Native aenv (ArraysFunctionR t)
ExecOpenAcc Native aenv (ArraysR (AfunctionR t))
b Val aenv
aenv
ArraysR (AfunctionR t)
arrs <- ArraysR (ArraysR (AfunctionR t))
-> FutureArraysR Native (ArraysR (AfunctionR t))
-> Par Native (ArraysR (AfunctionR t))
forall arch a.
Async arch =>
ArraysR a -> FutureArraysR arch a -> Par arch a
getArrays (ExecOpenAcc Native aenv (ArraysR (AfunctionR t))
-> ArraysR (ArraysR (AfunctionR t))
forall (f :: * -> * -> *) aenv a.
HasArraysR f =>
f aenv a -> ArraysR a
arraysR ExecOpenAcc Native aenv (ArraysFunctionR t)
ExecOpenAcc Native aenv (ArraysR (AfunctionR t))
b) FutureArraysR Native (ArraysR (AfunctionR t))
res
AfunctionR t -> Par Native (AfunctionR t)
forall (m :: * -> *) a. Monad m => a -> m a
return (AfunctionR t -> Par Native (AfunctionR t))
-> AfunctionR t -> Par Native (AfunctionR t)
forall a b. (a -> b) -> a -> b
$ ArraysR (AfunctionR t) -> AfunctionR t
forall a. Arrays a => ArraysR a -> a
toArr ArraysR (AfunctionR t)
arrs
go AfunctionRepr t (AfunctionR t) (ArraysFunctionR t)
_ ExecOpenAfun Native aenv (ArraysFunctionR t)
_ Par Native (Val aenv)
_ = String -> AfunctionR t
forall a. HasCallStack => String -> a
error String
"The moon is hanging upside down"
run1Async :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> a -> IO (Async b)
run1Async :: (Acc a -> Acc b) -> a -> IO (Async b)
run1Async = Native -> (Acc a -> Acc b) -> a -> IO (Async b)
forall a b.
(Arrays a, Arrays b) =>
Native -> (Acc a -> Acc b) -> a -> IO (Async b)
run1AsyncWith Native
defaultTarget
run1AsyncWith :: (Arrays a, Arrays b) => Native -> (Acc a -> Acc b) -> a -> IO (Async b)
run1AsyncWith :: Native -> (Acc a -> Acc b) -> a -> IO (Async b)
run1AsyncWith = Native -> (Acc a -> Acc b) -> a -> IO (Async b)
forall f r.
(Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r) =>
Native -> f -> r
runNAsyncWith
runNAsync :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r) => f -> r
runNAsync :: f -> r
runNAsync = Native -> f -> r
forall f r.
(Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r) =>
Native -> f -> r
runNAsyncWith Native
defaultTarget
runNAsyncWith :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r) => Native -> f -> r
runNAsyncWith :: Native -> f -> r
runNAsyncWith Native
target f
f = r
exec
where
!acc :: DelayedAfun (ArraysFunctionR f)
acc = f -> DelayedAfun (ArraysFunctionR f)
forall f. Afunction f => f -> DelayedAfun (ArraysFunctionR f)
convertAfun f
f
!afun :: ExecAfun Native (RunAsyncR r)
afun = IO (ExecAfun Native (RunAsyncR r)) -> ExecAfun Native (RunAsyncR r)
forall a. IO a -> a
unsafePerformIO (IO (ExecAfun Native (RunAsyncR r))
-> ExecAfun Native (RunAsyncR r))
-> IO (ExecAfun Native (RunAsyncR r))
-> ExecAfun Native (RunAsyncR r)
forall a b. (a -> b) -> a -> b
$ do
DelayedAfun (RunAsyncR r) -> IO ()
forall (m :: * -> *) g. (MonadIO m, PrettyGraph g) => g -> m ()
dumpGraph DelayedAfun (ArraysFunctionR f)
DelayedAfun (RunAsyncR r)
acc
Native
-> LLVM Native (ExecAfun Native (RunAsyncR r))
-> IO (ExecAfun Native (RunAsyncR r))
forall a. Native -> LLVM Native a -> IO a
evalNative Native
target (LLVM Native (ExecAfun Native (RunAsyncR r))
-> IO (ExecAfun Native (RunAsyncR r)))
-> LLVM Native (ExecAfun Native (RunAsyncR r))
-> IO (ExecAfun Native (RunAsyncR r))
forall a b. (a -> b) -> a -> b
$ do
CompiledAfun Native (RunAsyncR r)
build <- String
-> (Double -> Double -> String)
-> LLVM Native (CompiledAfun Native (RunAsyncR r))
-> LLVM Native (CompiledAfun Native (RunAsyncR r))
forall (m :: * -> *) a.
MonadIO m =>
String -> (Double -> Double -> String) -> m a -> m a
phase String
"compile" Double -> Double -> String
elapsedS (DelayedAfun (RunAsyncR r)
-> LLVM Native (CompiledAfun Native (RunAsyncR r))
forall arch f.
(HasCallStack, Compile arch) =>
DelayedAfun f -> LLVM arch (CompiledAfun arch f)
compileAfun DelayedAfun (ArraysFunctionR f)
DelayedAfun (RunAsyncR r)
acc) LLVM Native (CompiledAfun Native (RunAsyncR r))
-> (CompiledAfun Native (RunAsyncR r)
-> LLVM Native (CompiledAfun Native (RunAsyncR r)))
-> LLVM Native (CompiledAfun Native (RunAsyncR r))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CompiledAfun Native (RunAsyncR r)
-> LLVM Native (CompiledAfun Native (RunAsyncR r))
forall (m :: * -> *) a. MonadIO m => a -> m a
dumpStats
ExecAfun Native (RunAsyncR r)
link <- String
-> (Double -> Double -> String)
-> LLVM Native (ExecAfun Native (RunAsyncR r))
-> LLVM Native (ExecAfun Native (RunAsyncR r))
forall (m :: * -> *) a.
MonadIO m =>
String -> (Double -> Double -> String) -> m a -> m a
phase String
"link" Double -> Double -> String
elapsedS (CompiledAfun Native (RunAsyncR r)
-> LLVM Native (ExecAfun Native (RunAsyncR r))
forall arch f.
Link arch =>
CompiledAfun arch f -> LLVM arch (ExecAfun arch f)
linkAfun CompiledAfun Native (RunAsyncR r)
build)
ExecAfun Native (RunAsyncR r)
-> LLVM Native (ExecAfun Native (RunAsyncR r))
forall (m :: * -> *) a. Monad m => a -> m a
return ExecAfun Native (RunAsyncR r)
link
!exec :: r
exec = Native -> ExecAfun Native (RunAsyncR r) -> Par Native (Val ()) -> r
forall f aenv.
RunAsync f =>
Native
-> ExecOpenAfun Native aenv (RunAsyncR f)
-> Par Native (Val aenv)
-> f
runAsync' Native
target ExecAfun Native (RunAsyncR r)
afun (Val () -> Par Native (Val ())
forall (m :: * -> *) a. Monad m => a -> m a
return Val ()
forall arch. ValR arch ()
Empty)
class RunAsync f where
type RunAsyncR f
runAsync' :: Native -> ExecOpenAfun Native aenv (RunAsyncR f) -> Par Native (Val aenv) -> f
instance (Arrays a, RunAsync b) => RunAsync (a -> b) where
type RunAsyncR (a -> b) = ArraysR a -> RunAsyncR b
runAsync' :: Native
-> ExecOpenAfun Native aenv (RunAsyncR (a -> b))
-> Par Native (Val aenv)
-> a
-> b
runAsync' Native
_ Abody{} Par Native (Val aenv)
_ a
_ = String -> b
forall a. HasCallStack => String -> a
error String
"runAsync: function oversaturated"
runAsync' Native
target (Alam ALeftHandSide a aenv aenv'
lhs PreOpenAfun (ExecOpenAcc Native) aenv' t1
l) Par Native (Val aenv)
k a
arrs =
let k' :: Par Native (ValR Native aenv')
k' = do Val aenv
aenv <- Par Native (Val aenv)
k
FutureArraysR Native a
a <- ArraysR a -> a -> Par Native (FutureArraysR Native a)
forall arch arrs.
Remote arch =>
ArraysR arrs -> arrs -> Par arch (FutureArraysR arch arrs)
useRemoteAsync (Arrays a => ArraysR (ArraysR a)
forall a. Arrays a => ArraysR (ArraysR a)
Sugar.arraysR @a) (a -> Par Native (FutureArraysR Native a))
-> a -> Par Native (FutureArraysR Native a)
forall a b. (a -> b) -> a -> b
$ a -> ArraysR a
forall a. Arrays a => a -> ArraysR a
fromArr a
arrs
ValR Native aenv' -> Par Native (ValR Native aenv')
forall (m :: * -> *) a. Monad m => a -> m a
return (Val aenv
aenv Val aenv
-> (ALeftHandSide a aenv aenv', FutureArraysR Native a)
-> ValR Native aenv'
forall arch env t env'.
ValR arch env
-> (ALeftHandSide t env env', FutureArraysR arch t)
-> ValR arch env'
`push` (ALeftHandSide a aenv aenv'
lhs, FutureArraysR Native a
a))
in Native
-> ExecOpenAfun Native aenv' (RunAsyncR b)
-> Par Native (ValR Native aenv')
-> b
forall f aenv.
RunAsync f =>
Native
-> ExecOpenAfun Native aenv (RunAsyncR f)
-> Par Native (Val aenv)
-> f
runAsync' Native
target PreOpenAfun (ExecOpenAcc Native) aenv' t1
ExecOpenAfun Native aenv' (RunAsyncR b)
l Par Native (ValR Native aenv')
k'
instance Arrays b => RunAsync (IO (Async b)) where
type RunAsyncR (IO (Async b)) = ArraysR b
runAsync' :: Native
-> ExecOpenAfun Native aenv (RunAsyncR (IO (Async b)))
-> Par Native (Val aenv)
-> IO (Async b)
runAsync' Native
_ Alam{} Par Native (Val aenv)
_ = String -> IO (Async b)
forall a. HasCallStack => String -> a
error String
"runAsync: function not fully applied"
runAsync' Native
target (Abody ExecOpenAcc Native aenv (RunAsyncR (IO (Async b)))
b) Par Native (Val aenv)
k = IO b -> IO (Async b)
forall a. IO a -> IO (Async a)
async (IO b -> IO (Async b))
-> (Par Native b -> IO b) -> Par Native b -> IO (Async b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (Double -> Double -> String) -> IO b -> IO b
forall (m :: * -> *) a.
MonadIO m =>
String -> (Double -> Double -> String) -> m a -> m a
phase String
"execute" Double -> Double -> String
elapsedP (IO b -> IO b) -> (Par Native b -> IO b) -> Par Native b -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Native -> LLVM Native b -> IO b
forall a. Native -> LLVM Native a -> IO a
evalNative Native
target (LLVM Native b -> IO b)
-> (Par Native b -> LLVM Native b) -> Par Native b -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Par Native b -> LLVM Native b
forall a. Par Native a -> LLVM Native a
evalPar (Par Native b -> IO (Async b)) -> Par Native b -> IO (Async b)
forall a b. (a -> b) -> a -> b
$ do
Val aenv
aenv <- Par Native (Val aenv)
k
FutureArraysR Native (ArraysR b)
ans <- ExecOpenAcc Native aenv (ArraysR b)
-> Val aenv -> Par Native (FutureArraysR Native (ArraysR b))
forall arch aenv arrs.
Execute arch =>
ExecOpenAcc arch aenv arrs
-> ValR arch aenv -> Par arch (FutureArraysR arch arrs)
executeOpenAcc ExecOpenAcc Native aenv (ArraysR b)
ExecOpenAcc Native aenv (RunAsyncR (IO (Async b)))
b Val aenv
aenv
ArraysR b
arrs <- ArraysR (ArraysR b)
-> FutureArraysR Native (ArraysR b) -> Par Native (ArraysR b)
forall arch a.
Async arch =>
ArraysR a -> FutureArraysR arch a -> Par arch a
getArrays (ExecOpenAcc Native aenv (ArraysR b) -> ArraysR (ArraysR b)
forall (f :: * -> * -> *) aenv a.
HasArraysR f =>
f aenv a -> ArraysR a
arraysR ExecOpenAcc Native aenv (ArraysR b)
ExecOpenAcc Native aenv (RunAsyncR (IO (Async b)))
b) FutureArraysR Native (ArraysR b)
ans
b -> Par Native b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Par Native b) -> b -> Par Native b
forall a b. (a -> b) -> a -> b
$ ArraysR b -> b
forall a. Arrays a => ArraysR a -> a
toArr ArraysR b
arrs
stream :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> [a] -> [b]
stream :: (Acc a -> Acc b) -> [a] -> [b]
stream = Native -> (Acc a -> Acc b) -> [a] -> [b]
forall a b.
(Arrays a, Arrays b) =>
Native -> (Acc a -> Acc b) -> [a] -> [b]
streamWith Native
defaultTarget
streamWith :: (Arrays a, Arrays b) => Native -> (Acc a -> Acc b) -> [a] -> [b]
streamWith :: Native -> (Acc a -> Acc b) -> [a] -> [b]
streamWith Native
target Acc a -> Acc b
f [a]
arrs = (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
go [a]
arrs
where
!go :: a -> b
go = Native -> (Acc a -> Acc b) -> a -> b
forall a b.
(Arrays a, Arrays b) =>
Native -> (Acc a -> Acc b) -> a -> b
run1With Native
target Acc a -> Acc b
f
runQ :: Afunction f => f -> TH.ExpQ
runQ :: f -> ExpQ
runQ = ExpQ -> ExpQ -> f -> ExpQ
forall f. Afunction f => ExpQ -> ExpQ -> f -> ExpQ
runQ' [| unsafePerformIO |] [| defaultTarget |]
runQWith :: Afunction f => f -> TH.ExpQ
runQWith :: f -> ExpQ
runQWith f
f = do
Name
target <- String -> Q Name
TH.newName String
"target"
[PatQ] -> ExpQ -> ExpQ
TH.lamE [Name -> PatQ
TH.varP Name
target] (ExpQ -> ExpQ -> f -> ExpQ
forall f. Afunction f => ExpQ -> ExpQ -> f -> ExpQ
runQ' [| unsafePerformIO |] (Name -> ExpQ
TH.varE Name
target) f
f)
runQAsync :: Afunction f => f -> TH.ExpQ
runQAsync :: f -> ExpQ
runQAsync = ExpQ -> ExpQ -> f -> ExpQ
forall f. Afunction f => ExpQ -> ExpQ -> f -> ExpQ
runQ' [| async |] [| defaultTarget |]
runQAsyncWith :: Afunction f => f -> TH.ExpQ
runQAsyncWith :: f -> ExpQ
runQAsyncWith f
f = do
Name
target <- String -> Q Name
TH.newName String
"target"
[PatQ] -> ExpQ -> ExpQ
TH.lamE [Name -> PatQ
TH.varP Name
target] (ExpQ -> ExpQ -> f -> ExpQ
forall f. Afunction f => ExpQ -> ExpQ -> f -> ExpQ
runQ' [| async |] (Name -> ExpQ
TH.varE Name
target) f
f)
runQ' :: forall f. Afunction f => TH.ExpQ -> TH.ExpQ -> f -> TH.ExpQ
runQ' :: ExpQ -> ExpQ -> f -> ExpQ
runQ' ExpQ
using ExpQ
target f
f = do
#if MIN_VERSION_template_haskell(2,13,0)
String -> Q ()
TH.addCorePlugin String
"Data.Array.Accelerate.LLVM.Native.Plugin"
#endif
CompiledAfun Native (ArraysFunctionR f)
afun <- let acc :: DelayedAfun (ArraysFunctionR f)
acc = f -> DelayedAfun (ArraysFunctionR f)
forall f. Afunction f => f -> DelayedAfun (ArraysFunctionR f)
convertAfun f
f
in IO (CompiledAfun Native (ArraysFunctionR f))
-> Q (CompiledAfun Native (ArraysFunctionR f))
forall a. IO a -> Q a
TH.runIO (IO (CompiledAfun Native (ArraysFunctionR f))
-> Q (CompiledAfun Native (ArraysFunctionR f)))
-> IO (CompiledAfun Native (ArraysFunctionR f))
-> Q (CompiledAfun Native (ArraysFunctionR f))
forall a b. (a -> b) -> a -> b
$ do
DelayedAfun (ArraysFunctionR f) -> IO ()
forall (m :: * -> *) g. (MonadIO m, PrettyGraph g) => g -> m ()
dumpGraph DelayedAfun (ArraysFunctionR f)
acc
Native
-> LLVM Native (CompiledAfun Native (ArraysFunctionR f))
-> IO (CompiledAfun Native (ArraysFunctionR f))
forall a. Native -> LLVM Native a -> IO a
evalNative Native
defaultTarget (LLVM Native (CompiledAfun Native (ArraysFunctionR f))
-> IO (CompiledAfun Native (ArraysFunctionR f)))
-> LLVM Native (CompiledAfun Native (ArraysFunctionR f))
-> IO (CompiledAfun Native (ArraysFunctionR f))
forall a b. (a -> b) -> a -> b
$
String
-> (Double -> Double -> String)
-> LLVM Native (CompiledAfun Native (ArraysFunctionR f))
-> LLVM Native (CompiledAfun Native (ArraysFunctionR f))
forall (m :: * -> *) a.
MonadIO m =>
String -> (Double -> Double -> String) -> m a -> m a
phase String
"compile" Double -> Double -> String
elapsedS (DelayedAfun (ArraysFunctionR f)
-> LLVM Native (CompiledAfun Native (ArraysFunctionR f))
forall arch f.
(HasCallStack, Compile arch) =>
DelayedAfun f -> LLVM arch (CompiledAfun arch f)
compileAfun DelayedAfun (ArraysFunctionR f)
acc) LLVM Native (CompiledAfun Native (ArraysFunctionR f))
-> (CompiledAfun Native (ArraysFunctionR f)
-> LLVM Native (CompiledAfun Native (ArraysFunctionR f)))
-> LLVM Native (CompiledAfun Native (ArraysFunctionR f))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CompiledAfun Native (ArraysFunctionR f)
-> LLVM Native (CompiledAfun Native (ArraysFunctionR f))
forall (m :: * -> *) a. MonadIO m => a -> m a
dumpStats
let
go :: CompiledOpenAfun Native aenv t -> [TH.PatQ] -> [TH.ExpQ] -> [TH.StmtQ] -> TH.ExpQ
go :: CompiledOpenAfun Native aenv t
-> [PatQ] -> [ExpQ] -> [StmtQ] -> ExpQ
go (Alam ALeftHandSide a aenv aenv'
lhs PreOpenAfun (CompiledOpenAcc Native) aenv' t1
l) [PatQ]
xs [ExpQ]
as [StmtQ]
stmts = do
Name
x <- String -> Q Name
TH.newName String
"x"
Name
a <- String -> Q Name
TH.newName String
"a"
Stmt
s <- PatQ -> ExpQ -> StmtQ
TH.bindS (Name -> PatQ
TH.varP Name
a) [| useRemoteAsync $(TH.unTypeQ $ liftArraysR (lhsToTupR lhs)) (fromArr $(TH.varE x)) |]
PreOpenAfun (CompiledOpenAcc Native) aenv' t1
-> [PatQ] -> [ExpQ] -> [StmtQ] -> ExpQ
forall aenv t.
CompiledOpenAfun Native aenv t
-> [PatQ] -> [ExpQ] -> [StmtQ] -> ExpQ
go PreOpenAfun (CompiledOpenAcc Native) aenv' t1
l (Name -> PatQ
TH.varP Name
x PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
: [PatQ]
xs) ([| ($(TH.unTypeQ $ liftALeftHandSide lhs), $(TH.varE a)) |] ExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
: [ExpQ]
as) (Stmt -> StmtQ
forall (m :: * -> *) a. Monad m => a -> m a
return Stmt
s StmtQ -> [StmtQ] -> [StmtQ]
forall a. a -> [a] -> [a]
: [StmtQ]
stmts)
go (Abody CompiledOpenAcc Native aenv t
b) [PatQ]
xs [ExpQ]
as [StmtQ]
stmts = do
Name
r <- String -> Q Name
TH.newName String
"r"
Name
s <- String -> Q Name
TH.newName String
"s"
let
aenv :: ExpQ
aenv = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ExpQ
a ExpQ
gamma -> [| $gamma `push` $a |]) [| Empty |] [ExpQ]
as
body :: Q (TExp (ExecOpenAcc Native aenv t))
body = Native
-> CompiledOpenAcc Native aenv t
-> Q (TExp (ExecOpenAcc Native aenv t))
forall arch aenv arrs.
(HasCallStack, Embed arch) =>
arch
-> CompiledOpenAcc arch aenv arrs
-> Q (TExp (ExecOpenAcc arch aenv arrs))
embedOpenAcc Native
defaultTarget CompiledOpenAcc Native aenv t
b
[PatQ] -> ExpQ -> ExpQ
TH.lamE ([PatQ] -> [PatQ]
forall a. [a] -> [a]
reverse [PatQ]
xs)
[| $using . phase "execute" elapsedP . evalNative $target . evalPar $
$(TH.doE ( reverse stmts ++
[ TH.bindS (TH.varP r) [| executeOpenAcc $(TH.unTypeQ body) $aenv |]
, TH.bindS (TH.varP s) [| getArrays $(TH.unTypeQ (liftArraysR (arraysR b))) $(TH.varE r) |]
, TH.noBindS [| return $ toArr $(TH.varE s) |]
]))
|]
CompiledAfun Native (ArraysFunctionR f)
-> [PatQ] -> [ExpQ] -> [StmtQ] -> ExpQ
forall aenv t.
CompiledOpenAfun Native aenv t
-> [PatQ] -> [ExpQ] -> [StmtQ] -> ExpQ
go CompiledAfun Native (ArraysFunctionR f)
afun [] [] []
dumpStats :: MonadIO m => a -> m a
dumpStats :: a -> m a
dumpStats a
x = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
dumpSimplStats m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
phase :: MonadIO m => String -> (Double -> Double -> String) -> m a -> m a
phase :: String -> (Double -> Double -> String) -> m a -> m a
phase String
n Double -> Double -> String
fmt m a
go = Flag -> (Double -> Double -> String) -> m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
Flag -> (Double -> Double -> String) -> m a -> m a
timed Flag
dump_phases (\Double
wall Double
cpu -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"phase %s: %s" String
n (Double -> Double -> String
fmt Double
wall Double
cpu)) m a
go