{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TupleSections #-}
module Futhark.CodeGen.Backends.GenericC.Server
( serverDefs,
)
where
import Data.Bifunctor (first, second)
import qualified Data.Map as M
import qualified Data.Text as T
import Futhark.CodeGen.Backends.GenericC.Manifest
import Futhark.CodeGen.Backends.GenericC.Options
import Futhark.CodeGen.Backends.SimpleRep
import Futhark.CodeGen.RTS.C (serverH, tuningH, valuesH)
import Futhark.Util (zEncodeString)
import Futhark.Util.Pretty (prettyText)
import qualified Language.C.Quote.OpenCL as C
import qualified Language.C.Syntax as C
genericOptions :: [Option]
genericOptions :: [Option]
genericOptions =
[ Option :: String -> Maybe Char -> OptionArgument -> String -> Stm -> Option
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 :: String -> Maybe Char -> OptionArgument -> String -> Stm -> Option
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 :: String -> Maybe Char -> OptionArgument -> String -> Stm -> Option
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 :: String -> Maybe Char -> OptionArgument -> String -> Stm -> Option
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 :: String -> Maybe Char -> OptionArgument -> String -> Stm -> Option
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 size: %s\n", name);
}
} else {
futhark_panic(1, "Invalid argument for size option: %s\n", optarg);
}}|]
},
Option :: String -> Maybe Char -> OptionArgument -> String -> Stm -> Option
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, (int(*)(void*, const char*, size_t))
futhark_context_config_set_tuning_param);
if (ret != NULL) {
futhark_panic(1, "When loading tuning from '%s': %s\n", optarg, ret);
}}|]
}
]
typeStructName :: T.Text -> String
typeStructName :: Text -> String
typeStructName Text
tname = String
"type_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
zEncodeString (Text -> String
T.unpack Text
tname)
typeBoilerplate :: (T.Text, Type) -> (C.Initializer, [C.Definition])
typeBoilerplate :: (Text, Type) -> (Initializer, [Definition])
typeBoilerplate (Text
tname, TypeArray Text
_ Text
et Int
rank ArrayOps
ops) =
let type_name :: String
type_name = Text -> String
typeStructName Text
tname
aux_name :: String
aux_name = String
type_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_aux"
info_name :: String
info_name = Text -> String
T.unpack Text
et String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_info"
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]]
array_new_wrap :: Text
array_new_wrap = ArrayOps -> Text
arrayNew ArrayOps
ops Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_wrap"
in ( [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:(arrayNew ops)(ctx, p, $args:shape_args);
}
struct array_aux $id:aux_name = {
.name = $string:(T.unpack tname),
.rank = $int:rank,
.info = &$id:info_name,
.new = (typename array_new_fn)$id:array_new_wrap,
.free = (typename array_free_fn)$id:(arrayFree ops),
.shape = (typename array_shape_fn)$id:(arrayShape ops),
.values = (typename array_values_fn)$id:(arrayValues ops)
};
struct type $id:type_name = {
.name = $string:(T.unpack tname),
.restore = (typename restore_fn)restore_array,
.store = (typename store_fn)store_array,
.free = (typename free_fn)free_array,
.aux = &$id:aux_name
};|]
)
typeBoilerplate (Text
tname, TypeOpaque Text
_ OpaqueOps
ops) =
let type_name :: String
type_name = Text -> String
typeStructName Text
tname
aux_name :: String
aux_name = String
type_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_aux"
in ( [C.cinit|&$id:type_name|],
[C.cunit|
struct opaque_aux $id:aux_name = {
.store = (typename opaque_store_fn)$id:(opaqueStore ops),
.restore = (typename opaque_restore_fn)$id:(opaqueRestore ops),
.free = (typename opaque_free_fn)$id:(opaqueFree ops)
};
struct type $id:type_name = {
.name = $string:(T.unpack tname),
.restore = (typename restore_fn)restore_opaque,
.store = (typename store_fn)store_opaque,
.free = (typename free_fn)free_opaque,
.aux = &$id:aux_name
};|]
)
entryTypeBoilerplate :: Manifest -> ([C.Initializer], [C.Definition])
entryTypeBoilerplate :: Manifest -> ([Initializer], [Definition])
entryTypeBoilerplate =
([[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]))
-> (Manifest -> ([Initializer], [[Definition]]))
-> Manifest
-> ([Initializer], [Definition])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Initializer, [Definition])] -> ([Initializer], [[Definition]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Initializer, [Definition])] -> ([Initializer], [[Definition]]))
-> (Manifest -> [(Initializer, [Definition])])
-> Manifest
-> ([Initializer], [[Definition]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Type) -> (Initializer, [Definition]))
-> [(Text, Type)] -> [(Initializer, [Definition])]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Type) -> (Initializer, [Definition])
typeBoilerplate ([(Text, Type)] -> [(Initializer, [Definition])])
-> (Manifest -> [(Text, Type)])
-> Manifest
-> [(Initializer, [Definition])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text Type -> [(Text, Type)]
forall k a. Map k a -> [(k, a)]
M.toList (Map Text Type -> [(Text, Type)])
-> (Manifest -> Map Text Type) -> Manifest -> [(Text, Type)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Manifest -> Map Text Type
manifestTypes
oneEntryBoilerplate :: Manifest -> (T.Text, EntryPoint) -> ([C.Definition], C.Initializer)
oneEntryBoilerplate :: Manifest -> (Text, EntryPoint) -> ([Definition], Initializer)
oneEntryBoilerplate Manifest
manifest (Text
name, EntryPoint Text
cfun [Output]
outputs [Input]
inputs) =
let call_f :: String
call_f = String
"call_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
name
out_types :: [Text]
out_types = (Output -> Text) -> [Output] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Output -> Text
outputType [Output]
outputs
in_types :: [Text]
in_types = (Input -> Text) -> [Input] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Input -> Text
inputType [Input]
inputs
out_types_name :: String
out_types_name = Text -> String
T.unpack Text
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_out_types"
in_types_name :: String
in_types_name = Text -> String
T.unpack Text
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_in_types"
out_unique_name :: String
out_unique_name = Text -> String
T.unpack Text
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_out_unique"
in_unique_name :: String
in_unique_name = Text -> String
T.unpack Text
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_in_unique"
([BlockItem]
out_items, [Exp]
out_args)
| [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
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 -> Text -> (BlockItem, Exp))
-> [Int] -> [Text] -> [(BlockItem, Exp)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Text -> (BlockItem, Exp)
loadOut [Int
0 ..] [Text]
out_types
([BlockItem]
in_items, [Exp]
in_args)
| [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
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 -> Text -> (BlockItem, Exp))
-> [Int] -> [Text] -> [(BlockItem, Exp)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Text -> (BlockItem, Exp)
loadIn [Int
0 ..] [Text]
in_types
in ( [C.cunit|
struct type* $id:out_types_name[] = {
$inits:(map typeStructInit out_types),
NULL
};
bool $id:out_unique_name[] = {
$inits:(map outputUniqueInit outputs)
};
struct type* $id:in_types_name[] = {
$inits:(map typeStructInit in_types),
NULL
};
bool $id:in_unique_name[] = {
$inits:(map inputUniqueInit inputs)
};
int $id:call_f(struct futhark_context *ctx, void **outs, void **ins) {
$items:out_items
$items:in_items
return $id:cfun(ctx, $args:out_args, $args:in_args);
}
|],
[C.cinit|{
.name = $string:(T.unpack name),
.f = $id:call_f,
.in_types = $id:in_types_name,
.out_types = $id:out_types_name,
.in_unique = $id:in_unique_name,
.out_unique = $id:out_unique_name
}|]
)
where
typeStructInit :: Text -> Initializer
typeStructInit Text
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
inputUnique
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
outputUnique
uniqueInit :: Bool -> Initializer
uniqueInit Bool
True = [C.cinit|true|]
uniqueInit Bool
False = [C.cinit|false|]
cType :: Text -> Type
cType Text
tname =
case Text -> Map Text Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
tname (Map Text Type -> Maybe Type) -> Map Text Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Manifest -> Map Text Type
manifestTypes Manifest
manifest of
Just (TypeArray Text
ctype Text
_ Int
_ ArrayOps
_) -> [C.cty|typename $id:(T.unpack ctype)|]
Just (TypeOpaque Text
ctype OpaqueOps
_) -> [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
$ Text -> (Signedness, PrimType)
scalarToPrim Text
tname
loadOut :: Int -> Text -> (BlockItem, Exp)
loadOut Int
i Text
tname =
let v :: String
v = String
"out" 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 tname) *$id:v = outs[$int:i];|],
[C.cexp|$id:v|]
)
loadIn :: Int -> Text -> (BlockItem, Exp)
loadIn Int
i Text
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 tname) $id:v = *($ty:(cType tname)*)ins[$int:i];|],
[C.cexp|$id:v|]
)
entryBoilerplate :: Manifest -> ([C.Definition], [C.Initializer])
entryBoilerplate :: Manifest -> ([Definition], [Initializer])
entryBoilerplate Manifest
manifest =
([[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
$
((Text, EntryPoint) -> ([Definition], Initializer))
-> [(Text, EntryPoint)] -> [([Definition], Initializer)]
forall a b. (a -> b) -> [a] -> [b]
map (Manifest -> (Text, EntryPoint) -> ([Definition], Initializer)
oneEntryBoilerplate Manifest
manifest) ([(Text, EntryPoint)] -> [([Definition], Initializer)])
-> [(Text, EntryPoint)] -> [([Definition], Initializer)]
forall a b. (a -> b) -> a -> b
$
Map Text EntryPoint -> [(Text, EntryPoint)]
forall k a. Map k a -> [(k, a)]
M.toList (Map Text EntryPoint -> [(Text, EntryPoint)])
-> Map Text EntryPoint -> [(Text, EntryPoint)]
forall a b. (a -> b) -> a -> b
$ Manifest -> Map Text EntryPoint
manifestEntryPoints Manifest
manifest
mkBoilerplate ::
Manifest ->
([C.Definition], [C.Initializer], [C.Initializer])
mkBoilerplate :: Manifest -> ([Definition], [Initializer], [Initializer])
mkBoilerplate Manifest
manifest =
let ([Initializer]
type_inits, [Definition]
type_defs) = Manifest -> ([Initializer], [Definition])
entryTypeBoilerplate Manifest
manifest
([Definition]
entry_defs, [Initializer]
entry_inits) = Manifest -> ([Definition], [Initializer])
entryBoilerplate Manifest
manifest
scalar_type_inits :: [Initializer]
scalar_type_inits = (Text -> Initializer) -> [Text] -> [Initializer]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Initializer
scalarTypeInit [Text]
scalar_types
in ([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 :: Text -> Initializer
scalarTypeInit Text
tname = [C.cinit|&$id:(typeStructName tname)|]
scalar_types :: [Text]
scalar_types =
[ Text
"i8",
Text
"i16",
Text
"i32",
Text
"i64",
Text
"u8",
Text
"u16",
Text
"u32",
Text
"u64",
Text
"f16",
Text
"f32",
Text
"f64",
Text
"bool"
]
{-# NOINLINE serverDefs #-}
serverDefs :: [Option] -> Manifest -> T.Text
serverDefs :: [Option] -> Manifest -> Text
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] -> Text
forall a. Pretty a => a -> Text
prettyText
[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
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);
}
|]