{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies    #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Module      : Data.Array.Accelerate.LLVM.Native.Compile
-- 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.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 :: {- LAZY -} [ShortByteString]
                                , ObjectR Native -> ByteString
objData :: {- LAZY -} 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 an Accelerate expression to object code
--
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

  -- Generate code for this Acc operation
  --
  -- We require the metadata result, which will give us the names of the
  -- functions which will be contained in the object code, but the actual
  -- code generation step is executed lazily.
  --
  (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 ]

  -- Lower the generated LLVM and produce an object file.
  --
  -- The 'objData' field is only lazy evaluated since the object code might
  -- already have been loaded into memory from a different function, in which
  -- case it will be found in the linker cache.
  --
  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