{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Array.Accelerate.LLVM.Native.Compile (
module Data.Array.Accelerate.LLVM.Compile,
ObjectR(..),
) where
import Data.Array.Accelerate.AST ( PreOpenAcc )
import Data.Array.Accelerate.Trafo.Delayed
import Data.Array.Accelerate.LLVM.CodeGen
import Data.Array.Accelerate.LLVM.Compile
import Data.Array.Accelerate.LLVM.State
import Data.Array.Accelerate.LLVM.CodeGen.Environment ( Gamma )
import Data.Array.Accelerate.LLVM.CodeGen.Module ( Module(..) )
import Data.Array.Accelerate.LLVM.Native.CodeGen ( )
import Data.Array.Accelerate.LLVM.Native.Compile.Cache
import Data.Array.Accelerate.LLVM.Native.Compile.Optimise
import Data.Array.Accelerate.LLVM.Native.Foreign ( )
import Data.Array.Accelerate.LLVM.Native.Target
import qualified Data.Array.Accelerate.LLVM.Native.Debug as Debug
import LLVM.AST hiding ( Module )
import LLVM.Module as LLVM hiding ( Module )
import LLVM.Context
import LLVM.Target
import Control.Monad.State
import Data.ByteString ( ByteString )
import Data.ByteString.Short ( ShortByteString )
import Data.Maybe
import System.Directory
import System.IO.Unsafe
import Text.Printf
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Short as BS
import qualified Data.Map as Map
instance Compile Native where
data ObjectR Native = ObjectR { ObjectR Native -> UID
objId :: {-# UNPACK #-} !UID
, ObjectR Native -> [ShortByteString]
objSyms :: [ShortByteString]
, ObjectR Native -> ByteString
objData :: ByteString
}
compileForTarget :: PreOpenAcc DelayedOpenAcc aenv a
-> Gamma aenv -> LLVM Native (ObjectR Native)
compileForTarget = PreOpenAcc DelayedOpenAcc aenv a
-> Gamma aenv -> LLVM Native (ObjectR Native)
forall aenv a.
PreOpenAcc DelayedOpenAcc aenv a
-> Gamma aenv -> LLVM Native (ObjectR Native)
compile
instance Intrinsic Native
compile :: PreOpenAcc DelayedOpenAcc aenv a -> Gamma aenv -> LLVM Native (ObjectR Native)
compile :: PreOpenAcc DelayedOpenAcc aenv a
-> Gamma aenv -> LLVM Native (ObjectR Native)
compile PreOpenAcc DelayedOpenAcc aenv a
pacc Gamma aenv
aenv = do
(UID
uid, FilePath
cacheFile) <- PreOpenAcc DelayedOpenAcc aenv a -> LLVM Native (UID, FilePath)
forall arch aenv a.
Persistent arch =>
PreOpenAcc DelayedOpenAcc aenv a -> LLVM arch (UID, FilePath)
cacheOfPreOpenAcc PreOpenAcc DelayedOpenAcc aenv a
pacc
Module Module
ast Map Name (KernelMetadata Native)
md <- UID
-> PreOpenAcc DelayedOpenAcc aenv a
-> Gamma aenv
-> LLVM Native (Module Native aenv a)
forall arch aenv arrs.
(HasCallStack, Target arch, Skeleton arch, Intrinsic arch,
Foreign arch) =>
UID
-> PreOpenAcc DelayedOpenAcc aenv arrs
-> Gamma aenv
-> LLVM arch (Module arch aenv arrs)
llvmOfPreOpenAcc UID
uid PreOpenAcc DelayedOpenAcc aenv a
pacc Gamma aenv
aenv
let triple :: ShortByteString
triple = ShortByteString -> Maybe ShortByteString -> ShortByteString
forall a. a -> Maybe a -> a
fromMaybe ShortByteString
BS.empty (Module -> Maybe ShortByteString
moduleTargetTriple Module
ast)
datalayout :: Maybe DataLayout
datalayout = Module -> Maybe DataLayout
moduleDataLayout Module
ast
nms :: [ShortByteString]
nms = [ ShortByteString
f | Name ShortByteString
f <- Map Name (KernelMetadata Native) -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name (KernelMetadata Native)
md ]
ByteString
obj <- IO ByteString -> LLVM Native ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> LLVM Native ByteString)
-> (IO ByteString -> IO ByteString)
-> IO ByteString
-> LLVM Native ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO ByteString -> IO ByteString
forall a. IO a -> IO a
unsafeInterleaveIO (IO ByteString -> LLVM Native ByteString)
-> IO ByteString -> LLVM Native ByteString
forall a b. (a -> b) -> a -> b
$ do
Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
cacheFile
Bool
recomp <- if Bool
Debug.debuggingIsEnabled then Flag -> IO Bool
Debug.getFlag Flag
Debug.force_recomp else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
if Bool
exists Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
recomp
then do
Flag -> FilePath -> IO ()
Debug.traceIO Flag
Debug.dump_cc (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"cc: found cached object code %s" (UID -> FilePath
forall a. Show a => a -> FilePath
show UID
uid))
FilePath -> IO ByteString
B.readFile FilePath
cacheFile
else
(Context -> IO ByteString) -> IO ByteString
forall a. (Context -> IO a) -> IO a
withContext ((Context -> IO ByteString) -> IO ByteString)
-> (Context -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Context
ctx ->
Context -> Module -> (Module -> IO ByteString) -> IO ByteString
forall a. Context -> Module -> (Module -> IO a) -> IO a
withModuleFromAST Context
ctx Module
ast ((Module -> IO ByteString) -> IO ByteString)
-> (Module -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Module
mdl ->
(TargetMachine -> IO ByteString) -> IO ByteString
forall a. (TargetMachine -> IO a) -> IO a
withNativeTargetMachine ((TargetMachine -> IO ByteString) -> IO ByteString)
-> (TargetMachine -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \TargetMachine
machine ->
ShortByteString
-> (TargetLibraryInfo -> IO ByteString) -> IO ByteString
forall a. ShortByteString -> (TargetLibraryInfo -> IO a) -> IO a
withTargetLibraryInfo ShortByteString
triple ((TargetLibraryInfo -> IO ByteString) -> IO ByteString)
-> (TargetLibraryInfo -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \TargetLibraryInfo
libinfo -> do
Maybe DataLayout
-> Maybe TargetMachine
-> Maybe TargetLibraryInfo
-> Module
-> IO ()
optimiseModule Maybe DataLayout
datalayout (TargetMachine -> Maybe TargetMachine
forall a. a -> Maybe a
Just TargetMachine
machine) (TargetLibraryInfo -> Maybe TargetLibraryInfo
forall a. a -> Maybe a
Just TargetLibraryInfo
libinfo) Module
mdl
Flag -> IO () -> IO ()
forall (m :: * -> *). MonadIO m => Flag -> m () -> m ()
Debug.when Flag
Debug.verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Flag -> FilePath -> IO ()
Debug.traceIO Flag
Debug.dump_cc (FilePath -> IO ())
-> (ByteString -> FilePath) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
B8.unpack (ByteString -> IO ()) -> IO ByteString -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Module -> IO ByteString
moduleLLVMAssembly Module
mdl
Flag -> FilePath -> IO ()
Debug.traceIO Flag
Debug.dump_asm (FilePath -> IO ())
-> (ByteString -> FilePath) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
B8.unpack (ByteString -> IO ()) -> IO ByteString -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TargetMachine -> Module -> IO ByteString
moduleTargetAssembly TargetMachine
machine Module
mdl
ByteString
obj <- TargetMachine -> Module -> IO ByteString
moduleObject TargetMachine
machine Module
mdl
Flag -> FilePath -> IO ()
Debug.traceIO Flag
Debug.dump_cc (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"cc: new object code %s" (UID -> FilePath
forall a. Show a => a -> FilePath
show UID
uid))
FilePath -> ByteString -> IO ()
B.writeFile FilePath
cacheFile ByteString
obj
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
obj
ObjectR Native -> LLVM Native (ObjectR Native)
forall (m :: * -> *) a. Monad m => a -> m a
return (ObjectR Native -> LLVM Native (ObjectR Native))
-> ObjectR Native -> LLVM Native (ObjectR Native)
forall a b. (a -> b) -> a -> b
$! UID -> [ShortByteString] -> ByteString -> ObjectR Native
ObjectR UID
uid [ShortByteString]
nms ByteString
obj