{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Array.Accelerate.LLVM.Native.Embed (
module Data.Array.Accelerate.LLVM.Embed,
) where
import Data.ByteString.Short.Char8 as S8
import Data.ByteString.Short.Extra as BS
import Data.ByteString.Short.Internal as BS
import Data.Array.Accelerate.Lifetime
import Data.Array.Accelerate.LLVM.Compile
import Data.Array.Accelerate.LLVM.Embed
import Data.Array.Accelerate.LLVM.Native.Compile
import Data.Array.Accelerate.LLVM.Native.Compile.Cache
import Data.Array.Accelerate.LLVM.Native.Link
import Data.Array.Accelerate.LLVM.Native.Plugin.Annotation
import Data.Array.Accelerate.LLVM.Native.State
import Data.Array.Accelerate.LLVM.Native.Target
import Control.Concurrent.Unique
import Control.Monad
import Data.Hashable
import Foreign.Ptr
import Language.Haskell.TH ( Q, TExp )
import Numeric
import System.IO.Unsafe
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
#if __GLASGOW_HASKELL__ >= 806
import Data.Maybe
import qualified Data.Set as Set
#endif
instance Embed Native where
embedForTarget :: Native -> ObjectR Native -> Q (TExp (ExecutableR Native))
embedForTarget = Native -> ObjectR Native -> Q (TExp (ExecutableR Native))
embed
embed :: Native -> ObjectR Native -> Q (TExp (ExecutableR Native))
embed :: Native -> ObjectR Native -> Q (TExp (ExecutableR Native))
embed Native
target (ObjectR uid nms !_) = do
FilePath
objFile <- Q FilePath
getObjectFile
[Q (TExp (ShortByteString, FunPtr ()))]
funtab <- [ShortByteString]
-> (ShortByteString -> Q (Q (TExp (ShortByteString, FunPtr ()))))
-> Q [Q (TExp (ShortByteString, FunPtr ()))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ShortByteString]
nms ((ShortByteString -> Q (Q (TExp (ShortByteString, FunPtr ()))))
-> Q [Q (TExp (ShortByteString, FunPtr ()))])
-> (ShortByteString -> Q (Q (TExp (ShortByteString, FunPtr ()))))
-> Q [Q (TExp (ShortByteString, FunPtr ()))]
forall a b. (a -> b) -> a -> b
$ \ShortByteString
fn -> Q (TExp (ShortByteString, FunPtr ()))
-> Q (Q (TExp (ShortByteString, FunPtr ())))
forall (m :: * -> *) a. Monad m => a -> m a
return [|| ( $$(liftSBS (BS.take (BS.length fn - 65) fn)), $$(makeFFI fn objFile) ) ||]
[|| NativeR (unsafePerformIO $ newLifetime (FunctionTable $$(listE funtab))) ||]
where
listE :: [Q (TExp a)] -> Q (TExp [a])
listE :: [Q (TExp a)] -> Q (TExp [a])
listE [Q (TExp a)]
xs = Q Exp -> Q (TExp [a])
forall a. Q Exp -> Q (TExp a)
TH.unsafeTExpCoerce ([Q Exp] -> Q Exp
TH.listE ((Q (TExp a) -> Q Exp) -> [Q (TExp a)] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Q (TExp a) -> Q Exp
forall a. Q (TExp a) -> Q Exp
TH.unTypeQ [Q (TExp a)]
xs))
makeFFI :: ShortByteString -> FilePath -> Q (TExp (FunPtr ()))
makeFFI :: ShortByteString -> FilePath -> Q (TExp (FunPtr ()))
makeFFI (ShortByteString -> FilePath
S8.unpack -> FilePath
fn) FilePath
objFile = do
Unique
i <- IO Unique -> Q Unique
forall a. IO a -> Q a
TH.runIO IO Unique
newUnique
Name
fn' <- FilePath -> Q Name
TH.newName (FilePath
"__accelerate_llvm_native_" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath -> FilePath
forall a. (Integral a, Show a) => a -> FilePath -> FilePath
showHex (Unique -> Int
forall a. Hashable a => a -> Int
hash Unique
i) [])
Dec
dec <- Callconv -> Safety -> FilePath -> Name -> TypeQ -> DecQ
TH.forImpD Callconv
TH.CCall Safety
TH.Unsafe (Char
'&'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
fn) Name
fn' [t| FunPtr () |]
Dec
ann <- AnnTarget -> Q Exp -> DecQ
TH.pragAnnD (Name -> AnnTarget
TH.ValueAnnotation Name
fn') [| (Object objFile) |]
[Dec] -> Q ()
TH.addTopDecls [Dec
dec, Dec
ann]
Q Exp -> Q (TExp (FunPtr ()))
forall a. Q Exp -> Q (TExp a)
TH.unsafeTExpCoerce (Name -> Q Exp
TH.varE Name
fn')
getObjectFile :: Q FilePath
getObjectFile :: Q FilePath
getObjectFile = do
FilePath
this <- IO FilePath -> Q FilePath
forall a. IO a -> Q a
TH.runIO (Native -> LLVM Native FilePath -> IO FilePath
forall a. Native -> LLVM Native a -> IO a
evalNative Native
target (UID -> LLVM Native FilePath
forall arch. Persistent arch => UID -> LLVM arch FilePath
cacheOfUID UID
uid))
#if __GLASGOW_HASKELL__ >= 806
Set FilePath
rest <- Set FilePath -> Maybe (Set FilePath) -> Set FilePath
forall a. a -> Maybe a -> a
fromMaybe Set FilePath
forall a. Set a
Set.empty (Maybe (Set FilePath) -> Set FilePath)
-> Q (Maybe (Set FilePath)) -> Q (Set FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q (Maybe (Set FilePath))
forall a. Typeable a => Q (Maybe a)
TH.getQ
if FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member FilePath
this Set FilePath
rest
then () -> Q ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
ForeignSrcLang -> FilePath -> Q ()
TH.addForeignFilePath ForeignSrcLang
TH.RawObject FilePath
this
Set FilePath -> Q ()
forall a. Typeable a => a -> Q ()
TH.putQ (FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => a -> Set a -> Set a
Set.insert FilePath
this Set FilePath
rest)
#endif
FilePath -> Q FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
this