content: {-# 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->gpu.default_grid_size|]
        BlockSize -> [C.cexp|ctx->cfg->gpu.default_block_size|]
        TileSize -> [C.cexp|ctx->cfg->gpu.default_tile_size|]
        RegTileSize -> [C.cexp|ctx->cfg->gpu.default_reg_tile_size|]
        Threshold -> [C.cexp|ctx->cfg->gpu.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 <OpenCL/cl.h>
         #else
         #include <CL/cl.h>
         #endif
         |]
  