{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TupleSections #-}

-- | Code generation for server executables.
module Futhark.CodeGen.Backends.GenericC.Server
  ( serverDefs,
  )
where

import Data.Bifunctor (first, second)
import Data.FileEmbed
import qualified Data.Map as M
import Futhark.CodeGen.Backends.GenericC.Options
import Futhark.CodeGen.Backends.SimpleRep
import Futhark.CodeGen.ImpCode
import qualified Language.C.Quote.OpenCL as C
import qualified Language.C.Syntax as C

genericOptions :: [Option]
genericOptions :: [Option]
genericOptions =
  [ Option :: [Char] -> Maybe Char -> OptionArgument -> [Char] -> Stm -> Option
Option
      { optionLongName :: [Char]
optionLongName = [Char]
"debugging",
        optionShortName :: Maybe Char
optionShortName = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'D',
        optionArgument :: OptionArgument
optionArgument = OptionArgument
NoArgument,
        optionDescription :: [Char]
optionDescription = [Char]
"Perform possibly expensive internal correctness checks and verbose logging.",
        optionAction :: Stm
optionAction = [C.cstm|futhark_context_config_set_debugging(cfg, 1);|]
      },
    Option :: [Char] -> Maybe Char -> OptionArgument -> [Char] -> Stm -> Option
Option
      { optionLongName :: [Char]
optionLongName = [Char]
"log",
        optionShortName :: Maybe Char
optionShortName = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'L',
        optionArgument :: OptionArgument
optionArgument = OptionArgument
NoArgument,
        optionDescription :: [Char]
optionDescription = [Char]
"Print various low-overhead logging information while running.",
        optionAction :: Stm
optionAction = [C.cstm|futhark_context_config_set_logging(cfg, 1);|]
      },
    Option :: [Char] -> Maybe Char -> OptionArgument -> [Char] -> Stm -> Option
Option
      { optionLongName :: [Char]
optionLongName = [Char]
"help",
        optionShortName :: Maybe Char
optionShortName = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'h',
        optionArgument :: OptionArgument
optionArgument = OptionArgument
NoArgument,
        optionDescription :: [Char]
optionDescription = [Char]
"Print help information and exit.",
        optionAction :: Stm
optionAction =
          [C.cstm|{
                   printf("Usage: %s [OPTIONS]...\nOptions:\n\n%s\nFor more information, consult the Futhark User's Guide or the man pages.\n",
                          fut_progname, option_descriptions);
                   exit(0);
                  }|]
      },
    Option :: [Char] -> Maybe Char -> OptionArgument -> [Char] -> Stm -> Option
Option
      { optionLongName :: [Char]
optionLongName = [Char]
"print-sizes",
        optionShortName :: Maybe Char
optionShortName = Maybe Char
forall a. Maybe a
Nothing,
        optionArgument :: OptionArgument
optionArgument = OptionArgument
NoArgument,
        optionDescription :: [Char]
optionDescription = [Char]
"Print all sizes that can be set with --size or --tuning.",
        optionAction :: Stm
optionAction =
          [C.cstm|{
                int n = futhark_get_num_sizes();
                for (int i = 0; i < n; i++) {
                  printf("%s (%s)\n", futhark_get_size_name(i),
                                      futhark_get_size_class(i));
                }
                exit(0);
              }|]
      },
    Option :: [Char] -> Maybe Char -> OptionArgument -> [Char] -> Stm -> Option
Option
      { optionLongName :: [Char]
optionLongName = [Char]
"size",
        optionShortName :: Maybe Char
optionShortName = Maybe Char
forall a. Maybe a
Nothing,
        optionArgument :: OptionArgument
optionArgument = [Char] -> OptionArgument
RequiredArgument [Char]
"ASSIGNMENT",
        optionDescription :: [Char]
optionDescription = [Char]
"Set a configurable run-time parameter to the given value.",
        optionAction :: Stm
optionAction =
          [C.cstm|{
                char *name = optarg;
                char *equals = strstr(optarg, "=");
                char *value_str = equals != NULL ? equals+1 : optarg;
                int value = atoi(value_str);
                if (equals != NULL) {
                  *equals = 0;
                  if (futhark_context_config_set_size(cfg, name, value) != 0) {
                    futhark_panic(1, "Unknown size: %s\n", name);
                  }
                } else {
                  futhark_panic(1, "Invalid argument for size option: %s\n", optarg);
                }}|]
      },
    Option :: [Char] -> Maybe Char -> OptionArgument -> [Char] -> Stm -> Option
Option
      { optionLongName :: [Char]
optionLongName = [Char]
"tuning",
        optionShortName :: Maybe Char
optionShortName = Maybe Char
forall a. Maybe a
Nothing,
        optionArgument :: OptionArgument
optionArgument = [Char] -> OptionArgument
RequiredArgument [Char]
"FILE",
        optionDescription :: [Char]
optionDescription = [Char]
"Read size=value assignments from the given file.",
        optionAction :: Stm
optionAction =
          [C.cstm|{
                char *ret = load_tuning_file(optarg, cfg, (int(*)(void*, const char*, size_t))
                                                          futhark_context_config_set_size);
                if (ret != NULL) {
                  futhark_panic(1, "When loading tuning from '%s': %s\n", optarg, ret);
                }}|]
      }
  ]

typeStructName :: ExternalValue -> String
typeStructName :: ExternalValue -> [Char]
typeStructName (TransparentValue (ScalarValue PrimType
pt Signedness
signed VName
_)) =
  let name :: [Char]
name = Bool -> PrimType -> [Char]
prettySigned (Signedness
signed Signedness -> Signedness -> Bool
forall a. Eq a => a -> a -> Bool
== Signedness
TypeUnsigned) PrimType
pt
   in [Char]
"type_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name
typeStructName (TransparentValue (ArrayValue VName
_ Space
_ PrimType
pt Signedness
signed [DimSize]
shape)) =
  let rank :: Int
rank = [DimSize] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DimSize]
shape
      name :: [Char]
name = PrimType -> Signedness -> Int -> [Char]
arrayName PrimType
pt Signedness
signed Int
rank
   in [Char]
"type_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name
typeStructName (OpaqueValue [Char]
name [ValueDesc]
vds) =
  [Char]
"type_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [ValueDesc] -> [Char]
opaqueName [Char]
name [ValueDesc]
vds

valueDescBoilerplate :: ExternalValue -> (String, (C.Initializer, [C.Definition]))
valueDescBoilerplate :: ExternalValue -> ([Char], (Initializer, [Definition]))
valueDescBoilerplate ev :: ExternalValue
ev@(TransparentValue (ScalarValue PrimType
pt Signedness
signed VName
_)) =
  let name :: [Char]
name = Bool -> PrimType -> [Char]
prettySigned (Signedness
signed Signedness -> Signedness -> Bool
forall a. Eq a => a -> a -> Bool
== Signedness
TypeUnsigned) PrimType
pt
      type_name :: [Char]
type_name = ExternalValue -> [Char]
typeStructName ExternalValue
ev
   in ([Char]
name, ([C.cinit|&$id:type_name|], [Definition]
forall a. Monoid a => a
mempty))
valueDescBoilerplate ev :: ExternalValue
ev@(TransparentValue (ArrayValue VName
_ Space
_ PrimType
pt Signedness
signed [DimSize]
shape)) =
  let rank :: Int
rank = [DimSize] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DimSize]
shape
      name :: [Char]
name = PrimType -> Signedness -> Int -> [Char]
arrayName PrimType
pt Signedness
signed Int
rank
      pt_name :: [Char]
pt_name = Bool -> PrimType -> [Char]
prettySigned (Signedness
signed Signedness -> Signedness -> Bool
forall a. Eq a => a -> a -> Bool
== Signedness
TypeUnsigned) PrimType
pt
      pretty_name :: [Char]
pretty_name = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Int -> [Char] -> [[Char]]
forall a. Int -> a -> [a]
replicate Int
rank [Char]
"[]") [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
pt_name
      type_name :: [Char]
type_name = ExternalValue -> [Char]
typeStructName ExternalValue
ev
      aux_name :: [Char]
aux_name = [Char]
type_name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_aux"
      info_name :: [Char]
info_name = [Char]
pt_name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_info"
      array_new :: [Char]
array_new = [Char]
"futhark_new_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name
      array_new_wrap :: [Char]
array_new_wrap = [Char]
"futhark_new_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_wrap"
      array_free :: [Char]
array_free = [Char]
"futhark_free_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name
      array_shape :: [Char]
array_shape = [Char]
"futhark_shape_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name
      array_values :: [Char]
array_values = [Char]
"futhark_values_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name
      shape_args :: [Exp]
shape_args = [[C.cexp|shape[$int:i]|] | Int
i <- [Int
0 .. Int
rank Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]]
   in ( [Char]
name,
        ( [C.cinit|&$id:type_name|],
          [C.cunit|
              void* $id:array_new_wrap(struct futhark_context *ctx,
                                       const void* p,
                                       const typename int64_t* shape) {
                return $id:array_new(ctx, p, $args:shape_args);
              }
              struct array_aux $id:aux_name = {
                .name = $string:pretty_name,
                .rank = $int:rank,
                .info = &$id:info_name,
                .new = (typename array_new_fn)$id:array_new_wrap,
                .free = (typename array_free_fn)$id:array_free,
                .shape = (typename array_shape_fn)$id:array_shape,
                .values = (typename array_values_fn)$id:array_values
              };
              struct type $id:type_name = {
                .name = $string:pretty_name,
                .restore = (typename restore_fn)restore_array,
                .store = (typename store_fn)store_array,
                .free = (typename free_fn)free_array,
                .aux = &$id:aux_name
              };|]
        )
      )
valueDescBoilerplate ev :: ExternalValue
ev@(OpaqueValue [Char]
name [ValueDesc]
vds) =
  let type_name :: [Char]
type_name = ExternalValue -> [Char]
typeStructName ExternalValue
ev
      aux_name :: [Char]
aux_name = [Char]
type_name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_aux"
      opaque_free :: [Char]
opaque_free = [Char]
"futhark_free_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [ValueDesc] -> [Char]
opaqueName [Char]
name [ValueDesc]
vds
      opaque_store :: [Char]
opaque_store = [Char]
"futhark_store_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [ValueDesc] -> [Char]
opaqueName [Char]
name [ValueDesc]
vds
      opaque_restore :: [Char]
opaque_restore = [Char]
"futhark_restore_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [ValueDesc] -> [Char]
opaqueName [Char]
name [ValueDesc]
vds
   in ( [Char]
name,
        ( [C.cinit|&$id:type_name|],
          [C.cunit|
              struct opaque_aux $id:aux_name = {
                .store = (typename opaque_store_fn)$id:opaque_store,
                .restore = (typename opaque_restore_fn)$id:opaque_restore,
                .free = (typename opaque_free_fn)$id:opaque_free
              };
              struct type $id:type_name = {
                .name = $string:name,
                .restore = (typename restore_fn)restore_opaque,
                .store = (typename store_fn)store_opaque,
                .free = (typename free_fn)free_opaque,
                .aux = &$id:aux_name
              };|]
        )
      )

functionExternalValues :: Function a -> [ExternalValue]
functionExternalValues :: forall a. Function a -> [ExternalValue]
functionExternalValues Function a
fun = Function a -> [ExternalValue]
forall a. Function a -> [ExternalValue]
functionResult Function a
fun [ExternalValue] -> [ExternalValue] -> [ExternalValue]
forall a. [a] -> [a] -> [a]
++ Function a -> [ExternalValue]
forall a. Function a -> [ExternalValue]
functionArgs Function a
fun

entryTypeBoilerplate :: Functions a -> ([C.Initializer], [C.Definition])
entryTypeBoilerplate :: forall a. Functions a -> ([Initializer], [Definition])
entryTypeBoilerplate (Functions [(Name, Function a)]
funs) =
  ([[Definition]] -> [Definition])
-> ([Initializer], [[Definition]]) -> ([Initializer], [Definition])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [[Definition]] -> [Definition]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([Initializer], [[Definition]]) -> ([Initializer], [Definition]))
-> ([Initializer], [[Definition]]) -> ([Initializer], [Definition])
forall a b. (a -> b) -> a -> b
$
    [(Initializer, [Definition])] -> ([Initializer], [[Definition]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Initializer, [Definition])] -> ([Initializer], [[Definition]]))
-> [(Initializer, [Definition])] -> ([Initializer], [[Definition]])
forall a b. (a -> b) -> a -> b
$
      Map [Char] (Initializer, [Definition])
-> [(Initializer, [Definition])]
forall k a. Map k a -> [a]
M.elems (Map [Char] (Initializer, [Definition])
 -> [(Initializer, [Definition])])
-> Map [Char] (Initializer, [Definition])
-> [(Initializer, [Definition])]
forall a b. (a -> b) -> a -> b
$
        [([Char], (Initializer, [Definition]))]
-> Map [Char] (Initializer, [Definition])
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([([Char], (Initializer, [Definition]))]
 -> Map [Char] (Initializer, [Definition]))
-> [([Char], (Initializer, [Definition]))]
-> Map [Char] (Initializer, [Definition])
forall a b. (a -> b) -> a -> b
$
          (ExternalValue -> ([Char], (Initializer, [Definition])))
-> [ExternalValue] -> [([Char], (Initializer, [Definition]))]
forall a b. (a -> b) -> [a] -> [b]
map ExternalValue -> ([Char], (Initializer, [Definition]))
valueDescBoilerplate ([ExternalValue] -> [([Char], (Initializer, [Definition]))])
-> [ExternalValue] -> [([Char], (Initializer, [Definition]))]
forall a b. (a -> b) -> a -> b
$
            ((Name, Function a) -> [ExternalValue])
-> [(Name, Function a)] -> [ExternalValue]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Function a -> [ExternalValue]
forall a. Function a -> [ExternalValue]
functionExternalValues (Function a -> [ExternalValue])
-> ((Name, Function a) -> Function a)
-> (Name, Function a)
-> [ExternalValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Function a) -> Function a
forall a b. (a, b) -> b
snd) ([(Name, Function a)] -> [ExternalValue])
-> [(Name, Function a)] -> [ExternalValue]
forall a b. (a -> b) -> a -> b
$
              ((Name, Function a) -> Bool)
-> [(Name, Function a)] -> [(Name, Function a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Function a -> Bool
forall a. FunctionT a -> Bool
functionEntry (Function a -> Bool)
-> ((Name, Function a) -> Function a) -> (Name, Function a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Function a) -> Function a
forall a b. (a, b) -> b
snd) [(Name, Function a)]
funs

oneEntryBoilerplate :: (Name, Function a) -> ([C.Definition], C.Initializer)
oneEntryBoilerplate :: forall a. (Name, Function a) -> ([Definition], Initializer)
oneEntryBoilerplate (Name
name, Function a
fun) =
  let entry_f :: [Char]
entry_f = [Char]
"futhark_entry_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
pretty Name
name
      call_f :: [Char]
call_f = [Char]
"call_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
pretty Name
name
      out_types :: [ExternalValue]
out_types = Function a -> [ExternalValue]
forall a. Function a -> [ExternalValue]
functionResult Function a
fun
      in_types :: [ExternalValue]
in_types = Function a -> [ExternalValue]
forall a. Function a -> [ExternalValue]
functionArgs Function a
fun
      out_types_name :: [Char]
out_types_name = Name -> [Char]
forall a. Pretty a => a -> [Char]
pretty Name
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_out_types"
      in_types_name :: [Char]
in_types_name = Name -> [Char]
forall a. Pretty a => a -> [Char]
pretty Name
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_in_types"
      ([BlockItem]
out_items, [Exp]
out_args)
        | [ExternalValue] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ExternalValue]
out_types = ([C.citems|(void)outs;|], [Exp]
forall a. Monoid a => a
mempty)
        | Bool
otherwise = [(BlockItem, Exp)] -> ([BlockItem], [Exp])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(BlockItem, Exp)] -> ([BlockItem], [Exp]))
-> [(BlockItem, Exp)] -> ([BlockItem], [Exp])
forall a b. (a -> b) -> a -> b
$ (Int -> ExternalValue -> (BlockItem, Exp))
-> [Int] -> [ExternalValue] -> [(BlockItem, Exp)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> ExternalValue -> (BlockItem, Exp)
loadOut [Int
0 ..] [ExternalValue]
out_types
      ([BlockItem]
in_items, [Exp]
in_args)
        | [ExternalValue] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ExternalValue]
in_types = ([C.citems|(void)ins;|], [Exp]
forall a. Monoid a => a
mempty)
        | Bool
otherwise = [(BlockItem, Exp)] -> ([BlockItem], [Exp])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(BlockItem, Exp)] -> ([BlockItem], [Exp]))
-> [(BlockItem, Exp)] -> ([BlockItem], [Exp])
forall a b. (a -> b) -> a -> b
$ (Int -> ExternalValue -> (BlockItem, Exp))
-> [Int] -> [ExternalValue] -> [(BlockItem, Exp)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> ExternalValue -> (BlockItem, Exp)
loadIn [Int
0 ..] [ExternalValue]
in_types
   in ( [C.cunit|
                struct type* $id:out_types_name[] = {
                  $inits:(map typeStructInit out_types),
                  NULL
                };
                struct type* $id:in_types_name[] = {
                  $inits:(map typeStructInit in_types),
                  NULL
                };
                int $id:call_f(struct futhark_context *ctx, void **outs, void **ins) {
                  $items:out_items
                  $items:in_items
                  return $id:entry_f(ctx, $args:out_args, $args:in_args);
                }
                |],
        [C.cinit|{
            .name = $string:(pretty name),
            .f = $id:call_f,
            .in_types = $id:in_types_name,
            .out_types = $id:out_types_name
            }|]
      )
  where
    typeStructInit :: ExternalValue -> Initializer
typeStructInit ExternalValue
t = [C.cinit|&$id:(typeStructName t)|]

    loadOut :: Int -> ExternalValue -> (BlockItem, Exp)
loadOut Int
i ExternalValue
ev =
      let v :: [Char]
v = [Char]
"out" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
i :: Int)
       in ( [C.citem|$ty:(externalValueType ev) *$id:v = outs[$int:i];|],
            [C.cexp|$id:v|]
          )
    loadIn :: Int -> ExternalValue -> (BlockItem, Exp)
loadIn Int
i ExternalValue
ev =
      let v :: [Char]
v = [Char]
"in" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
i :: Int)
          evt :: Type
evt = ExternalValue -> Type
externalValueType ExternalValue
ev
       in ( [C.citem|$ty:evt $id:v = *($ty:evt*)ins[$int:i];|],
            [C.cexp|$id:v|]
          )

entryBoilerplate :: Functions a -> ([C.Definition], [C.Initializer])
entryBoilerplate :: forall a. Functions a -> ([Definition], [Initializer])
entryBoilerplate (Functions [(Name, Function a)]
funs) =
  ([[Definition]] -> [Definition])
-> ([[Definition]], [Initializer]) -> ([Definition], [Initializer])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [[Definition]] -> [Definition]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([[Definition]], [Initializer]) -> ([Definition], [Initializer]))
-> ([[Definition]], [Initializer]) -> ([Definition], [Initializer])
forall a b. (a -> b) -> a -> b
$ [([Definition], Initializer)] -> ([[Definition]], [Initializer])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([Definition], Initializer)] -> ([[Definition]], [Initializer]))
-> [([Definition], Initializer)] -> ([[Definition]], [Initializer])
forall a b. (a -> b) -> a -> b
$ ((Name, Function a) -> ([Definition], Initializer))
-> [(Name, Function a)] -> [([Definition], Initializer)]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Function a) -> ([Definition], Initializer)
forall a. (Name, Function a) -> ([Definition], Initializer)
oneEntryBoilerplate ([(Name, Function a)] -> [([Definition], Initializer)])
-> [(Name, Function a)] -> [([Definition], Initializer)]
forall a b. (a -> b) -> a -> b
$ ((Name, Function a) -> Bool)
-> [(Name, Function a)] -> [(Name, Function a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Function a -> Bool
forall a. FunctionT a -> Bool
functionEntry (Function a -> Bool)
-> ((Name, Function a) -> Function a) -> (Name, Function a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Function a) -> Function a
forall a b. (a, b) -> b
snd) [(Name, Function a)]
funs

mkBoilerplate ::
  Functions a ->
  ([C.Definition], [C.Initializer], [C.Initializer])
mkBoilerplate :: forall a.
Functions a -> ([Definition], [Initializer], [Initializer])
mkBoilerplate Functions a
funs =
  let ([Initializer]
type_inits, [Definition]
type_defs) = Functions a -> ([Initializer], [Definition])
forall a. Functions a -> ([Initializer], [Definition])
entryTypeBoilerplate Functions a
funs
      ([Definition]
entry_defs, [Initializer]
entry_inits) = Functions a -> ([Definition], [Initializer])
forall a. Functions a -> ([Definition], [Initializer])
entryBoilerplate Functions a
funs
   in ([Definition]
type_defs [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++ [Definition]
entry_defs, [Initializer]
type_inits, [Initializer]
entry_inits)

{-# NOINLINE serverDefs #-}

-- | Generate Futhark server executable code.
serverDefs :: [Option] -> Functions a -> [C.Definition]
serverDefs :: forall a. [Option] -> Functions a -> [Definition]
serverDefs [Option]
options Functions a
funs =
  let server_h :: [Char]
server_h = $(embedStringFile "rts/c/server.h")
      values_h :: [Char]
values_h = $(embedStringFile "rts/c/values.h")
      tuning_h :: [Char]
tuning_h = $(embedStringFile "rts/c/tuning.h")
      option_parser :: Func
option_parser =
        [Char] -> [Option] -> Func
generateOptionParser [Char]
"parse_options" ([Option] -> Func) -> [Option] -> Func
forall a b. (a -> b) -> a -> b
$ [Option]
genericOptions [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
options
      ([Definition]
boilerplate_defs, [Initializer]
type_inits, [Initializer]
entry_point_inits) =
        Functions a -> ([Definition], [Initializer], [Initializer])
forall a.
Functions a -> ([Definition], [Initializer], [Initializer])
mkBoilerplate Functions a
funs
   in [C.cunit|
$esc:("#include <getopt.h>")
$esc:("#include <ctype.h>")
$esc:("#include <inttypes.h>")

// If the entry point is NULL, the program will terminate after doing initialisation and such.  It is not used for anything else in server mode.
static const char *entry_point = "main";

$esc:values_h
$esc:server_h
$esc:tuning_h

$edecls:boilerplate_defs

struct type* types[] = {
  $inits:type_inits,
  NULL
};

struct entry_point entry_points[] = {
  $inits:entry_point_inits,
  { .name = NULL }
};

struct futhark_prog prog = {
  .types = types,
  .entry_points = entry_points
};

$func:option_parser

int main(int argc, char** argv) {
  fut_progname = argv[0];

  struct futhark_context_config *cfg = futhark_context_config_new();
  assert(cfg != NULL);

  int parsed_options = parse_options(cfg, argc, argv);
  argc -= parsed_options;
  argv += parsed_options;

  if (argc != 0) {
    futhark_panic(1, "Excess non-option: %s\n", argv[0]);
  }

  struct futhark_context *ctx = futhark_context_new(cfg);
  assert (ctx != NULL);

  futhark_context_set_logging_file(ctx, stdout);

  char* error = futhark_context_get_error(ctx);
  if (error != NULL) {
    futhark_panic(1, "Error during context initialisation:\n%s", error);
  }

  if (entry_point != NULL) {
    run_server(&prog, ctx);
  }

  futhark_context_free(ctx);
  futhark_context_config_free(cfg);
}
|]