{-# LANGUAGE QuasiQuotes #-}

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

import Data.Bifunctor (first, second)
import Data.List (unzip4)
import Data.Map qualified as M
import Data.Text qualified as T
import Futhark.CodeGen.Backends.GenericC.Options
import Futhark.CodeGen.Backends.GenericC.Pretty
import Futhark.CodeGen.Backends.SimpleRep
import Futhark.CodeGen.RTS.C (serverH, tuningH, valuesH)
import Futhark.Manifest
import Futhark.Util (zEncodeText)
import Futhark.Util.Pretty (prettyText)
import Language.C.Quote.OpenCL qualified as C
import Language.C.Syntax qualified as C
import Language.Futhark.Core (nameFromText)

genericOptions :: [Option]
genericOptions :: [Option]
genericOptions =
  [ Option
      { optionLongName :: String
optionLongName = String
"debugging",
        optionShortName :: Maybe Char
optionShortName = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'D',
        optionArgument :: OptionArgument
optionArgument = OptionArgument
NoArgument,
        optionDescription :: String
optionDescription = String
"Perform possibly expensive internal correctness checks and verbose logging.",
        optionAction :: Stm
optionAction = [C.cstm|futhark_context_config_set_debugging(cfg, 1);|]
      },
    Option
      { optionLongName :: String
optionLongName = String
"log",
        optionShortName :: Maybe Char
optionShortName = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'L',
        optionArgument :: OptionArgument
optionArgument = OptionArgument
NoArgument,
        optionDescription :: String
optionDescription = String
"Print various low-overhead logging information while running.",
        optionAction :: Stm
optionAction = [C.cstm|futhark_context_config_set_logging(cfg, 1);|]
      },
    Option
      { optionLongName :: String
optionLongName = String
"profile",
        optionShortName :: Maybe Char
optionShortName = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'P',
        optionArgument :: OptionArgument
optionArgument = OptionArgument
NoArgument,
        optionDescription :: String
optionDescription = String
"Enable the collection of profiling information.",
        optionAction :: Stm
optionAction = [C.cstm|futhark_context_config_set_profiling(cfg, 1);|]
      },
    Option
      { optionLongName :: String
optionLongName = String
"help",
        optionShortName :: Maybe Char
optionShortName = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'h',
        optionArgument :: OptionArgument
optionArgument = OptionArgument
NoArgument,
        optionDescription :: String
optionDescription = String
"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
      { optionLongName :: String
optionLongName = String
"print-params",
        optionShortName :: Maybe Char
optionShortName = Maybe Char
forall a. Maybe a
Nothing,
        optionArgument :: OptionArgument
optionArgument = OptionArgument
NoArgument,
        optionDescription :: String
optionDescription = String
"Print all tuning parameters that can be set with --param or --tuning.",
        optionAction :: Stm
optionAction =
          [C.cstm|{
                int n = futhark_get_tuning_param_count();
                for (int i = 0; i < n; i++) {
                  printf("%s (%s)\n", futhark_get_tuning_param_name(i),
                                      futhark_get_tuning_param_class(i));
                }
                exit(0);
              }|]
      },
    Option
      { optionLongName :: String
optionLongName = String
"param",
        optionShortName :: Maybe Char
optionShortName = Maybe Char
forall a. Maybe a
Nothing,
        optionArgument :: OptionArgument
optionArgument = String -> OptionArgument
RequiredArgument String
"ASSIGNMENT",
        optionDescription :: String
optionDescription = String
"Set a tuning 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_tuning_param(cfg, name, value) != 0) {
                    futhark_panic(1, "Unknown parameter: %s\n", name);
                  }
                } else {
                  futhark_panic(1, "Invalid argument for --parameter option: %s\n", optarg);
                }}|]
      },
    Option
      { optionLongName :: String
optionLongName = String
"tuning",
        optionShortName :: Maybe Char
optionShortName = Maybe Char
forall a. Maybe a
Nothing,
        optionArgument :: OptionArgument
optionArgument = String -> OptionArgument
RequiredArgument String
"FILE",
        optionDescription :: String
optionDescription = String
"Read size=value assignments from the given file.",
        optionAction :: Stm
optionAction =
          [C.cstm|{
                char *ret = load_tuning_file(optarg, cfg);
                if (ret != NULL) {
                  futhark_panic(1, "When loading tuning file '%s': %s\n", optarg, ret);
                }}|]
      },
    Option
      { optionLongName :: String
optionLongName = String
"cache-file",
        optionShortName :: Maybe Char
optionShortName = Maybe Char
forall a. Maybe a
Nothing,
        optionArgument :: OptionArgument
optionArgument = String -> OptionArgument
RequiredArgument String
"FILE",
        optionDescription :: String
optionDescription = String
"Store program cache here.",
        optionAction :: Stm
optionAction =
          [C.cstm|futhark_context_config_set_cache_file(cfg, optarg);|]
      }
  ]

typeStructName :: T.Text -> T.Text
typeStructName :: CFuncName -> CFuncName
typeStructName CFuncName
tname = CFuncName
"type_" CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName -> CFuncName
zEncodeText CFuncName
tname

cType :: Manifest -> TypeName -> C.Type
cType :: Manifest -> CFuncName -> Type
cType Manifest
manifest CFuncName
tname =
  case CFuncName -> Map CFuncName Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup CFuncName
tname (Map CFuncName Type -> Maybe Type)
-> Map CFuncName Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Manifest -> Map CFuncName Type
manifestTypes Manifest
manifest of
    Just (TypeArray CFuncName
ctype CFuncName
_ Int
_ ArrayOps
_) -> [C.cty|typename $id:(T.unpack ctype)|]
    Just (TypeOpaque CFuncName
ctype OpaqueOps
_ Maybe OpaqueExtraOps
_ Doc
_) -> [C.cty|typename $id:(T.unpack ctype)|]
    Maybe Type
Nothing -> (Signedness -> PrimType -> Type) -> (Signedness, PrimType) -> Type
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Signedness -> PrimType -> Type
primAPIType ((Signedness, PrimType) -> Type) -> (Signedness, PrimType) -> Type
forall a b. (a -> b) -> a -> b
$ CFuncName -> (Signedness, PrimType)
scalarToPrim CFuncName
tname

data Kind
  = Primitive
  | -- TODO: Implement array functions for opaque arrays
    Array
  | Record
  | Sum
  | Opaque

cKind :: Kind -> C.Exp
cKind :: Kind -> Exp
cKind Kind
Primitive = [C.cexp|PRIMITIVE|]
cKind Kind
Array = [C.cexp|ARRAY|]
cKind Kind
Record = [C.cexp|RECORD|]
cKind Kind
Sum = [C.cexp|SUM|]
cKind Kind
Opaque = [C.cexp|OPAQUE|]

-- First component is forward declaration so we don't have to worry
-- about ordering.
typeBoilerplate :: Manifest -> (T.Text, Type) -> (C.Definition, C.Initializer, [C.Definition])
typeBoilerplate :: Manifest
-> (CFuncName, Type) -> (Definition, Initializer, [Definition])
typeBoilerplate Manifest
manifest (CFuncName
tname, TypeArray CFuncName
c_type_name CFuncName
et Int
rank ArrayOps
ops) =
  let element_type_name :: CFuncName
element_type_name = CFuncName -> CFuncName
typeStructName CFuncName
et
      element_c_type :: Type
element_c_type = Manifest -> CFuncName -> Type
cType Manifest
manifest CFuncName
et
      type_name :: CFuncName
type_name = CFuncName -> CFuncName
typeStructName CFuncName
tname
      array_name :: CFuncName
array_name = CFuncName
type_name CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_array"
      info_name :: CFuncName
info_name = CFuncName
et CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_info"
      array_new_wrap :: CFuncName
array_new_wrap = ArrayOps -> CFuncName
arrayNew ArrayOps
ops CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_wrap"
      array_set_wrap :: CFuncName
array_set_wrap = ArrayOps -> CFuncName
arraySet ArrayOps
ops CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_wrap"
      array_index_wrap :: CFuncName
array_index_wrap = ArrayOps -> CFuncName
arrayIndex ArrayOps
ops CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_wrap"
      array_shape_wrap :: CFuncName
array_shape_wrap = ArrayOps -> CFuncName
arrayShape ArrayOps
ops CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_wrap"
      array_values_wrap :: CFuncName
array_values_wrap = ArrayOps -> CFuncName
arrayValues ArrayOps
ops CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_wrap"
      array_free_wrap :: CFuncName
array_free_wrap = ArrayOps -> CFuncName
arrayFree ArrayOps
ops CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_wrap"
      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]]
      is_args :: [Exp]
is_args = [[C.cexp|is[$int:i]|] | Int
i <- [Int
0 .. Int
rank Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
   in ( [C.cedecl|const struct type $id:type_name;|],
        [C.cinit|&$id:type_name|],
        [C.cunit|
               int $id:array_new_wrap(struct futhark_context* ctx,
                                     void** outp,
                                     const void* p,
                                     const typename int64_t* shape) {
                typename $id:c_type_name *out = (typename $id:c_type_name*) outp;
                *out = $id:(arrayNew ops)(ctx, p, $args:shape_args);
                return 0;
              }
              int $id:array_set_wrap(struct futhark_context *ctx,
                                     const void *arr,
                                     void *val,
                                     const typename int64_t *is) {
                return $id:(arraySet ops)(ctx, (typename $id:c_type_name)arr,
                                          *($ty:element_c_type*)val, $args:is_args);
              }
              const typename int64_t* $id:array_shape_wrap(struct futhark_context *ctx,
                                                           const void *arr) {
                return $id:(arrayShape ops)(ctx, (typename $id:c_type_name)arr);
              }
              int $id:array_index_wrap(struct futhark_context *ctx,
                                       void *dest,
                                       const void *arr,
                                       const typename int64_t *is) {
                return $id:(arrayIndex ops)(ctx, dest, (typename $id:c_type_name)arr, $args:is_args);
              }
              int $id:array_values_wrap(struct futhark_context *ctx,
                                        const void *arr,
                                        void *data) {
                return $id:(arrayValues ops)(ctx, (typename $id:c_type_name)arr, data);
              }
              int $id:array_free_wrap(struct futhark_context *ctx, void *arr) {
                return $id:(arrayFree ops)(ctx, arr);
              }
              const struct array $id:array_name = {
                .rank = $int:rank,
                .element_type = &$id:element_type_name,
                .info = &$id:info_name,
                .name = $string:(T.unpack tname),
                .num_fields = 0,
                .fields = NULL,
                .new = $id:array_new_wrap,
                .set = $id:array_set_wrap,
                .shape = $id:array_shape_wrap,
                .index = $id:array_index_wrap,
                .values = $id:array_values_wrap,
                .free = $id:array_free_wrap,
                .zip = NULL,
              };
              const struct type $id:type_name = {
                .name = $string:(T.unpack tname),
                .restore = restore_array,
                .store = store_array,
                .free = free_array,
                .aux = &$id:array_name,
                .kind = $exp:(cKind Array),
                .info = &$id:array_name
              };|]
      )
typeBoilerplate Manifest
manifest (CFuncName
tname, TypeOpaque CFuncName
c_type_name OpaqueOps
ops Maybe OpaqueExtraOps
extra_ops Doc
_) =
  let type_name :: CFuncName
type_name = CFuncName -> CFuncName
typeStructName CFuncName
tname
      aux_name :: CFuncName
aux_name = CFuncName
type_name CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_aux"
      store_wrap :: CFuncName
store_wrap = OpaqueOps -> CFuncName
opaqueStore OpaqueOps
ops CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_wrap"
      restore_wrap :: CFuncName
restore_wrap = OpaqueOps -> CFuncName
opaqueRestore OpaqueOps
ops CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_wrap"
      free_wrap :: CFuncName
free_wrap = OpaqueOps -> CFuncName
opaqueFree OpaqueOps
ops CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_wrap"
      ([Definition]
transparent_edecls, Initializer
transparent_init, Kind
kind) = CFuncName
-> Maybe OpaqueExtraOps -> ([Definition], Initializer, Kind)
transparentDefs CFuncName
type_name Maybe OpaqueExtraOps
extra_ops
   in ( [C.cedecl|const struct type $id:type_name;|],
        [C.cinit|&$id:type_name|],
        [Definition]
transparent_edecls
          [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++ [C.cunit|
              int $id:store_wrap(struct futhark_context *ctx, const void *obj,
                                 void **p, size_t *n) {
                return $id:(opaqueStore ops)(ctx, obj, p, n);
              }
              void* $id:restore_wrap(struct futhark_context *ctx, void *p) {
                return $id:(opaqueRestore ops)(ctx, p);
              }
              int $id:free_wrap(struct futhark_context *ctx, void *obj) {
                return $id:(opaqueFree ops)(ctx, obj);
              }
              const struct opaque_aux $id:aux_name = {
                .store = $id:store_wrap,
                .restore = $id:restore_wrap,
                .free = $id:free_wrap
              };
              const struct type $id:type_name = {
                .name = $string:(T.unpack tname),
                .restore = restore_opaque,
                .store = store_opaque,
                .free = free_opaque,
                .aux = &$id:aux_name,
                .kind = $exp:(cKind kind),
                .info = $init:transparent_init
              };|]
      )
  where
    transparentDefs :: CFuncName
-> Maybe OpaqueExtraOps -> ([Definition], Initializer, Kind)
transparentDefs CFuncName
type_name (Just (OpaqueRecord (RecordOps [RecordField]
fields CFuncName
new))) =
      let new_wrap :: CFuncName
new_wrap = CFuncName
new CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_wrap"
          record_name :: CFuncName
record_name = CFuncName
type_name CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_record"
          fields_name :: CFuncName
fields_name = CFuncName
type_name CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_fields"
          onField :: Int -> RecordField -> (Initializer, BlockItem, Exp)
onField Int
i (RecordField CFuncName
name CFuncName
field_tname CFuncName
project) =
            let field_c_type :: Type
field_c_type = Manifest -> CFuncName -> Type
cType Manifest
manifest CFuncName
field_tname
                field_v :: String
field_v = String
"v" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Int
i :: Int)
             in ( [C.cinit|{.name = $string:(T.unpack name),
                            .type = &$id:(typeStructName field_tname),
                            .project = $id:(projectWrapName project)
                           }|],
                  [C.citem|const $ty:field_c_type $id:field_v =
                            *(const $ty:field_c_type*)fields[$int:i];|],
                  [C.cexp|$id:field_v|]
                )
          ([Initializer]
field_inits, [BlockItem]
get_fields, [Exp]
field_args) = [(Initializer, BlockItem, Exp)]
-> ([Initializer], [BlockItem], [Exp])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(Initializer, BlockItem, Exp)]
 -> ([Initializer], [BlockItem], [Exp]))
-> [(Initializer, BlockItem, Exp)]
-> ([Initializer], [BlockItem], [Exp])
forall a b. (a -> b) -> a -> b
$ (Int -> RecordField -> (Initializer, BlockItem, Exp))
-> [Int] -> [RecordField] -> [(Initializer, BlockItem, Exp)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> RecordField -> (Initializer, BlockItem, Exp)
onField [Int
0 ..] [RecordField]
fields
       in ( (RecordField -> [Definition]) -> [RecordField] -> [Definition]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CFuncName -> [Definition]
projectWrap (CFuncName -> [Definition])
-> (RecordField -> CFuncName) -> RecordField -> [Definition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordField -> CFuncName
recordFieldProject) [RecordField]
fields
              [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++ [C.cunit|
             const struct field $id:fields_name[] = {
               $inits:field_inits
             };
             int $id:new_wrap(struct futhark_context* ctx, void** outp, const void* fields[]) {
               typename $id:c_type_name *out = (typename $id:c_type_name*) outp;
               $items:get_fields
               return $id:new(ctx, out, $args:field_args);
             }
             const struct record $id:record_name = {
               .num_fields = $int:(length fields),
               .fields = $id:fields_name,
               .new = $id:new_wrap
             };|],
            [C.cinit|&$id:record_name|],
            Kind
Record
          )
    transparentDefs CFuncName
type_name (Just (OpaqueSum (SumOps [SumVariant]
variants CFuncName
variant))) =
      let sum_name :: CFuncName
sum_name = CFuncName
type_name CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_sum"
          variants_name :: CFuncName
variants_name = CFuncName
type_name CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_variants"
          onType :: Int -> CFuncName -> (BlockItem, BlockItem, Exp, Initializer)
onType Int
i CFuncName
type_tname =
            let type_c_type :: Type
type_c_type = Manifest -> CFuncName -> Type
cType Manifest
manifest CFuncName
type_tname
                type_v :: String
type_v = String
"v" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Int
i :: Int)
             in ( [C.citem|const $ty:type_c_type $id:type_v =
                            *(const $ty:type_c_type*)types[$int:i];|],
                  [C.citem|$ty:type_c_type *$id:type_v =
                            ($ty:type_c_type*)outs[$int:i];|],
                  [C.cexp|$id:type_v|],
                  [C.cinit|&$id:(typeStructName type_tname)|]
                )
          onVariant :: SumVariant -> (Initializer, [Definition])
onVariant (SumVariant CFuncName
name [CFuncName]
variant_tnames CFuncName
new CFuncName
destruct) =
            let new_wrap :: CFuncName
new_wrap = CFuncName
new CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_wrap"
                destruct_wrap :: CFuncName
destruct_wrap = CFuncName
destruct CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_wrap"
                types_name :: CFuncName
types_name = CFuncName
type_name CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_" CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
name CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_fields"
                ([BlockItem]
get_types, [BlockItem]
get_outs, [Exp]
type_args, [Initializer]
type_struct_names) = [(BlockItem, BlockItem, Exp, Initializer)]
-> ([BlockItem], [BlockItem], [Exp], [Initializer])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([(BlockItem, BlockItem, Exp, Initializer)]
 -> ([BlockItem], [BlockItem], [Exp], [Initializer]))
-> [(BlockItem, BlockItem, Exp, Initializer)]
-> ([BlockItem], [BlockItem], [Exp], [Initializer])
forall a b. (a -> b) -> a -> b
$ (Int -> CFuncName -> (BlockItem, BlockItem, Exp, Initializer))
-> [Int]
-> [CFuncName]
-> [(BlockItem, BlockItem, Exp, Initializer)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> CFuncName -> (BlockItem, BlockItem, Exp, Initializer)
onType [Int
0 ..] [CFuncName]
variant_tnames
             in ( [C.cinit|{.name = $string:(T.unpack name),
                            .num_types = $int:(length variant_tnames),
                            .types = $id:types_name,
                            .new = $id:new_wrap,
                            .destruct = $id:destruct_wrap
                           }|],
                  [C.cunit|
                    const struct type *$id:types_name[] = {
                      $inits:type_struct_names
                    };
                    int $id:new_wrap(struct futhark_context* ctx, void** outp, const void* types[]) {
                      typename $id:c_type_name *out = (typename $id:c_type_name*) outp;
                      $items:get_types
                      return $id:new(ctx, out, $args:type_args);
                    }
                    int $id:destruct_wrap(struct futhark_context* ctx, const void* outs[], const void* inp) {
                      const typename $id:c_type_name in = (const typename $id:c_type_name) inp;
                      $items:get_outs
                      return $id:destruct(ctx, $args:type_args, in);
                    }|]
                )

          variant_wrap :: CFuncName
variant_wrap = CFuncName
variant CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_wrap"
          ([Initializer]
variant_inits, [[Definition]]
variant_wraps) = [(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
$ (SumVariant -> (Initializer, [Definition]))
-> [SumVariant] -> [(Initializer, [Definition])]
forall a b. (a -> b) -> [a] -> [b]
map SumVariant -> (Initializer, [Definition])
onVariant [SumVariant]
variants
       in ( ([Definition] -> [Definition] -> [Definition])
-> [[Definition]] -> [Definition]
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
(++) [[Definition]]
variant_wraps
              [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++ [C.cunit|
             int $id:variant_wrap(struct futhark_context *ctx, const void *v) {
               return $id:variant(ctx, v);
             }
             const struct variant $id:variants_name[] = {
               $inits:variant_inits
             };
             const struct sum $id:sum_name = {
               .num_variants = $int:(length variants),
               .variants = $id:variants_name,
               .variant = $id:variant_wrap
             };|],
            [C.cinit|&$id:sum_name|],
            Kind
Sum
          )
    transparentDefs CFuncName
type_name (Just (OpaqueArray OpaqueArrayOps
ops')) =
      CFuncName
-> Int
-> CFuncName
-> CFuncName
-> CFuncName
-> CFuncName
-> CFuncName
-> Maybe ([RecordField], CFuncName)
-> ([Definition], Initializer, Kind)
opaqueArrayDefs
        CFuncName
type_name
        (OpaqueArrayOps -> Int
opaqueArrayRank OpaqueArrayOps
ops')
        (OpaqueArrayOps -> CFuncName
opaqueArrayElemType OpaqueArrayOps
ops')
        (OpaqueArrayOps -> CFuncName
opaqueArrayNew OpaqueArrayOps
ops')
        (OpaqueArrayOps -> CFuncName
opaqueArraySet OpaqueArrayOps
ops')
        (OpaqueArrayOps -> CFuncName
opaqueArrayShape OpaqueArrayOps
ops')
        (OpaqueArrayOps -> CFuncName
opaqueArrayIndex OpaqueArrayOps
ops')
        Maybe ([RecordField], CFuncName)
forall a. Maybe a
Nothing
    transparentDefs CFuncName
type_name (Just (OpaqueRecordArray RecordArrayOps
ops')) =
      CFuncName
-> Int
-> CFuncName
-> CFuncName
-> CFuncName
-> CFuncName
-> CFuncName
-> Maybe ([RecordField], CFuncName)
-> ([Definition], Initializer, Kind)
opaqueArrayDefs
        CFuncName
type_name
        (RecordArrayOps -> Int
recordArrayRank RecordArrayOps
ops')
        (RecordArrayOps -> CFuncName
recordArrayElemType RecordArrayOps
ops')
        (RecordArrayOps -> CFuncName
recordArrayNew RecordArrayOps
ops')
        (RecordArrayOps -> CFuncName
recordArraySet RecordArrayOps
ops')
        (RecordArrayOps -> CFuncName
recordArrayShape RecordArrayOps
ops')
        (RecordArrayOps -> CFuncName
recordArrayIndex RecordArrayOps
ops')
        (Maybe ([RecordField], CFuncName)
 -> ([Definition], Initializer, Kind))
-> Maybe ([RecordField], CFuncName)
-> ([Definition], Initializer, Kind)
forall a b. (a -> b) -> a -> b
$ ([RecordField], CFuncName) -> Maybe ([RecordField], CFuncName)
forall a. a -> Maybe a
Just (RecordArrayOps -> [RecordField]
recordArrayFields RecordArrayOps
ops', RecordArrayOps -> CFuncName
recordArrayZip RecordArrayOps
ops')
    transparentDefs CFuncName
_ Maybe OpaqueExtraOps
_ = ([], [C.cinit|NULL|], Kind
Opaque)

    opaqueArrayDefs ::
      T.Text ->
      Int ->
      T.Text ->
      CFuncName ->
      CFuncName ->
      CFuncName ->
      CFuncName ->
      Maybe ([RecordField], CFuncName) ->
      ([C.Definition], C.Initializer, Kind)
    opaqueArrayDefs :: CFuncName
-> Int
-> CFuncName
-> CFuncName
-> CFuncName
-> CFuncName
-> CFuncName
-> Maybe ([RecordField], CFuncName)
-> ([Definition], Initializer, Kind)
opaqueArrayDefs CFuncName
type_name Int
rank CFuncName
et CFuncName
new CFuncName
set CFuncName
shape CFuncName
index Maybe ([RecordField], CFuncName)
maybe_fields =
      let array_name :: CFuncName
array_name = CFuncName
type_name CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_array"
          element_type_name :: CFuncName
element_type_name = CFuncName -> CFuncName
typeStructName CFuncName
et
          element_c_type :: Type
element_c_type = Manifest -> CFuncName -> Type
cType Manifest
manifest CFuncName
et
          new_wrap :: CFuncName
new_wrap = CFuncName
new CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_wrap"
          set_wrap :: CFuncName
set_wrap = CFuncName
set CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_wrap"
          index_wrap :: CFuncName
index_wrap = CFuncName
index CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_wrap"
          shape_wrap :: CFuncName
shape_wrap = CFuncName
shape CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_wrap"
          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]]
          is_args :: [Exp]
is_args = [[C.cexp|is[$int:i]|] | Int
i <- [Int
0 .. Int
rank Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
          ([Definition]
zip_defs, Exp
fields_init, Int
num_fields, Exp
zip_init) =
            case Maybe ([RecordField], CFuncName)
maybe_fields of
              Maybe ([RecordField], CFuncName)
Nothing ->
                ( [],
                  [C.cexp|NULL|],
                  Int
0 :: Int,
                  [C.cexp|NULL|]
                )
              Just ([RecordField]
fields, CFuncName
zip_f) ->
                let fields_name :: CFuncName
fields_name = CFuncName
type_name CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_zip_fields"
                    zip_wrap :: CFuncName
zip_wrap = CFuncName
zip_f CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_aux_wrap"
                    onField :: a -> RecordField -> (Initializer, BlockItem, Exp)
onField a
i RecordField
field =
                      let field_type :: Type
field_type = Manifest -> CFuncName -> Type
cType Manifest
manifest (CFuncName -> Type) -> CFuncName -> Type
forall a b. (a -> b) -> a -> b
$ RecordField -> CFuncName
recordFieldType RecordField
field
                          field_v :: CFuncName
field_v = CFuncName
"f" CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> a -> CFuncName
forall a. Pretty a => a -> CFuncName
prettyText a
i
                       in ( [C.cinit|{ .name = $string:(T.unpack (recordFieldName field)),
                                       .type = &$id:(typeStructName (recordFieldType field)),
                                       .project = $id:(projectWrapName (recordFieldProject field))
                                     }|],
                            [C.citem|const $ty:field_type $id:field_v =
                                         (const $ty:field_type)f[$int:i];|],
                            [C.cexp|$id:field_v|]
                          )
                    ([Initializer]
field_inits, [BlockItem]
get_fields, [Exp]
zip_args) = [(Initializer, BlockItem, Exp)]
-> ([Initializer], [BlockItem], [Exp])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(Initializer, BlockItem, Exp)]
 -> ([Initializer], [BlockItem], [Exp]))
-> [(Initializer, BlockItem, Exp)]
-> ([Initializer], [BlockItem], [Exp])
forall a b. (a -> b) -> a -> b
$ (Int -> RecordField -> (Initializer, BlockItem, Exp))
-> [Int] -> [RecordField] -> [(Initializer, BlockItem, Exp)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> RecordField -> (Initializer, BlockItem, Exp)
forall {a}.
(Show a, Integral a, Pretty a) =>
a -> RecordField -> (Initializer, BlockItem, Exp)
onField [Int
0 :: Int ..] [RecordField]
fields
                 in ( (RecordField -> [Definition]) -> [RecordField] -> [Definition]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CFuncName -> [Definition]
projectWrap (CFuncName -> [Definition])
-> (RecordField -> CFuncName) -> RecordField -> [Definition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordField -> CFuncName
recordFieldProject) [RecordField]
fields
                        [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++ [C.cunit|const struct field $id:fields_name[] = {
                                  $inits:field_inits
                                };|]
                        [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++ [C.cunit|int $id:zip_wrap(struct futhark_context *ctx,
                                                     void *outp,
                                                     const void *f[]) {
                                      typename $id:c_type_name *out = (typename $id:c_type_name*)outp;
                                      $items:get_fields
                                      return $id:zip_f(ctx, out, $args:zip_args);
                                    }|],
                      [C.cexp|$id:fields_name|],
                      [RecordField] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RecordField]
fields,
                      [C.cexp|$id:zip_wrap|]
                    )
       in ( [Definition]
zip_defs
              [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++ [C.cunit|
               int $id:new_wrap(struct futhark_context *ctx,
                                void **outp,
                                const void *p,
                                const typename int64_t *shape) {
                typename $id:c_type_name *out = (typename $id:c_type_name*) outp;
                $ty:element_c_type **ps = ($ty:element_c_type **) p;
                typename int64_t n_values = 1;
                for (int i = 0; i < $int:rank; ++i) {
                  n_values *= shape[i];
                }
                $ty:element_c_type *values = alloca(n_values * sizeof($ty:element_c_type));
                for (typename int64_t i = 0; i < n_values; ++i) {
                  values[i] = *ps[i];
                }
                return $id:new(ctx, out, values, $args:shape_args);
              }
              int $id:set_wrap(struct futhark_context *ctx,
                               const void *arr,
                               void *val,
                               const typename int64_t *is) {
                return $id:set(ctx, (typename $id:c_type_name)arr,
                               *($ty:element_c_type*)val, $args:is_args);
              }
              const typename int64_t* $id:shape_wrap(struct futhark_context *ctx,
                                                     const void *arr) {
                return $id:shape(ctx, (typename $id:c_type_name)arr);
              }
               int $id:index_wrap(struct futhark_context *ctx,
                                  void *dest,
                                  const void *arr,
                                  const typename int64_t *is) {
                 return $id:index(ctx, dest, (typename $id:c_type_name)arr, $args:is_args);
               }
               const struct array $id:array_name = {
                 .rank = $int:rank,
                 .element_type = &$id:element_type_name,
                 .info = NULL,
                 .name = $string:(T.unpack tname),
                 .num_fields = $int:num_fields,
                 .fields = $exp:fields_init,
                 .new = $id:new_wrap,
                 .set = $id:set_wrap,
                 .shape = $id:shape_wrap,
                 .index = $id:index_wrap,
                 .values = NULL,
                 .free = NULL,
                 .zip = $exp:zip_init,
                };|],
            [C.cinit|&$id:array_name|],
            Kind
Array
          )

projectWrapName :: CFuncName -> CFuncName
projectWrapName :: CFuncName -> CFuncName
projectWrapName CFuncName
project = CFuncName
project CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
"_wrap"

projectWrap :: CFuncName -> [C.Definition]
projectWrap :: CFuncName -> [Definition]
projectWrap CFuncName
project =
  [C.cunit|int $id:(projectWrapName project)(struct futhark_context *ctx, void *out, const void *obj) {
             return $id:project(ctx, out, obj);
           }|]

entryTypeBoilerplate :: Manifest -> ([C.Definition], [C.Initializer], [C.Definition])
entryTypeBoilerplate :: Manifest -> ([Definition], [Initializer], [Definition])
entryTypeBoilerplate Manifest
manifest =
  ([[Definition]] -> [Definition])
-> ([Definition], [Initializer], [[Definition]])
-> ([Definition], [Initializer], [Definition])
forall b c a.
(b -> c) -> ([Definition], a, b) -> ([Definition], a, c)
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 (([Definition], [Initializer], [[Definition]])
 -> ([Definition], [Initializer], [Definition]))
-> (Manifest -> ([Definition], [Initializer], [[Definition]]))
-> Manifest
-> ([Definition], [Initializer], [Definition])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Definition, Initializer, [Definition])]
-> ([Definition], [Initializer], [[Definition]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(Definition, Initializer, [Definition])]
 -> ([Definition], [Initializer], [[Definition]]))
-> (Manifest -> [(Definition, Initializer, [Definition])])
-> Manifest
-> ([Definition], [Initializer], [[Definition]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CFuncName, Type) -> (Definition, Initializer, [Definition]))
-> [(CFuncName, Type)] -> [(Definition, Initializer, [Definition])]
forall a b. (a -> b) -> [a] -> [b]
map (Manifest
-> (CFuncName, Type) -> (Definition, Initializer, [Definition])
typeBoilerplate Manifest
manifest) ([(CFuncName, Type)] -> [(Definition, Initializer, [Definition])])
-> (Manifest -> [(CFuncName, Type)])
-> Manifest
-> [(Definition, Initializer, [Definition])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map CFuncName Type -> [(CFuncName, Type)]
forall k a. Map k a -> [(k, a)]
M.toList (Map CFuncName Type -> [(CFuncName, Type)])
-> (Manifest -> Map CFuncName Type)
-> Manifest
-> [(CFuncName, Type)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Manifest -> Map CFuncName Type
manifestTypes (Manifest -> ([Definition], [Initializer], [Definition]))
-> Manifest -> ([Definition], [Initializer], [Definition])
forall a b. (a -> b) -> a -> b
$
    Manifest
manifest

oneEntryBoilerplate :: Manifest -> (T.Text, EntryPoint) -> ([C.Definition], C.Initializer)
oneEntryBoilerplate :: Manifest -> (CFuncName, EntryPoint) -> ([Definition], Initializer)
oneEntryBoilerplate Manifest
manifest (CFuncName
name, EntryPoint CFuncName
cfun [CFuncName]
tuning_params Output
output [Input]
inputs [CFuncName]
attrs Doc
_doc) =
  let call_f :: Name
call_f = Name
"call_" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> CFuncName -> Name
nameFromText CFuncName
name
      out_type :: CFuncName
out_type = Output -> CFuncName
outputType Output
output
      in_types :: [CFuncName]
in_types = (Input -> CFuncName) -> [Input] -> [CFuncName]
forall a b. (a -> b) -> [a] -> [b]
map Input -> CFuncName
inputType [Input]
inputs
      in_types_name :: Name
in_types_name = CFuncName -> Name
nameFromText CFuncName
name Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_in_types"
      in_consumed_name :: Name
in_consumed_name = CFuncName -> Name
nameFromText CFuncName
name Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_in_consumed"
      tuning_params_name :: Name
tuning_params_name = CFuncName -> Name
nameFromText CFuncName
name Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_tuning_params"
      attrs_name :: Name
attrs_name = CFuncName -> Name
nameFromText CFuncName
name Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_attrs"
      ([BlockItem]
in_items, [Exp]
in_args)
        | [CFuncName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CFuncName]
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 -> CFuncName -> (BlockItem, Exp))
-> [Int] -> [CFuncName] -> [(BlockItem, Exp)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> CFuncName -> (BlockItem, Exp)
loadIn [Int
0 ..] [CFuncName]
in_types
   in ( [C.cunit|
                const struct type* $id:in_types_name[] = {
                  $inits:(map typeStructInit in_types),
                  NULL
                };
                bool $id:in_consumed_name[] = {
                  $inits:(map inputUniqueInit inputs)
                };
                const char* $id:tuning_params_name[] = {
                  $inits:(map textInit tuning_params),
                  NULL
                };
                const char* $id:attrs_name[] = {
                  $inits:(map (textInit . prettyText) attrs),
                  NULL
                };
                int $id:call_f(struct futhark_context *ctx, void *out, void **ins) {
                  $items:in_items
                  return $id:cfun(ctx, out, $args:in_args);
                }
                |],
        [C.cinit|{
            .name = $string:(T.unpack name),
            .f = $id:call_f,
            .tuning_params = $id:tuning_params_name,
            .in_types = $id:in_types_name,
            .out_type = $init:(typeStructInit out_type),
            .in_consumed = $id:in_consumed_name,
            .out_fresh = $init:(outputUniqueInit output),
            .attrs = $id:attrs_name
            }|]
      )
  where
    typeStructInit :: CFuncName -> Initializer
typeStructInit CFuncName
tname = [C.cinit|&$id:(typeStructName tname)|]
    inputUniqueInit :: Input -> Initializer
inputUniqueInit = Bool -> Initializer
uniqueInit (Bool -> Initializer) -> (Input -> Bool) -> Input -> Initializer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> Bool
inputConsumed
    outputUniqueInit :: Output -> Initializer
outputUniqueInit = Bool -> Initializer
uniqueInit (Bool -> Initializer) -> (Output -> Bool) -> Output -> Initializer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Output -> Bool
outputFresh
    uniqueInit :: Bool -> Initializer
uniqueInit Bool
True = [C.cinit|true|]
    uniqueInit Bool
False = [C.cinit|false|]

    loadIn :: Int -> CFuncName -> (BlockItem, Exp)
loadIn Int
i CFuncName
tname =
      let v :: String
v = String
"in" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
i :: Int)
       in ( [C.citem|$ty:(cType manifest tname) $id:v = *($ty:(cType manifest tname)*)ins[$int:i];|],
            [C.cexp|$id:v|]
          )

    textInit :: CFuncName -> Initializer
textInit CFuncName
t = [C.cinit|$string:(T.unpack t)|]

entryBoilerplate :: Manifest -> ([C.Definition], [C.Initializer])
entryBoilerplate :: Manifest -> ([Definition], [Initializer])
entryBoilerplate Manifest
manifest =
  ([[Definition]] -> [Definition])
-> ([[Definition]], [Initializer]) -> ([Definition], [Initializer])
forall a b c. (a -> b) -> (a, c) -> (b, c)
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
$
      ((CFuncName, EntryPoint) -> ([Definition], Initializer))
-> [(CFuncName, EntryPoint)] -> [([Definition], Initializer)]
forall a b. (a -> b) -> [a] -> [b]
map (Manifest -> (CFuncName, EntryPoint) -> ([Definition], Initializer)
oneEntryBoilerplate Manifest
manifest) ([(CFuncName, EntryPoint)] -> [([Definition], Initializer)])
-> [(CFuncName, EntryPoint)] -> [([Definition], Initializer)]
forall a b. (a -> b) -> a -> b
$
        Map CFuncName EntryPoint -> [(CFuncName, EntryPoint)]
forall k a. Map k a -> [(k, a)]
M.toList (Map CFuncName EntryPoint -> [(CFuncName, EntryPoint)])
-> Map CFuncName EntryPoint -> [(CFuncName, EntryPoint)]
forall a b. (a -> b) -> a -> b
$
          Manifest -> Map CFuncName EntryPoint
manifestEntryPoints Manifest
manifest

mkBoilerplate ::
  Manifest ->
  ([C.Definition], [C.Initializer], [C.Initializer])
mkBoilerplate :: Manifest -> ([Definition], [Initializer], [Initializer])
mkBoilerplate Manifest
manifest =
  let ([Definition]
type_decls, [Initializer]
type_inits, [Definition]
type_defs) = Manifest -> ([Definition], [Initializer], [Definition])
entryTypeBoilerplate Manifest
manifest
      ([Definition]
entry_defs, [Initializer]
entry_inits) = Manifest -> ([Definition], [Initializer])
entryBoilerplate Manifest
manifest
      scalar_type_inits :: [Initializer]
scalar_type_inits = (CFuncName -> Initializer) -> [CFuncName] -> [Initializer]
forall a b. (a -> b) -> [a] -> [b]
map CFuncName -> Initializer
scalarTypeInit [CFuncName]
scalar_types
   in ([Definition]
type_decls [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++ [Definition]
type_defs [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++ [Definition]
entry_defs, [Initializer]
scalar_type_inits [Initializer] -> [Initializer] -> [Initializer]
forall a. [a] -> [a] -> [a]
++ [Initializer]
type_inits, [Initializer]
entry_inits)
  where
    scalarTypeInit :: CFuncName -> Initializer
scalarTypeInit CFuncName
tname = [C.cinit|&$id:(typeStructName tname)|]
    scalar_types :: [CFuncName]
scalar_types =
      [ CFuncName
"i8",
        CFuncName
"i16",
        CFuncName
"i32",
        CFuncName
"i64",
        CFuncName
"u8",
        CFuncName
"u16",
        CFuncName
"u32",
        CFuncName
"u64",
        CFuncName
"f16",
        CFuncName
"f32",
        CFuncName
"f64",
        CFuncName
"bool"
      ]

{-# NOINLINE serverDefs #-}

-- | Generate Futhark server executable code.
serverDefs :: [Option] -> Manifest -> T.Text
serverDefs :: [Option] -> Manifest -> CFuncName
serverDefs [Option]
options Manifest
manifest =
  let option_parser :: Func
option_parser =
        String -> [Option] -> Func
generateOptionParser String
"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) =
        Manifest -> ([Definition], [Initializer], [Initializer])
mkBoilerplate Manifest
manifest
   in [Definition] -> CFuncName
definitionsText
        [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:(T.unpack valuesH)
$esc:(T.unpack serverH)
$esc:(T.unpack tuningH)

$edecls:boilerplate_defs

const 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, cfg, ctx);
  }

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