{-# LANGUAGE QuasiQuotes #-} -- | Code generation for C with OpenCL. module Futhark.CodeGen.Backends.COpenCL ( compileProg, GC.CParts (..), GC.asLibrary, GC.asExecutable, GC.asServer, ) where import Control.Monad.State import Data.Map qualified as M import Data.Text qualified as T import Futhark.CodeGen.Backends.GPU import Futhark.CodeGen.Backends.GenericC qualified as GC import Futhark.CodeGen.Backends.GenericC.Options import Futhark.CodeGen.ImpCode.OpenCL import Futhark.CodeGen.ImpGen.OpenCL qualified as ImpGen import Futhark.CodeGen.OpenCL.Heuristics import Futhark.CodeGen.RTS.C (backendsOpenclH) import Futhark.IR.GPUMem hiding ( CmpSizeLe, GetSize, GetSizeMax, ) import Futhark.MonadFreshNames import Language.C.Quote.OpenCL qualified as C import Language.C.Syntax qualified as C import NeatInterpolation (untrimming) sizeHeuristicsCode :: SizeHeuristic -> C.Stm sizeHeuristicsCode (SizeHeuristic platform_name device_type which (TPrimExp what)) = [C.cstm| if ($exp:which' == 0 && strstr(option->platform_name, $string:platform_name) != NULL && (option->device_type & $exp:(clDeviceType device_type)) == $exp:(clDeviceType device_type)) { $items:get_size }|] where clDeviceType DeviceGPU = [C.cexp|CL_DEVICE_TYPE_GPU|] clDeviceType DeviceCPU = [C.cexp|CL_DEVICE_TYPE_CPU|] which' = case which of LockstepWidth -> [C.cexp|ctx->lockstep_width|] NumBlocks -> [C.cexp|ctx->cfg->default_num_groups|] BlockSize -> [C.cexp|ctx->cfg->default_group_size|] TileSize -> [C.cexp|ctx->cfg->default_tile_size|] RegTileSize -> [C.cexp|ctx->cfg->default_reg_tile_size|] Threshold -> [C.cexp|ctx->cfg->default_threshold|] get_size = let (e, m) = runState (GC.compilePrimExp onLeaf what) mempty in concat (M.elems m) ++ [[C.citem|$exp:which' = $exp:e;|]] onLeaf (DeviceInfo s) = do let s' = "CL_DEVICE_" ++ s v = s ++ "_val" m <- get case M.lookup s m of Nothing -> -- XXX: Cheating with the type here; works for the infos we -- currently use because we zero-initialise and assume a -- little-endian platform, but should be made more -- size-aware in the future. modify $ M.insert s' [C.citems|size_t $id:v = 0; clGetDeviceInfo(ctx->device, $id:s', sizeof($id:v), &$id:v, NULL);|] Just _ -> pure () pure [C.cexp|$id:v|] mkBoilerplate :: T.Text -> [(Name, KernelConstExp)] -> M.Map Name KernelSafety -> [PrimType] -> [FailureMsg] -> GC.CompilerM OpenCL () () mkBoilerplate opencl_program macros kernels types failures = do generateGPUBoilerplate opencl_program macros backendsOpenclH (M.keys kernels) types failures GC.earlyDecl [C.cedecl|void post_opencl_setup(struct futhark_context *ctx, struct opencl_device_option *option) { $stms:(map sizeHeuristicsCode sizeHeuristicsTable) }|] GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_add_build_option(struct futhark_context_config *cfg, const char* opt);|] GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_device(struct futhark_context_config *cfg, const char* s);|] GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_platform(struct futhark_context_config *cfg, const char* s);|] GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_select_device_interactively(struct futhark_context_config *cfg);|] GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_list_devices(struct futhark_context_config *cfg);|] GC.headerDecl GC.InitDecl [C.cedecl|const char* futhark_context_config_get_program(struct futhark_context_config *cfg);|] GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_program(struct futhark_context_config *cfg, const char* s);|] GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_dump_binary_to(struct futhark_context_config *cfg, const char* s);|] GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_load_binary_from(struct futhark_context_config *cfg, const char* s);|] GC.headerDecl GC.InitDecl [C.cedecl|void futhark_context_config_set_command_queue(struct futhark_context_config *cfg, typename cl_command_queue);|] GC.headerDecl GC.MiscDecl [C.cedecl|typename cl_command_queue futhark_context_get_command_queue(struct futhark_context* ctx);|] cliOptions :: [Option] cliOptions = gpuOptions ++ [ Option { optionLongName = "platform", optionShortName = Just 'p', optionArgument = RequiredArgument "NAME", optionDescription = "Use the first OpenCL platform whose name contains the given string.", optionAction = [C.cstm|futhark_context_config_set_platform(cfg, optarg);|] }, Option { optionLongName = "dump-opencl", optionShortName = Nothing, optionArgument = RequiredArgument "FILE", optionDescription = "Dump the embedded OpenCL program to the indicated file.", optionAction = [C.cstm|{const char* prog = futhark_context_config_get_program(cfg); if (dump_file(optarg, prog, strlen(prog)) != 0) { fprintf(stderr, "%s: %s\n", optarg, strerror(errno)); exit(1); } exit(0);}|] }, Option { optionLongName = "load-opencl", optionShortName = Nothing, optionArgument = RequiredArgument "FILE", optionDescription = "Instead of using the embedded OpenCL program, load it from the indicated file.", optionAction = [C.cstm|{ size_t n; const char *s = slurp_file(optarg, &n); if (s == NULL) { fprintf(stderr, "%s: %s\n", optarg, strerror(errno)); exit(1); } futhark_context_config_set_program(cfg, s); }|] }, Option { optionLongName = "dump-opencl-binary", optionShortName = Nothing, optionArgument = RequiredArgument "FILE", optionDescription = "Dump the compiled version of the embedded OpenCL program to the indicated file.", optionAction = [C.cstm|{futhark_context_config_dump_binary_to(cfg, optarg); entry_point = NULL;}|] }, Option { optionLongName = "load-opencl-binary", optionShortName = Nothing, optionArgument = RequiredArgument "FILE", optionDescription = "Load an OpenCL binary from the indicated file.", optionAction = [C.cstm|futhark_context_config_load_binary_from(cfg, optarg);|] }, Option { optionLongName = "build-option", optionShortName = Nothing, optionArgument = RequiredArgument "OPT", optionDescription = "Add an additional build option to the string passed to clBuildProgram().", optionAction = [C.cstm|futhark_context_config_add_build_option(cfg, optarg);|] }, Option { optionLongName = "list-devices", optionShortName = Nothing, optionArgument = NoArgument, optionDescription = "List all OpenCL devices and platforms available on the system.", optionAction = [C.cstm|{futhark_context_config_list_devices(cfg); entry_point = NULL;}|] } ] openclMemoryType :: GC.MemoryType OpenCL () openclMemoryType "device" = pure [C.cty|typename cl_mem|] openclMemoryType space = error $ "GPU backend does not support '" ++ space ++ "' memory space." -- | Compile the program to C with calls to OpenCL. compileProg :: (MonadFreshNames m) => T.Text -> Prog GPUMem -> m (ImpGen.Warnings, GC.CParts) compileProg version prog = do ( ws, Program opencl_code opencl_prelude macros kernels types params failures prog' ) <- ImpGen.compileProg prog (ws,) <$> GC.compileProg "opencl" version params operations (mkBoilerplate (opencl_prelude <> opencl_code) macros kernels types failures) opencl_includes (Space "device", [Space "device", DefaultSpace]) cliOptions prog' where operations :: GC.Operations OpenCL () operations = gpuOperations { GC.opsMemoryType = openclMemoryType } opencl_includes = [untrimming| #define CL_TARGET_OPENCL_VERSION 120 #define CL_USE_DEPRECATED_OPENCL_1_2_APIS #ifdef __APPLE__ #define CL_SILENCE_DEPRECATION #include #else #include #endif |]