{-# LANGUAGE FlexibleContexts #-}
module Futhark.Actions
( printAction
, impCodeGenAction
, kernelImpCodeGenAction
, metricsAction
, compileCAction
, compileOpenCLAction
, compileCUDAAction
)
where
import Control.Monad
import Control.Monad.IO.Class
import System.Exit
import System.FilePath
import qualified System.Info
import Futhark.Compiler.CLI
import Futhark.Analysis.Alias
import Futhark.IR
import Futhark.IR.Prop.Aliases
import Futhark.IR.KernelsMem (KernelsMem)
import Futhark.IR.SeqMem (SeqMem)
import qualified Futhark.CodeGen.ImpGen.Sequential as ImpGenSequential
import qualified Futhark.CodeGen.ImpGen.Kernels as ImpGenKernels
import qualified Futhark.CodeGen.Backends.SequentialC as SequentialC
import qualified Futhark.CodeGen.Backends.CCUDA as CCUDA
import qualified Futhark.CodeGen.Backends.COpenCL as COpenCL
import Futhark.Analysis.Metrics
import Futhark.Util (runProgramWithExitCode)
printAction :: (ASTLore lore, CanBeAliased (Op lore)) => Action lore
printAction :: Action lore
printAction =
Action :: forall lore.
String -> String -> (Prog lore -> FutharkM ()) -> Action lore
Action { actionName :: String
actionName = String
"Prettyprint"
, actionDescription :: String
actionDescription = String
"Prettyprint the resulting internal representation on standard output."
, actionProcedure :: Prog lore -> FutharkM ()
actionProcedure = IO () -> FutharkM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ())
-> (Prog lore -> IO ()) -> Prog lore -> FutharkM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> IO ()) -> (Prog lore -> String) -> Prog lore -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prog (Aliases lore) -> String
forall a. Pretty a => a -> String
pretty (Prog (Aliases lore) -> String)
-> (Prog lore -> Prog (Aliases lore)) -> Prog lore -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prog lore -> Prog (Aliases lore)
forall lore.
(ASTLore lore, CanBeAliased (Op lore)) =>
Prog lore -> Prog (Aliases lore)
aliasAnalysis
}
metricsAction :: OpMetrics (Op lore) => Action lore
metricsAction :: Action lore
metricsAction =
Action :: forall lore.
String -> String -> (Prog lore -> FutharkM ()) -> Action lore
Action { actionName :: String
actionName = String
"Compute metrics"
, actionDescription :: String
actionDescription = String
"Print metrics on the final AST."
, actionProcedure :: Prog lore -> FutharkM ()
actionProcedure = IO () -> FutharkM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ())
-> (Prog lore -> IO ()) -> Prog lore -> FutharkM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStr (String -> IO ()) -> (Prog lore -> String) -> Prog lore -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstMetrics -> String
forall a. Show a => a -> String
show (AstMetrics -> String)
-> (Prog lore -> AstMetrics) -> Prog lore -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prog lore -> AstMetrics
forall lore. OpMetrics (Op lore) => Prog lore -> AstMetrics
progMetrics
}
impCodeGenAction :: Action SeqMem
impCodeGenAction :: Action SeqMem
impCodeGenAction =
Action :: forall lore.
String -> String -> (Prog lore -> FutharkM ()) -> Action lore
Action { actionName :: String
actionName = String
"Compile imperative"
, actionDescription :: String
actionDescription = String
"Translate program into imperative IL and write it on standard output."
, actionProcedure :: Prog SeqMem -> FutharkM ()
actionProcedure = IO () -> FutharkM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ())
-> ((Warnings, Program) -> IO ())
-> (Warnings, Program)
-> FutharkM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> IO ())
-> ((Warnings, Program) -> String) -> (Warnings, Program) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program -> String
forall a. Pretty a => a -> String
pretty (Program -> String)
-> ((Warnings, Program) -> Program)
-> (Warnings, Program)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Warnings, Program) -> Program
forall a b. (a, b) -> b
snd ((Warnings, Program) -> FutharkM ())
-> (Prog SeqMem -> FutharkM (Warnings, Program))
-> Prog SeqMem
-> FutharkM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Prog SeqMem -> FutharkM (Warnings, Program)
forall (m :: * -> *).
MonadFreshNames m =>
Prog SeqMem -> m (Warnings, Program)
ImpGenSequential.compileProg
}
kernelImpCodeGenAction :: Action KernelsMem
kernelImpCodeGenAction :: Action KernelsMem
kernelImpCodeGenAction =
Action :: forall lore.
String -> String -> (Prog lore -> FutharkM ()) -> Action lore
Action { actionName :: String
actionName = String
"Compile imperative kernels"
, actionDescription :: String
actionDescription = String
"Translate program into imperative IL with kernels and write it on standard output."
, actionProcedure :: Prog KernelsMem -> FutharkM ()
actionProcedure = IO () -> FutharkM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ())
-> ((Warnings, Program) -> IO ())
-> (Warnings, Program)
-> FutharkM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> IO ())
-> ((Warnings, Program) -> String) -> (Warnings, Program) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program -> String
forall a. Pretty a => a -> String
pretty (Program -> String)
-> ((Warnings, Program) -> Program)
-> (Warnings, Program)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Warnings, Program) -> Program
forall a b. (a, b) -> b
snd ((Warnings, Program) -> FutharkM ())
-> (Prog KernelsMem -> FutharkM (Warnings, Program))
-> Prog KernelsMem
-> FutharkM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Prog KernelsMem -> FutharkM (Warnings, Program)
forall (m :: * -> *).
MonadFreshNames m =>
Prog KernelsMem -> m (Warnings, Program)
ImpGenKernels.compileProgOpenCL
}
compileCAction :: FutharkConfig -> CompilerMode -> FilePath -> Action SeqMem
compileCAction :: FutharkConfig -> CompilerMode -> String -> Action SeqMem
compileCAction FutharkConfig
fcfg CompilerMode
mode String
outpath =
Action :: forall lore.
String -> String -> (Prog lore -> FutharkM ()) -> Action lore
Action { actionName :: String
actionName = String
"Compile to OpenCL"
, actionDescription :: String
actionDescription = String
"Compile to OpenCL"
, actionProcedure :: Prog SeqMem -> FutharkM ()
actionProcedure = Prog SeqMem -> FutharkM ()
helper }
where
helper :: Prog SeqMem -> FutharkM ()
helper Prog SeqMem
prog = do
CParts
cprog <- FutharkConfig -> FutharkM (Warnings, CParts) -> FutharkM CParts
forall a. FutharkConfig -> FutharkM (Warnings, a) -> FutharkM a
handleWarnings FutharkConfig
fcfg (FutharkM (Warnings, CParts) -> FutharkM CParts)
-> FutharkM (Warnings, CParts) -> FutharkM CParts
forall a b. (a -> b) -> a -> b
$ Prog SeqMem -> FutharkM (Warnings, CParts)
forall (m :: * -> *).
MonadFreshNames m =>
Prog SeqMem -> m (Warnings, CParts)
SequentialC.compileProg Prog SeqMem
prog
let cpath :: String
cpath = String
outpath String -> String -> String
`addExtension` String
"c"
hpath :: String
hpath = String
outpath String -> String -> String
`addExtension` String
"h"
case CompilerMode
mode of
CompilerMode
ToLibrary -> do
let (String
header, String
impl) = CParts -> (String, String)
SequentialC.asLibrary CParts
cprog
IO () -> FutharkM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
writeFile String
hpath String
header
IO () -> FutharkM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
writeFile String
cpath String
impl
CompilerMode
ToExecutable -> do
IO () -> FutharkM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
writeFile String
cpath (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ CParts -> String
SequentialC.asExecutable CParts
cprog
Either IOException (ExitCode, String, String)
ret <- IO (Either IOException (ExitCode, String, String))
-> FutharkM (Either IOException (ExitCode, String, String))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException (ExitCode, String, String))
-> FutharkM (Either IOException (ExitCode, String, String)))
-> IO (Either IOException (ExitCode, String, String))
-> FutharkM (Either IOException (ExitCode, String, String))
forall a b. (a -> b) -> a -> b
$ String
-> [String]
-> ByteString
-> IO (Either IOException (ExitCode, String, String))
runProgramWithExitCode String
"gcc"
[String
cpath, String
"-O3", String
"-std=c99", String
"-lm", String
"-o", String
outpath] ByteString
forall a. Monoid a => a
mempty
case Either IOException (ExitCode, String, String)
ret of
Left IOException
err ->
String -> FutharkM ()
forall (m :: * -> *) a. MonadError CompilerError m => String -> m a
externalErrorS (String -> FutharkM ()) -> String -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to run gcc: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall a. Show a => a -> String
show IOException
err
Right (ExitFailure Int
code, String
_, String
gccerr) ->
String -> FutharkM ()
forall (m :: * -> *) a. MonadError CompilerError m => String -> m a
externalErrorS (String -> FutharkM ()) -> String -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String
"gcc failed with code " String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
forall a. Show a => a -> String
show Int
code String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
gccerr
Right (ExitCode
ExitSuccess, String
_, String
_) ->
() -> FutharkM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
compileOpenCLAction :: FutharkConfig -> CompilerMode -> FilePath -> Action KernelsMem
compileOpenCLAction :: FutharkConfig -> CompilerMode -> String -> Action KernelsMem
compileOpenCLAction FutharkConfig
fcfg CompilerMode
mode String
outpath =
Action :: forall lore.
String -> String -> (Prog lore -> FutharkM ()) -> Action lore
Action { actionName :: String
actionName = String
"Compile to OpenCL"
, actionDescription :: String
actionDescription = String
"Compile to OpenCL"
, actionProcedure :: Prog KernelsMem -> FutharkM ()
actionProcedure = Prog KernelsMem -> FutharkM ()
helper }
where
helper :: Prog KernelsMem -> FutharkM ()
helper Prog KernelsMem
prog = do
CParts
cprog <- FutharkConfig -> FutharkM (Warnings, CParts) -> FutharkM CParts
forall a. FutharkConfig -> FutharkM (Warnings, a) -> FutharkM a
handleWarnings FutharkConfig
fcfg (FutharkM (Warnings, CParts) -> FutharkM CParts)
-> FutharkM (Warnings, CParts) -> FutharkM CParts
forall a b. (a -> b) -> a -> b
$ Prog KernelsMem -> FutharkM (Warnings, CParts)
forall (m :: * -> *).
MonadFreshNames m =>
Prog KernelsMem -> m (Warnings, CParts)
COpenCL.compileProg Prog KernelsMem
prog
let cpath :: String
cpath = String
outpath String -> String -> String
`addExtension` String
"c"
hpath :: String
hpath = String
outpath String -> String -> String
`addExtension` String
"h"
extra_options :: [String]
extra_options
| String
System.Info.os String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"darwin" =
[String
"-framework", String
"OpenCL"]
| String
System.Info.os String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"mingw32" =
[String
"-lOpenCL64"]
| Bool
otherwise =
[String
"-lOpenCL"]
case CompilerMode
mode of
CompilerMode
ToLibrary -> do
let (String
header, String
impl) = CParts -> (String, String)
COpenCL.asLibrary CParts
cprog
IO () -> FutharkM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
writeFile String
hpath String
header
IO () -> FutharkM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
writeFile String
cpath String
impl
CompilerMode
ToExecutable -> do
IO () -> FutharkM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
writeFile String
cpath (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ CParts -> String
COpenCL.asExecutable CParts
cprog
Either IOException (ExitCode, String, String)
ret <- IO (Either IOException (ExitCode, String, String))
-> FutharkM (Either IOException (ExitCode, String, String))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException (ExitCode, String, String))
-> FutharkM (Either IOException (ExitCode, String, String)))
-> IO (Either IOException (ExitCode, String, String))
-> FutharkM (Either IOException (ExitCode, String, String))
forall a b. (a -> b) -> a -> b
$ String
-> [String]
-> ByteString
-> IO (Either IOException (ExitCode, String, String))
runProgramWithExitCode String
"gcc"
([String
cpath, String
"-O", String
"-std=c99", String
"-lm", String
"-o", String
outpath] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
extra_options) ByteString
forall a. Monoid a => a
mempty
case Either IOException (ExitCode, String, String)
ret of
Left IOException
err ->
String -> FutharkM ()
forall (m :: * -> *) a. MonadError CompilerError m => String -> m a
externalErrorS (String -> FutharkM ()) -> String -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to run gcc: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall a. Show a => a -> String
show IOException
err
Right (ExitFailure Int
code, String
_, String
gccerr) ->
String -> FutharkM ()
forall (m :: * -> *) a. MonadError CompilerError m => String -> m a
externalErrorS (String -> FutharkM ()) -> String -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String
"gcc failed with code " String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
forall a. Show a => a -> String
show Int
code String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
gccerr
Right (ExitCode
ExitSuccess, String
_, String
_) ->
() -> FutharkM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
compileCUDAAction :: FutharkConfig -> CompilerMode -> FilePath -> Action KernelsMem
compileCUDAAction :: FutharkConfig -> CompilerMode -> String -> Action KernelsMem
compileCUDAAction FutharkConfig
fcfg CompilerMode
mode String
outpath =
Action :: forall lore.
String -> String -> (Prog lore -> FutharkM ()) -> Action lore
Action { actionName :: String
actionName = String
"Compile to CUDA"
, actionDescription :: String
actionDescription = String
"Compile to CUDA"
, actionProcedure :: Prog KernelsMem -> FutharkM ()
actionProcedure = Prog KernelsMem -> FutharkM ()
helper }
where
helper :: Prog KernelsMem -> FutharkM ()
helper Prog KernelsMem
prog = do
CParts
cprog <- FutharkConfig -> FutharkM (Warnings, CParts) -> FutharkM CParts
forall a. FutharkConfig -> FutharkM (Warnings, a) -> FutharkM a
handleWarnings FutharkConfig
fcfg (FutharkM (Warnings, CParts) -> FutharkM CParts)
-> FutharkM (Warnings, CParts) -> FutharkM CParts
forall a b. (a -> b) -> a -> b
$ Prog KernelsMem -> FutharkM (Warnings, CParts)
forall (m :: * -> *).
MonadFreshNames m =>
Prog KernelsMem -> m (Warnings, CParts)
CCUDA.compileProg Prog KernelsMem
prog
let cpath :: String
cpath = String
outpath String -> String -> String
`addExtension` String
"c"
hpath :: String
hpath = String
outpath String -> String -> String
`addExtension` String
"h"
extra_options :: [String]
extra_options = [ String
"-lcuda"
, String
"-lcudart"
, String
"-lnvrtc"
]
case CompilerMode
mode of
CompilerMode
ToLibrary -> do
let (String
header, String
impl) = CParts -> (String, String)
CCUDA.asLibrary CParts
cprog
IO () -> FutharkM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
writeFile String
hpath String
header
IO () -> FutharkM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
writeFile String
cpath String
impl
CompilerMode
ToExecutable -> do
IO () -> FutharkM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
writeFile String
cpath (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ CParts -> String
CCUDA.asExecutable CParts
cprog
let args :: [String]
args = [String
cpath, String
"-O", String
"-std=c99", String
"-lm", String
"-o", String
outpath]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
extra_options
Either IOException (ExitCode, String, String)
ret <- IO (Either IOException (ExitCode, String, String))
-> FutharkM (Either IOException (ExitCode, String, String))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException (ExitCode, String, String))
-> FutharkM (Either IOException (ExitCode, String, String)))
-> IO (Either IOException (ExitCode, String, String))
-> FutharkM (Either IOException (ExitCode, String, String))
forall a b. (a -> b) -> a -> b
$ String
-> [String]
-> ByteString
-> IO (Either IOException (ExitCode, String, String))
runProgramWithExitCode String
"gcc" [String]
args ByteString
forall a. Monoid a => a
mempty
case Either IOException (ExitCode, String, String)
ret of
Left IOException
err ->
String -> FutharkM ()
forall (m :: * -> *) a. MonadError CompilerError m => String -> m a
externalErrorS (String -> FutharkM ()) -> String -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to run gcc: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall a. Show a => a -> String
show IOException
err
Right (ExitFailure Int
code, String
_, String
gccerr) ->
String -> FutharkM ()
forall (m :: * -> *) a. MonadError CompilerError m => String -> m a
externalErrorS (String -> FutharkM ()) -> String -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String
"gcc failed with code " String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String
forall a. Show a => a -> String
show Int
code String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
gccerr
Right (ExitCode
ExitSuccess, String
_, String
_) ->
() -> FutharkM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()