{-# LANGUAGE BangPatterns    #-}
{-# LANGUAGE CPP             #-}
{-# LANGUAGE QuasiQuotes     #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns    #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Module      : Data.Array.Accelerate.LLVM.Native.Embed
-- Copyright   : [2017..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.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

-- Add the given object code to the set of files to link the executable with,
-- and generate FFI declarations to access the external functions of that file.
-- The returned ExecutableR references the new FFI declarations.
--
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')

    -- Note: [Template Haskell and raw object files]
    --
    -- We can only addForeignFilePath once per object file, otherwise the
    -- linker will complain about duplicate symbols. To work around this,
    -- we use putQ/getQ to keep track of which object files have already
    -- been encountered during compilation _of the current module_. This
    -- means that we might still run into problems if runQ is invoked at
    -- multiple modules.
    --
    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