-- | All (almost) compiler pipelines end with an 'Action', which does
-- something with the result of the pipeline.
module Futhark.Actions
  ( printAction,
    printAliasesAction,
    printLastUseGPU,
    printFusionGraph,
    printInterferenceGPU,
    printMemAliasGPU,
    callGraphAction,
    impCodeGenAction,
    kernelImpCodeGenAction,
    multicoreImpCodeGenAction,
    metricsAction,
    compileCAction,
    compileCtoWASMAction,
    compileOpenCLAction,
    compileCUDAAction,
    compileHIPAction,
    compileMulticoreAction,
    compileMulticoreToISPCAction,
    compileMulticoreToWASMAction,
    compilePythonAction,
    compilePyOpenCLAction,
  )
where

import Control.Monad
import Control.Monad.IO.Class
import Data.Bifunctor
import Data.List (intercalate)
import Data.Map qualified as M
import Data.Maybe (fromMaybe)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Futhark.Analysis.Alias
import Futhark.Analysis.CallGraph (buildCallGraph)
import Futhark.Analysis.Interference qualified as Interference
import Futhark.Analysis.LastUse qualified as LastUse
import Futhark.Analysis.MemAlias qualified as MemAlias
import Futhark.Analysis.Metrics
import Futhark.CodeGen.Backends.CCUDA qualified as CCUDA
import Futhark.CodeGen.Backends.COpenCL qualified as COpenCL
import Futhark.CodeGen.Backends.HIP qualified as HIP
import Futhark.CodeGen.Backends.MulticoreC qualified as MulticoreC
import Futhark.CodeGen.Backends.MulticoreISPC qualified as MulticoreISPC
import Futhark.CodeGen.Backends.MulticoreWASM qualified as MulticoreWASM
import Futhark.CodeGen.Backends.PyOpenCL qualified as PyOpenCL
import Futhark.CodeGen.Backends.SequentialC qualified as SequentialC
import Futhark.CodeGen.Backends.SequentialPython qualified as SequentialPy
import Futhark.CodeGen.Backends.SequentialWASM qualified as SequentialWASM
import Futhark.CodeGen.ImpGen.GPU qualified as ImpGenGPU
import Futhark.CodeGen.ImpGen.Multicore qualified as ImpGenMulticore
import Futhark.CodeGen.ImpGen.Sequential qualified as ImpGenSequential
import Futhark.Compiler.CLI
import Futhark.IR
import Futhark.IR.GPUMem (GPUMem)
import Futhark.IR.MCMem (MCMem)
import Futhark.IR.SOACS (SOACS)
import Futhark.IR.SeqMem (SeqMem)
import Futhark.Optimise.Fusion.GraphRep qualified
import Futhark.Util (runProgramWithExitCode, unixEnvironment)
import Futhark.Version (versionString)
import System.Directory
import System.Exit
import System.FilePath
import System.Info qualified

-- | Print the result to stdout.
printAction :: (ASTRep rep) => Action rep
printAction :: forall rep. ASTRep rep => Action rep
printAction =
  Action
    { actionName :: String
actionName = String
"Prettyprint",
      actionDescription :: String
actionDescription = String
"Prettyprint the resulting internal representation on standard output.",
      actionProcedure :: Prog rep -> FutharkM ()
actionProcedure = IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ())
-> (Prog rep -> IO ()) -> Prog rep -> FutharkM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> IO ()) -> (Prog rep -> String) -> Prog rep -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prog rep -> String
forall a. Pretty a => a -> String
prettyString
    }

-- | Print the result to stdout, alias annotations.
printAliasesAction :: (AliasableRep rep) => Action rep
printAliasesAction :: forall rep. AliasableRep rep => Action rep
printAliasesAction =
  Action
    { actionName :: String
actionName = String
"Prettyprint",
      actionDescription :: String
actionDescription = String
"Prettyprint the resulting internal representation on standard output.",
      actionProcedure :: Prog rep -> FutharkM ()
actionProcedure = IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ())
-> (Prog rep -> IO ()) -> Prog rep -> FutharkM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> IO ()) -> (Prog rep -> String) -> Prog rep -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prog (Aliases rep) -> String
forall a. Pretty a => a -> String
prettyString (Prog (Aliases rep) -> String)
-> (Prog rep -> Prog (Aliases rep)) -> Prog rep -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prog rep -> Prog (Aliases rep)
forall rep. AliasableRep rep => Prog rep -> Prog (Aliases rep)
aliasAnalysis
    }

-- | Print last use information to stdout.
printLastUseGPU :: Action GPUMem
printLastUseGPU :: Action GPUMem
printLastUseGPU =
  Action
    { actionName :: String
actionName = String
"print last use gpu",
      actionDescription :: String
actionDescription = String
"Print last use information on gpu.",
      actionProcedure :: Prog GPUMem -> FutharkM ()
actionProcedure =
        IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
          (IO () -> FutharkM ())
-> (Prog GPUMem -> IO ()) -> Prog GPUMem -> FutharkM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn
          (String -> IO ())
-> (Prog GPUMem -> String) -> Prog GPUMem -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(VName, Names)], [(Name, [(VName, Names)])]) -> String
forall a. Pretty a => a -> String
prettyString
          (([(VName, Names)], [(Name, [(VName, Names)])]) -> String)
-> (Prog GPUMem -> ([(VName, Names)], [(Name, [(VName, Names)])]))
-> Prog GPUMem
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map VName Names -> [(VName, Names)])
-> (Map Name (Map VName Names) -> [(Name, [(VName, Names)])])
-> (Map VName Names, Map Name (Map VName Names))
-> ([(VName, Names)], [(Name, [(VName, Names)])])
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Map VName Names -> [(VName, Names)]
forall k a. Map k a -> [(k, a)]
M.toList (Map Name [(VName, Names)] -> [(Name, [(VName, Names)])]
forall k a. Map k a -> [(k, a)]
M.toList (Map Name [(VName, Names)] -> [(Name, [(VName, Names)])])
-> (Map Name (Map VName Names) -> Map Name [(VName, Names)])
-> Map Name (Map VName Names)
-> [(Name, [(VName, Names)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map VName Names -> [(VName, Names)])
-> Map Name (Map VName Names) -> Map Name [(VName, Names)]
forall a b. (a -> b) -> Map Name a -> Map Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map VName Names -> [(VName, Names)]
forall k a. Map k a -> [(k, a)]
M.toList)
          ((Map VName Names, Map Name (Map VName Names))
 -> ([(VName, Names)], [(Name, [(VName, Names)])]))
-> (Prog GPUMem -> (Map VName Names, Map Name (Map VName Names)))
-> Prog GPUMem
-> ([(VName, Names)], [(Name, [(VName, Names)])])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prog (Aliases GPUMem)
-> (Map VName Names, Map Name (Map VName Names))
LastUse.lastUseGPUMem
          (Prog (Aliases GPUMem)
 -> (Map VName Names, Map Name (Map VName Names)))
-> (Prog GPUMem -> Prog (Aliases GPUMem))
-> Prog GPUMem
-> (Map VName Names, Map Name (Map VName Names))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prog GPUMem -> Prog (Aliases GPUMem)
forall rep. AliasableRep rep => Prog rep -> Prog (Aliases rep)
aliasAnalysis
    }

-- | Print fusion graph to stdout.
printFusionGraph :: Action SOACS
printFusionGraph :: Action SOACS
printFusionGraph =
  Action
    { actionName :: String
actionName = String
"print fusion graph",
      actionDescription :: String
actionDescription = String
"Print fusion graph in Graphviz format.",
      actionProcedure :: Prog SOACS -> FutharkM ()
actionProcedure =
        IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
          (IO () -> FutharkM ())
-> (Prog SOACS -> IO ()) -> Prog SOACS -> FutharkM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FunDef SOACS -> IO ()) -> [FunDef SOACS] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
            ( String -> IO ()
putStrLn
                (String -> IO ())
-> (FunDef SOACS -> String) -> FunDef SOACS -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DepGraph -> String
Futhark.Optimise.Fusion.GraphRep.pprg
                (DepGraph -> String)
-> (FunDef SOACS -> DepGraph) -> FunDef SOACS -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunDef SOACS -> DepGraph
Futhark.Optimise.Fusion.GraphRep.mkDepGraphForFun
            )
          ([FunDef SOACS] -> IO ())
-> (Prog SOACS -> [FunDef SOACS]) -> Prog SOACS -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prog SOACS -> [FunDef SOACS]
forall rep. Prog rep -> [FunDef rep]
progFuns
    }

-- | Print interference information to stdout.
printInterferenceGPU :: Action GPUMem
printInterferenceGPU :: Action GPUMem
printInterferenceGPU =
  Action
    { actionName :: String
actionName = String
"print interference gpu",
      actionDescription :: String
actionDescription = String
"Print interference information on gpu.",
      actionProcedure :: Prog GPUMem -> FutharkM ()
actionProcedure = IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ())
-> (Prog GPUMem -> IO ()) -> Prog GPUMem -> FutharkM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph VName -> IO ()
forall a. Show a => a -> IO ()
print (Graph VName -> IO ())
-> (Prog GPUMem -> Graph VName) -> Prog GPUMem -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prog GPUMem -> Graph VName
Interference.analyseProgGPU
    }

-- | Print memory alias information to stdout
printMemAliasGPU :: Action GPUMem
printMemAliasGPU :: Action GPUMem
printMemAliasGPU =
  Action
    { actionName :: String
actionName = String
"print mem alias gpu",
      actionDescription :: String
actionDescription = String
"Print memory alias information on gpu.",
      actionProcedure :: Prog GPUMem -> FutharkM ()
actionProcedure = IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ())
-> (Prog GPUMem -> IO ()) -> Prog GPUMem -> FutharkM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MemAliases, Map Name MemAliases) -> IO ()
forall a. Show a => a -> IO ()
print ((MemAliases, Map Name MemAliases) -> IO ())
-> (Prog GPUMem -> (MemAliases, Map Name MemAliases))
-> Prog GPUMem
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prog GPUMem -> (MemAliases, Map Name MemAliases)
MemAlias.analyzeGPUMem
    }

-- | Print call graph to stdout.
callGraphAction :: Action SOACS
callGraphAction :: Action SOACS
callGraphAction =
  Action
    { actionName :: String
actionName = String
"call-graph",
      actionDescription :: String
actionDescription = String
"Prettyprint the callgraph of the result to standard output.",
      actionProcedure :: Prog SOACS -> FutharkM ()
actionProcedure = IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ())
-> (Prog SOACS -> IO ()) -> Prog SOACS -> FutharkM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> IO ()) -> (Prog SOACS -> String) -> Prog SOACS -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallGraph -> String
forall a. Pretty a => a -> String
prettyString (CallGraph -> String)
-> (Prog SOACS -> CallGraph) -> Prog SOACS -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prog SOACS -> CallGraph
buildCallGraph
    }

-- | Print metrics about AST node counts to stdout.
metricsAction :: (OpMetrics (Op rep)) => Action rep
metricsAction :: forall rep. OpMetrics (Op rep) => Action rep
metricsAction =
  Action
    { actionName :: String
actionName = String
"Compute metrics",
      actionDescription :: String
actionDescription = String
"Print metrics on the final AST.",
      actionProcedure :: Prog rep -> FutharkM ()
actionProcedure = IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ())
-> (Prog rep -> IO ()) -> Prog rep -> FutharkM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStr (String -> IO ()) -> (Prog rep -> String) -> Prog rep -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstMetrics -> String
forall a. Show a => a -> String
show (AstMetrics -> String)
-> (Prog rep -> AstMetrics) -> Prog rep -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prog rep -> AstMetrics
forall rep. OpMetrics (Op rep) => Prog rep -> AstMetrics
progMetrics
    }

-- | Convert the program to sequential ImpCode and print it to stdout.
impCodeGenAction :: Action SeqMem
impCodeGenAction :: Action SeqMem
impCodeGenAction =
  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 a. IO a -> FutharkM a
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
prettyString (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
    }

-- | Convert the program to GPU ImpCode and print it to stdout.
kernelImpCodeGenAction :: Action GPUMem
kernelImpCodeGenAction :: Action GPUMem
kernelImpCodeGenAction =
  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 GPUMem -> FutharkM ()
actionProcedure = IO () -> FutharkM ()
forall a. IO a -> FutharkM a
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
prettyString (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 GPUMem -> FutharkM (Warnings, Program))
-> Prog GPUMem
-> FutharkM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Prog GPUMem -> FutharkM (Warnings, Program)
forall (m :: * -> *).
MonadFreshNames m =>
Prog GPUMem -> m (Warnings, Program)
ImpGenGPU.compileProgHIP
    }

-- | Convert the program to CPU multicore ImpCode and print it to stdout.
multicoreImpCodeGenAction :: Action MCMem
multicoreImpCodeGenAction :: Action MCMem
multicoreImpCodeGenAction =
  Action
    { actionName :: String
actionName = String
"Compile to imperative multicore",
      actionDescription :: String
actionDescription = String
"Translate program into imperative multicore IL and write it on standard output.",
      actionProcedure :: Prog MCMem -> FutharkM ()
actionProcedure = IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ())
-> ((Warnings, Definitions Multicore) -> IO ())
-> (Warnings, Definitions Multicore)
-> FutharkM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> IO ())
-> ((Warnings, Definitions Multicore) -> String)
-> (Warnings, Definitions Multicore)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definitions Multicore -> String
forall a. Pretty a => a -> String
prettyString (Definitions Multicore -> String)
-> ((Warnings, Definitions Multicore) -> Definitions Multicore)
-> (Warnings, Definitions Multicore)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Warnings, Definitions Multicore) -> Definitions Multicore
forall a b. (a, b) -> b
snd ((Warnings, Definitions Multicore) -> FutharkM ())
-> (Prog MCMem -> FutharkM (Warnings, Definitions Multicore))
-> Prog MCMem
-> FutharkM ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Prog MCMem -> FutharkM (Warnings, Definitions Multicore)
forall (m :: * -> *).
MonadFreshNames m =>
Prog MCMem -> m (Warnings, Definitions Multicore)
ImpGenMulticore.compileProg
    }

-- Lines that we prepend (in comments) to generated code.
headerLines :: [T.Text]
headerLines :: [Text]
headerLines = Text -> [Text]
T.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text
"Generated by Futhark " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
versionString

cHeaderLines :: [T.Text]
cHeaderLines :: [Text]
cHeaderLines = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"// " <>) [Text]
headerLines

pyHeaderLines :: [T.Text]
pyHeaderLines :: [Text]
pyHeaderLines = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"# " <>) [Text]
headerLines

cPrependHeader :: T.Text -> T.Text
cPrependHeader :: Text -> Text
cPrependHeader = ([Text] -> Text
T.unlines [Text]
cHeaderLines <>)

pyPrependHeader :: T.Text -> T.Text
pyPrependHeader :: Text -> Text
pyPrependHeader = ([Text] -> Text
T.unlines [Text]
pyHeaderLines <>)

cmdCC :: String
cmdCC :: String
cmdCC = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"cc" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"CC" [(String, String)]
unixEnvironment

cmdCFLAGS :: [String] -> [String]
cmdCFLAGS :: [String] -> [String]
cmdCFLAGS [String]
def = [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [String]
def String -> [String]
words (Maybe String -> [String]) -> Maybe String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"CFLAGS" [(String, String)]
unixEnvironment

cmdISPCFLAGS :: [String] -> [String]
cmdISPCFLAGS :: [String] -> [String]
cmdISPCFLAGS [String]
def = [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [String]
def String -> [String]
words (Maybe String -> [String]) -> Maybe String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"ISPCFLAGS" [(String, String)]
unixEnvironment

runCC :: String -> String -> [String] -> [String] -> FutharkM ()
runCC :: String -> String -> [String] -> [String] -> FutharkM ()
runCC String
cpath String
outpath [String]
cflags_def [String]
ldflags = do
  Either IOException (ExitCode, String, String)
ret <-
    IO (Either IOException (ExitCode, String, String))
-> FutharkM (Either IOException (ExitCode, String, String))
forall a. IO a -> FutharkM a
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
cmdCC
        ( [String
cpath, String
"-o", String
outpath]
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String] -> [String]
cmdCFLAGS [String]
cflags_def
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
            -- The default LDFLAGS are always added.
            [String]
ldflags
        )
        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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmdCC String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " 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
cmdCC
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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 a. a -> FutharkM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

runISPC :: String -> String -> String -> String -> [String] -> [String] -> [String] -> FutharkM ()
runISPC :: String
-> String
-> String
-> String
-> [String]
-> [String]
-> [String]
-> FutharkM ()
runISPC String
ispcpath String
outpath String
cpath String
ispcextension [String]
ispc_flags [String]
cflags_def [String]
ldflags = do
  Either IOException (ExitCode, String, String)
ret_ispc <-
    IO (Either IOException (ExitCode, String, String))
-> FutharkM (Either IOException (ExitCode, String, String))
forall a. IO a -> FutharkM a
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
cmdISPC
        ( [String
ispcpath, String
"-o", String
ispcbase String -> String -> String
`addExtension` String
"o"]
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"--addressing=64", String
"--pic"]
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String] -> [String]
cmdISPCFLAGS [String]
ispc_flags -- These flags are always needed
        )
        ByteString
forall a. Monoid a => a
mempty
  Either IOException (ExitCode, String, String)
ret <-
    IO (Either IOException (ExitCode, String, String))
-> FutharkM (Either IOException (ExitCode, String, String))
forall a. IO a -> FutharkM a
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
cmdCC
        ( [String
ispcbase String -> String -> String
`addExtension` String
"o"]
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
cpath, String
"-o", String
outpath]
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String] -> [String]
cmdCFLAGS [String]
cflags_def
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
            -- The default LDFLAGS are always added.
            [String]
ldflags
        )
        ByteString
forall a. Monoid a => a
mempty
  case Either IOException (ExitCode, String, String)
ret_ispc 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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmdISPC String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " 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
ispcerr) -> String -> Int -> String -> FutharkM ()
forall {m :: * -> *} {a} {a}.
(MonadError CompilerError m, Show a) =>
String -> a -> String -> m a
throwError String
cmdISPC Int
code String
ispcerr
    Right (ExitCode
ExitSuccess, String
_, String
_) ->
      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 ispc: " 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 -> Int -> String -> FutharkM ()
forall {m :: * -> *} {a} {a}.
(MonadError CompilerError m, Show a) =>
String -> a -> String -> m a
throwError String
cmdCC Int
code String
gccerr
        Right (ExitCode
ExitSuccess, String
_, String
_) ->
          () -> FutharkM ()
forall a. a -> FutharkM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    cmdISPC :: String
cmdISPC = String
"ispc"
    ispcbase :: String
ispcbase = String
outpath String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
ispcextension
    throwError :: String -> a -> String -> m a
throwError String
prog a
code String
err =
      String -> m a
forall (m :: * -> *) a. MonadError CompilerError m => String -> m a
externalErrorS (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$
        String
prog
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" failed with code "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
code
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err

-- | The @futhark c@ action.
compileCAction :: FutharkConfig -> CompilerMode -> FilePath -> Action SeqMem
compileCAction :: FutharkConfig -> CompilerMode -> String -> Action SeqMem
compileCAction FutharkConfig
fcfg CompilerMode
mode String
outpath =
  Action
    { actionName :: String
actionName = String
"Compile to sequential C",
      actionDescription :: String
actionDescription = String
"Compile to sequential C",
      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
$ Text -> Prog SeqMem -> FutharkM (Warnings, CParts)
forall (m :: * -> *).
MonadFreshNames m =>
Text -> Prog SeqMem -> m (Warnings, CParts)
SequentialC.compileProg Text
versionString 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"
          jsonpath :: String
jsonpath = String
outpath String -> String -> String
`addExtension` String
"json"

      case CompilerMode
mode of
        CompilerMode
ToLibrary -> do
          let (Text
header, Text
impl, Text
manifest) = CParts -> (Text, Text, Text)
SequentialC.asLibrary CParts
cprog
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
hpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader Text
header
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
cpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader Text
impl
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
jsonpath Text
manifest
        CompilerMode
ToExecutable -> do
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
cpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ CParts -> Text
SequentialC.asExecutable CParts
cprog
          String -> String -> [String] -> [String] -> FutharkM ()
runCC String
cpath String
outpath [String
"-O3", String
"-std=c99"] [String
"-lm"]
        CompilerMode
ToServer -> do
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
cpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ CParts -> Text
SequentialC.asServer CParts
cprog
          String -> String -> [String] -> [String] -> FutharkM ()
runCC String
cpath String
outpath [String
"-O3", String
"-std=c99"] [String
"-lm"]

-- | The @futhark opencl@ action.
compileOpenCLAction :: FutharkConfig -> CompilerMode -> FilePath -> Action GPUMem
compileOpenCLAction :: FutharkConfig -> CompilerMode -> String -> Action GPUMem
compileOpenCLAction FutharkConfig
fcfg CompilerMode
mode String
outpath =
  Action
    { actionName :: String
actionName = String
"Compile to OpenCL",
      actionDescription :: String
actionDescription = String
"Compile to OpenCL",
      actionProcedure :: Prog GPUMem -> FutharkM ()
actionProcedure = Prog GPUMem -> FutharkM ()
helper
    }
  where
    helper :: Prog GPUMem -> FutharkM ()
helper Prog GPUMem
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
$ Text -> Prog GPUMem -> FutharkM (Warnings, CParts)
forall (m :: * -> *).
MonadFreshNames m =>
Text -> Prog GPUMem -> m (Warnings, CParts)
COpenCL.compileProg Text
versionString Prog GPUMem
prog
      let cpath :: String
cpath = String
outpath String -> String -> String
`addExtension` String
"c"
          hpath :: String
hpath = String
outpath String -> String -> String
`addExtension` String
"h"
          jsonpath :: String
jsonpath = String
outpath String -> String -> String
`addExtension` String
"json"
          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 (Text
header, Text
impl, Text
manifest) = CParts -> (Text, Text, Text)
COpenCL.asLibrary CParts
cprog
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
hpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader Text
header
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
cpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader Text
impl
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
jsonpath Text
manifest
        CompilerMode
ToExecutable -> do
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
cpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ CParts -> Text
COpenCL.asExecutable CParts
cprog
          String -> String -> [String] -> [String] -> FutharkM ()
runCC String
cpath String
outpath [String
"-O", String
"-std=c99"] (String
"-lm" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
extra_options)
        CompilerMode
ToServer -> do
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
cpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ CParts -> Text
COpenCL.asServer CParts
cprog
          String -> String -> [String] -> [String] -> FutharkM ()
runCC String
cpath String
outpath [String
"-O", String
"-std=c99"] (String
"-lm" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
extra_options)

-- | The @futhark cuda@ action.
compileCUDAAction :: FutharkConfig -> CompilerMode -> FilePath -> Action GPUMem
compileCUDAAction :: FutharkConfig -> CompilerMode -> String -> Action GPUMem
compileCUDAAction FutharkConfig
fcfg CompilerMode
mode String
outpath =
  Action
    { actionName :: String
actionName = String
"Compile to CUDA",
      actionDescription :: String
actionDescription = String
"Compile to CUDA",
      actionProcedure :: Prog GPUMem -> FutharkM ()
actionProcedure = Prog GPUMem -> FutharkM ()
helper
    }
  where
    helper :: Prog GPUMem -> FutharkM ()
helper Prog GPUMem
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
$ Text -> Prog GPUMem -> FutharkM (Warnings, CParts)
forall (m :: * -> *).
MonadFreshNames m =>
Text -> Prog GPUMem -> m (Warnings, CParts)
CCUDA.compileProg Text
versionString Prog GPUMem
prog
      let cpath :: String
cpath = String
outpath String -> String -> String
`addExtension` String
"c"
          hpath :: String
hpath = String
outpath String -> String -> String
`addExtension` String
"h"
          jsonpath :: String
jsonpath = String
outpath String -> String -> String
`addExtension` String
"json"
          extra_options :: [String]
extra_options =
            [ String
"-lcuda",
              String
"-lcudart",
              String
"-lnvrtc"
            ]
      case CompilerMode
mode of
        CompilerMode
ToLibrary -> do
          let (Text
header, Text
impl, Text
manifest) = CParts -> (Text, Text, Text)
CCUDA.asLibrary CParts
cprog
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
hpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader Text
header
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
cpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader Text
impl
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
jsonpath Text
manifest
        CompilerMode
ToExecutable -> do
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
cpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ CParts -> Text
CCUDA.asExecutable CParts
cprog
          String -> String -> [String] -> [String] -> FutharkM ()
runCC String
cpath String
outpath [String
"-O", String
"-std=c99"] (String
"-lm" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
extra_options)
        CompilerMode
ToServer -> do
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
cpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ CParts -> Text
CCUDA.asServer CParts
cprog
          String -> String -> [String] -> [String] -> FutharkM ()
runCC String
cpath String
outpath [String
"-O", String
"-std=c99"] (String
"-lm" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
extra_options)

-- | The @futhark hip@ action.
compileHIPAction :: FutharkConfig -> CompilerMode -> FilePath -> Action GPUMem
compileHIPAction :: FutharkConfig -> CompilerMode -> String -> Action GPUMem
compileHIPAction FutharkConfig
fcfg CompilerMode
mode String
outpath =
  Action
    { actionName :: String
actionName = String
"Compile to HIP",
      actionDescription :: String
actionDescription = String
"Compile to HIP",
      actionProcedure :: Prog GPUMem -> FutharkM ()
actionProcedure = Prog GPUMem -> FutharkM ()
helper
    }
  where
    helper :: Prog GPUMem -> FutharkM ()
helper Prog GPUMem
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
$ Text -> Prog GPUMem -> FutharkM (Warnings, CParts)
forall (m :: * -> *).
MonadFreshNames m =>
Text -> Prog GPUMem -> m (Warnings, CParts)
HIP.compileProg Text
versionString Prog GPUMem
prog
      let cpath :: String
cpath = String
outpath String -> String -> String
`addExtension` String
"c"
          hpath :: String
hpath = String
outpath String -> String -> String
`addExtension` String
"h"
          jsonpath :: String
jsonpath = String
outpath String -> String -> String
`addExtension` String
"json"
          extra_options :: [String]
extra_options =
            [ String
"-lamdhip64",
              String
"-lhiprtc"
            ]
      case CompilerMode
mode of
        CompilerMode
ToLibrary -> do
          let (Text
header, Text
impl, Text
manifest) = CParts -> (Text, Text, Text)
HIP.asLibrary CParts
cprog
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
hpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader Text
header
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
cpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader Text
impl
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
jsonpath Text
manifest
        CompilerMode
ToExecutable -> do
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
cpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ CParts -> Text
HIP.asExecutable CParts
cprog
          String -> String -> [String] -> [String] -> FutharkM ()
runCC String
cpath String
outpath [String
"-O", String
"-std=c99"] (String
"-lm" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
extra_options)
        CompilerMode
ToServer -> do
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
cpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ CParts -> Text
HIP.asServer CParts
cprog
          String -> String -> [String] -> [String] -> FutharkM ()
runCC String
cpath String
outpath [String
"-O", String
"-std=c99"] (String
"-lm" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
extra_options)

-- | The @futhark multicore@ action.
compileMulticoreAction :: FutharkConfig -> CompilerMode -> FilePath -> Action MCMem
compileMulticoreAction :: FutharkConfig -> CompilerMode -> String -> Action MCMem
compileMulticoreAction FutharkConfig
fcfg CompilerMode
mode String
outpath =
  Action
    { actionName :: String
actionName = String
"Compile to multicore",
      actionDescription :: String
actionDescription = String
"Compile to multicore",
      actionProcedure :: Prog MCMem -> FutharkM ()
actionProcedure = Prog MCMem -> FutharkM ()
helper
    }
  where
    helper :: Prog MCMem -> FutharkM ()
helper Prog MCMem
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
$ Text -> Prog MCMem -> FutharkM (Warnings, CParts)
forall (m :: * -> *).
MonadFreshNames m =>
Text -> Prog MCMem -> m (Warnings, CParts)
MulticoreC.compileProg Text
versionString Prog MCMem
prog
      let cpath :: String
cpath = String
outpath String -> String -> String
`addExtension` String
"c"
          hpath :: String
hpath = String
outpath String -> String -> String
`addExtension` String
"h"
          jsonpath :: String
jsonpath = String
outpath String -> String -> String
`addExtension` String
"json"

      case CompilerMode
mode of
        CompilerMode
ToLibrary -> do
          let (Text
header, Text
impl, Text
manifest) = CParts -> (Text, Text, Text)
MulticoreC.asLibrary CParts
cprog
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
hpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader Text
header
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
cpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader Text
impl
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
jsonpath Text
manifest
        CompilerMode
ToExecutable -> do
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
cpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ CParts -> Text
MulticoreC.asExecutable CParts
cprog
          String -> String -> [String] -> [String] -> FutharkM ()
runCC String
cpath String
outpath [String
"-O3", String
"-std=c99"] [String
"-lm", String
"-pthread"]
        CompilerMode
ToServer -> do
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
cpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ CParts -> Text
MulticoreC.asServer CParts
cprog
          String -> String -> [String] -> [String] -> FutharkM ()
runCC String
cpath String
outpath [String
"-O3", String
"-std=c99"] [String
"-lm", String
"-pthread"]

-- | The @futhark ispc@ action.
compileMulticoreToISPCAction :: FutharkConfig -> CompilerMode -> FilePath -> Action MCMem
compileMulticoreToISPCAction :: FutharkConfig -> CompilerMode -> String -> Action MCMem
compileMulticoreToISPCAction FutharkConfig
fcfg CompilerMode
mode String
outpath =
  Action
    { actionName :: String
actionName = String
"Compile to multicore ISPC",
      actionDescription :: String
actionDescription = String
"Compile to multicore ISPC",
      actionProcedure :: Prog MCMem -> FutharkM ()
actionProcedure = Prog MCMem -> FutharkM ()
helper
    }
  where
    helper :: Prog MCMem -> FutharkM ()
helper Prog MCMem
prog = do
      let cpath :: String
cpath = String
outpath String -> String -> String
`addExtension` String
"c"
          hpath :: String
hpath = String
outpath String -> String -> String
`addExtension` String
"h"
          jsonpath :: String
jsonpath = String
outpath String -> String -> String
`addExtension` String
"json"
          ispcpath :: String
ispcpath = String
outpath String -> String -> String
`addExtension` String
"kernels.ispc"
          ispcextension :: String
ispcextension = String
"_ispc"
      (CParts
cprog, Text
ispc) <- FutharkConfig
-> FutharkM (Warnings, (CParts, Text)) -> FutharkM (CParts, Text)
forall a. FutharkConfig -> FutharkM (Warnings, a) -> FutharkM a
handleWarnings FutharkConfig
fcfg (FutharkM (Warnings, (CParts, Text)) -> FutharkM (CParts, Text))
-> FutharkM (Warnings, (CParts, Text)) -> FutharkM (CParts, Text)
forall a b. (a -> b) -> a -> b
$ Text -> Prog MCMem -> FutharkM (Warnings, (CParts, Text))
forall (m :: * -> *).
MonadFreshNames m =>
Text -> Prog MCMem -> m (Warnings, (CParts, Text))
MulticoreISPC.compileProg Text
versionString Prog MCMem
prog
      case CompilerMode
mode of
        CompilerMode
ToLibrary -> do
          let (Text
header, Text
impl, Text
manifest) = CParts -> (Text, Text, Text)
MulticoreC.asLibrary CParts
cprog
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
hpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader Text
header
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
cpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader Text
impl
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
ispcpath Text
ispc
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
jsonpath Text
manifest
        CompilerMode
ToExecutable -> do
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
cpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ CParts -> Text
MulticoreC.asExecutable CParts
cprog
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
ispcpath Text
ispc
          String
-> String
-> String
-> String
-> [String]
-> [String]
-> [String]
-> FutharkM ()
runISPC String
ispcpath String
outpath String
cpath String
ispcextension [String
"-O3", String
"--woff"] [String
"-O3", String
"-std=c99"] [String
"-lm", String
"-pthread"]
        CompilerMode
ToServer -> do
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
cpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
cPrependHeader (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ CParts -> Text
MulticoreC.asServer CParts
cprog
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
ispcpath Text
ispc
          String
-> String
-> String
-> String
-> [String]
-> [String]
-> [String]
-> FutharkM ()
runISPC String
ispcpath String
outpath String
cpath String
ispcextension [String
"-O3", String
"--woff"] [String
"-O3", String
"-std=c99"] [String
"-lm", String
"-pthread"]

pythonCommon ::
  (CompilerMode -> String -> prog -> FutharkM (Warnings, T.Text)) ->
  FutharkConfig ->
  CompilerMode ->
  FilePath ->
  prog ->
  FutharkM ()
pythonCommon :: forall prog.
(CompilerMode -> String -> prog -> FutharkM (Warnings, Text))
-> FutharkConfig -> CompilerMode -> String -> prog -> FutharkM ()
pythonCommon CompilerMode -> String -> prog -> FutharkM (Warnings, Text)
codegen FutharkConfig
fcfg CompilerMode
mode String
outpath prog
prog = do
  let class_name :: String
class_name =
        case CompilerMode
mode of
          CompilerMode
ToLibrary -> String -> String
takeBaseName String
outpath
          CompilerMode
_ -> String
"internal"
  Text
pyprog <- FutharkConfig -> FutharkM (Warnings, Text) -> FutharkM Text
forall a. FutharkConfig -> FutharkM (Warnings, a) -> FutharkM a
handleWarnings FutharkConfig
fcfg (FutharkM (Warnings, Text) -> FutharkM Text)
-> FutharkM (Warnings, Text) -> FutharkM Text
forall a b. (a -> b) -> a -> b
$ CompilerMode -> String -> prog -> FutharkM (Warnings, Text)
codegen CompilerMode
mode String
class_name prog
prog

  case CompilerMode
mode of
    CompilerMode
ToLibrary ->
      IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile (String
outpath String -> String -> String
`addExtension` String
"py") (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
pyPrependHeader Text
pyprog
    CompilerMode
_ -> IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ do
      String -> Text -> IO ()
T.writeFile String
outpath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"#!/usr/bin/env python3\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
pyPrependHeader Text
pyprog
      Permissions
perms <- IO Permissions -> IO Permissions
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Permissions -> IO Permissions)
-> IO Permissions -> IO Permissions
forall a b. (a -> b) -> a -> b
$ String -> IO Permissions
getPermissions String
outpath
      String -> Permissions -> IO ()
setPermissions String
outpath (Permissions -> IO ()) -> Permissions -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Permissions -> Permissions
setOwnerExecutable Bool
True Permissions
perms

-- | The @futhark python@ action.
compilePythonAction :: FutharkConfig -> CompilerMode -> FilePath -> Action SeqMem
compilePythonAction :: FutharkConfig -> CompilerMode -> String -> Action SeqMem
compilePythonAction FutharkConfig
fcfg CompilerMode
mode String
outpath =
  Action
    { actionName :: String
actionName = String
"Compile to PyOpenCL",
      actionDescription :: String
actionDescription = String
"Compile to Python with OpenCL",
      actionProcedure :: Prog SeqMem -> FutharkM ()
actionProcedure = (CompilerMode
 -> String -> Prog SeqMem -> FutharkM (Warnings, Text))
-> FutharkConfig
-> CompilerMode
-> String
-> Prog SeqMem
-> FutharkM ()
forall prog.
(CompilerMode -> String -> prog -> FutharkM (Warnings, Text))
-> FutharkConfig -> CompilerMode -> String -> prog -> FutharkM ()
pythonCommon CompilerMode -> String -> Prog SeqMem -> FutharkM (Warnings, Text)
forall (m :: * -> *).
MonadFreshNames m =>
CompilerMode -> String -> Prog SeqMem -> m (Warnings, Text)
SequentialPy.compileProg FutharkConfig
fcfg CompilerMode
mode String
outpath
    }

-- | The @futhark pyopencl@ action.
compilePyOpenCLAction :: FutharkConfig -> CompilerMode -> FilePath -> Action GPUMem
compilePyOpenCLAction :: FutharkConfig -> CompilerMode -> String -> Action GPUMem
compilePyOpenCLAction FutharkConfig
fcfg CompilerMode
mode String
outpath =
  Action
    { actionName :: String
actionName = String
"Compile to PyOpenCL",
      actionDescription :: String
actionDescription = String
"Compile to Python with OpenCL",
      actionProcedure :: Prog GPUMem -> FutharkM ()
actionProcedure = (CompilerMode
 -> String -> Prog GPUMem -> FutharkM (Warnings, Text))
-> FutharkConfig
-> CompilerMode
-> String
-> Prog GPUMem
-> FutharkM ()
forall prog.
(CompilerMode -> String -> prog -> FutharkM (Warnings, Text))
-> FutharkConfig -> CompilerMode -> String -> prog -> FutharkM ()
pythonCommon CompilerMode -> String -> Prog GPUMem -> FutharkM (Warnings, Text)
forall (m :: * -> *).
MonadFreshNames m =>
CompilerMode -> String -> Prog GPUMem -> m (Warnings, Text)
PyOpenCL.compileProg FutharkConfig
fcfg CompilerMode
mode String
outpath
    }

cmdEMCFLAGS :: [String] -> [String]
cmdEMCFLAGS :: [String] -> [String]
cmdEMCFLAGS [String]
def = [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [String]
def String -> [String]
words (Maybe String -> [String]) -> Maybe String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"EMCFLAGS" [(String, String)]
unixEnvironment

runEMCC :: String -> String -> FilePath -> [String] -> [String] -> [String] -> Bool -> FutharkM ()
runEMCC :: String
-> String
-> String
-> [String]
-> [String]
-> [String]
-> Bool
-> FutharkM ()
runEMCC String
cpath String
outpath String
classpath [String]
cflags_def [String]
ldflags [String]
expfuns Bool
lib = do
  Either IOException (ExitCode, String, String)
ret <-
    IO (Either IOException (ExitCode, String, String))
-> FutharkM (Either IOException (ExitCode, String, String))
forall a. IO a -> FutharkM a
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
"emcc"
        ( [String
cpath, String
"-o", String
outpath]
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-lnodefs.js"]
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-s", String
"--extern-post-js", String
classpath]
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ( if Bool
lib
                   then [String
"-s", String
"EXPORT_NAME=loadWASM"]
                   else []
               )
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-s", String
"WASM_BIGINT"]
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String] -> [String]
cmdCFLAGS [String]
cflags_def
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String] -> [String]
cmdEMCFLAGS [String
""]
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"-s",
                 String
"EXPORTED_FUNCTIONS=["
                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," (String
"'_malloc'" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"'_free'" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
expfuns)
                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
               ]
            -- The default LDFLAGS are always added.
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ldflags
        )
        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 emcc: " 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
emccerr) ->
      String -> FutharkM ()
forall (m :: * -> *) a. MonadError CompilerError m => String -> m a
externalErrorS (String -> FutharkM ()) -> String -> FutharkM ()
forall a b. (a -> b) -> a -> b
$
        String
"emcc 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
emccerr
    Right (ExitCode
ExitSuccess, String
_, String
_) ->
      () -> FutharkM ()
forall a. a -> FutharkM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | The @futhark wasm@ action.
compileCtoWASMAction :: FutharkConfig -> CompilerMode -> FilePath -> Action SeqMem
compileCtoWASMAction :: FutharkConfig -> CompilerMode -> String -> Action SeqMem
compileCtoWASMAction FutharkConfig
fcfg CompilerMode
mode String
outpath =
  Action
    { actionName :: String
actionName = String
"Compile to sequential C",
      actionDescription :: String
actionDescription = String
"Compile to sequential C",
      actionProcedure :: Prog SeqMem -> FutharkM ()
actionProcedure = Prog SeqMem -> FutharkM ()
helper
    }
  where
    helper :: Prog SeqMem -> FutharkM ()
helper Prog SeqMem
prog = do
      (CParts
cprog, Text
jsprog, [String]
exps) <-
        FutharkConfig
-> FutharkM (Warnings, (CParts, Text, [String]))
-> FutharkM (CParts, Text, [String])
forall a. FutharkConfig -> FutharkM (Warnings, a) -> FutharkM a
handleWarnings FutharkConfig
fcfg (FutharkM (Warnings, (CParts, Text, [String]))
 -> FutharkM (CParts, Text, [String]))
-> FutharkM (Warnings, (CParts, Text, [String]))
-> FutharkM (CParts, Text, [String])
forall a b. (a -> b) -> a -> b
$ Text
-> Prog SeqMem -> FutharkM (Warnings, (CParts, Text, [String]))
forall (m :: * -> *).
MonadFreshNames m =>
Text -> Prog SeqMem -> m (Warnings, (CParts, Text, [String]))
SequentialWASM.compileProg Text
versionString Prog SeqMem
prog
      case CompilerMode
mode of
        CompilerMode
ToLibrary -> do
          CParts -> Text -> FutharkM ()
forall {m :: * -> *}. MonadIO m => CParts -> Text -> m ()
writeLibs CParts
cprog Text
jsprog
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.appendFile String
classpath Text
SequentialWASM.libraryExports
          String
-> String
-> String
-> [String]
-> [String]
-> [String]
-> Bool
-> FutharkM ()
runEMCC String
cpath String
mjspath String
classpath [String
"-O3", String
"-msimd128"] [String
"-lm"] [String]
exps Bool
True
        CompilerMode
_ -> do
          -- Non-server executables are not supported.
          CParts -> Text -> FutharkM ()
forall {m :: * -> *}. MonadIO m => CParts -> Text -> m ()
writeLibs CParts
cprog Text
jsprog
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.appendFile String
classpath Text
SequentialWASM.runServer
          String
-> String
-> String
-> [String]
-> [String]
-> [String]
-> Bool
-> FutharkM ()
runEMCC String
cpath String
outpath String
classpath [String
"-O3", String
"-msimd128"] [String
"-lm"] [String]
exps Bool
False
    writeLibs :: CParts -> Text -> m ()
writeLibs CParts
cprog Text
jsprog = do
      let (Text
h, Text
imp, Text
_) = CParts -> (Text, Text, Text)
SequentialC.asLibrary CParts
cprog
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
hpath Text
h
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
cpath Text
imp
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
classpath Text
jsprog

    cpath :: String
cpath = String
outpath String -> String -> String
`addExtension` String
"c"
    hpath :: String
hpath = String
outpath String -> String -> String
`addExtension` String
"h"
    mjspath :: String
mjspath = String
outpath String -> String -> String
`addExtension` String
"mjs"
    classpath :: String
classpath = String
outpath String -> String -> String
`addExtension` String
".class.js"

-- | The @futhark wasm-multicore@ action.
compileMulticoreToWASMAction :: FutharkConfig -> CompilerMode -> FilePath -> Action MCMem
compileMulticoreToWASMAction :: FutharkConfig -> CompilerMode -> String -> Action MCMem
compileMulticoreToWASMAction FutharkConfig
fcfg CompilerMode
mode String
outpath =
  Action
    { actionName :: String
actionName = String
"Compile to sequential C",
      actionDescription :: String
actionDescription = String
"Compile to sequential C",
      actionProcedure :: Prog MCMem -> FutharkM ()
actionProcedure = Prog MCMem -> FutharkM ()
helper
    }
  where
    helper :: Prog MCMem -> FutharkM ()
helper Prog MCMem
prog = do
      (CParts
cprog, Text
jsprog, [String]
exps) <-
        FutharkConfig
-> FutharkM (Warnings, (CParts, Text, [String]))
-> FutharkM (CParts, Text, [String])
forall a. FutharkConfig -> FutharkM (Warnings, a) -> FutharkM a
handleWarnings FutharkConfig
fcfg (FutharkM (Warnings, (CParts, Text, [String]))
 -> FutharkM (CParts, Text, [String]))
-> FutharkM (Warnings, (CParts, Text, [String]))
-> FutharkM (CParts, Text, [String])
forall a b. (a -> b) -> a -> b
$ Text -> Prog MCMem -> FutharkM (Warnings, (CParts, Text, [String]))
forall (m :: * -> *).
MonadFreshNames m =>
Text -> Prog MCMem -> m (Warnings, (CParts, Text, [String]))
MulticoreWASM.compileProg Text
versionString Prog MCMem
prog

      case CompilerMode
mode of
        CompilerMode
ToLibrary -> do
          CParts -> Text -> FutharkM ()
forall {m :: * -> *}. MonadIO m => CParts -> Text -> m ()
writeLibs CParts
cprog Text
jsprog
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.appendFile String
classpath Text
MulticoreWASM.libraryExports
          String
-> String
-> String
-> [String]
-> [String]
-> [String]
-> Bool
-> FutharkM ()
runEMCC String
cpath String
mjspath String
classpath [String
"-O3", String
"-msimd128"] [String
"-lm", String
"-pthread"] [String]
exps Bool
True
        CompilerMode
_ -> do
          -- Non-server executables are not supported.
          CParts -> Text -> FutharkM ()
forall {m :: * -> *}. MonadIO m => CParts -> Text -> m ()
writeLibs CParts
cprog Text
jsprog
          IO () -> FutharkM ()
forall a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.appendFile String
classpath Text
MulticoreWASM.runServer
          String
-> String
-> String
-> [String]
-> [String]
-> [String]
-> Bool
-> FutharkM ()
runEMCC String
cpath String
outpath String
classpath [String
"-O3", String
"-msimd128"] [String
"-lm", String
"-pthread"] [String]
exps Bool
False

    writeLibs :: CParts -> Text -> m ()
writeLibs CParts
cprog Text
jsprog = do
      let (Text
h, Text
imp, Text
_) = CParts -> (Text, Text, Text)
MulticoreC.asLibrary CParts
cprog
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
hpath Text
h
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
cpath Text
imp
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
T.writeFile String
classpath Text
jsprog

    cpath :: String
cpath = String
outpath String -> String -> String
`addExtension` String
"c"
    hpath :: String
hpath = String
outpath String -> String -> String
`addExtension` String
"h"
    mjspath :: String
mjspath = String
outpath String -> String -> String
`addExtension` String
"mjs"
    classpath :: String
classpath = String
outpath String -> String -> String
`addExtension` String
".class.js"