    {-# 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 -> Stm
    sizeHeuristicsCode (SizeHeuristic SpaceId
    platform_name DeviceType
    device_type WhichSize
    which (TPrimExp PrimExp DeviceInfo
    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 :: DeviceType -> Exp
    clDeviceType DeviceType
    DeviceGPU = [C.cexp|CL_DEVICE_TYPE_GPU|]
        clDeviceType DeviceType
    DeviceCPU = [C.cexp|CL_DEVICE_TYPE_CPU|]

        which' :: Exp
    which' = case WhichSize
    which of
          WhichSize
    LockstepWidth -> [C.cexp|ctx->lockstep_width|]
          WhichSize
    NumBlocks -> [C.cexp|ctx->cfg->gpu.default_grid_size|]
          WhichSize
    BlockSize -> [C.cexp|ctx->cfg->gpu.default_block_size|]
          WhichSize
    TileSize -> [C.cexp|ctx->cfg->gpu.default_tile_size|]
          WhichSize
    RegTileSize -> [C.cexp|ctx->cfg->gpu.default_reg_tile_size|]
          WhichSize
    Threshold -> [C.cexp|ctx->cfg->gpu.default_threshold|]

        get_size :: [BlockItem]
    get_size =
          let (Exp
    e, Map SpaceId [BlockItem]
    m) = State (Map SpaceId [BlockItem]) Exp
    -> Map SpaceId [BlockItem] -> (Exp, Map SpaceId [BlockItem])
    forall s a. State s a -> s -> (a, s)
    runState ((DeviceInfo -> State (Map SpaceId [BlockItem]) Exp)
    -> PrimExp DeviceInfo -> State (Map SpaceId [BlockItem]) Exp
    forall (m :: * -> *) v.
    Monad m =>
    (v -> m Exp) -> PrimExp v -> m Exp
    GC.compilePrimExp DeviceInfo -> State (Map SpaceId [BlockItem]) Exp
    forall {m :: * -> *}.
    MonadState (Map SpaceId [BlockItem]) m =>
    DeviceInfo -> m Exp
    onLeaf PrimExp DeviceInfo
    what) Map SpaceId [BlockItem]
    forall a. Monoid a => a
    mempty
           in [[BlockItem]] -> [BlockItem]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat (Map SpaceId [BlockItem] -> [[BlockItem]]
    forall k a. Map k a -> [a]
    M.elems Map SpaceId [BlockItem]
    m) [BlockItem] -> [BlockItem] -> [BlockItem]
    forall a. [a] -> [a] -> [a]
    ++ [[C.citem|$exp:which' = $exp:e;|]]

        onLeaf :: DeviceInfo -> m Exp
    onLeaf (DeviceInfo SpaceId
    s) = do
          let s' :: SpaceId
    s' = SpaceId
    "CL_DEVICE_" SpaceId -> SpaceId -> SpaceId
    forall a. [a] -> [a] -> [a]
    ++ SpaceId
    s
              v :: SpaceId
    v = SpaceId
    s SpaceId -> SpaceId -> SpaceId
    forall a. [a] -> [a] -> [a]
    ++ SpaceId
    "_val"
          m <- m (Map SpaceId [BlockItem])
    forall s (m :: * -> *). MonadState s m => m s
    get
          case M.lookup s m of
            Maybe [BlockItem]
    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.
              (Map SpaceId [BlockItem] -> Map SpaceId [BlockItem]) -> m ()
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
    modify ((Map SpaceId [BlockItem] -> Map SpaceId [BlockItem]) -> m ())
    -> (Map SpaceId [BlockItem] -> Map SpaceId [BlockItem]) -> m ()
    forall a b. (a -> b) -> a -> b
    $
                SpaceId
    -> [BlockItem]
    -> Map SpaceId [BlockItem]
    -> Map SpaceId [BlockItem]
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    M.insert
                  SpaceId
    s'
                  [C.citems|size_t $id:v = 0;
                            clGetDeviceInfo(ctx->device, $id:s',
                                            sizeof($id:v), &$id:v,
                                            NULL);|]
            Just [BlockItem]
    _ -> () -> m ()
    forall a. a -> m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()

          pure [C.cexp|$id:v|]

    mkBoilerplate ::
      T.Text ->
      [(Name, KernelConstExp)] ->
      M.Map Name KernelSafety ->
      [PrimType] ->
      [FailureMsg] ->
      GC.CompilerM OpenCL () ()
    mkBoilerplate :: Text
    -> [(Name, KernelConstExp)]
    -> Map Name KernelSafety
    -> [PrimType]
    -> [FailureMsg]
    -> CompilerM OpenCL () ()
    mkBoilerplate Text
    opencl_program [(Name, KernelConstExp)]
    macros Map Name KernelSafety
    kernels [PrimType]
    types [FailureMsg]
    failures = do
      Text
    -> [(Name, KernelConstExp)]
    -> Text
    -> [Name]
    -> [PrimType]
    -> [FailureMsg]
    -> CompilerM OpenCL () ()
    generateGPUBoilerplate
        Text
    opencl_program
        [(Name, KernelConstExp)]
    macros
        Text
    backendsOpenclH
        (Map Name KernelSafety -> [Name]
    forall k a. Map k a -> [k]
    M.keys Map Name KernelSafety
    kernels)
        [PrimType]
    types
        [FailureMsg]
    failures

      Definition -> CompilerM OpenCL () ()
    forall op s. Definition -> CompilerM op s ()
    GC.earlyDecl
        [C.cedecl|void post_opencl_setup(struct futhark_context *ctx, struct opencl_device_option *option) {
                 $stms:(map sizeHeuristicsCode sizeHeuristicsTable)
                 }|]

      HeaderSection -> Definition -> CompilerM OpenCL () ()
    forall op s. HeaderSection -> Definition -> CompilerM op s ()
    GC.headerDecl HeaderSection
    GC.InitDecl [C.cedecl|void futhark_context_config_add_build_option(struct futhark_context_config *cfg, const char* opt);|]
      HeaderSection -> Definition -> CompilerM OpenCL () ()
    forall op s. HeaderSection -> Definition -> CompilerM op s ()
    GC.headerDecl HeaderSection
    GC.InitDecl [C.cedecl|void futhark_context_config_set_device(struct futhark_context_config *cfg, const char* s);|]
      HeaderSection -> Definition -> CompilerM OpenCL () ()
    forall op s. HeaderSection -> Definition -> CompilerM op s ()
    GC.headerDecl HeaderSection
    GC.InitDecl [C.cedecl|void futhark_context_config_set_platform(struct futhark_context_config *cfg, const char* s);|]
      HeaderSection -> Definition -> CompilerM OpenCL () ()
    forall op s. HeaderSection -> Definition -> CompilerM op s ()
    GC.headerDecl HeaderSection
    GC.InitDecl [C.cedecl|void futhark_context_config_select_device_interactively(struct futhark_context_config *cfg);|]
      HeaderSection -> Definition -> CompilerM OpenCL () ()
    forall op s. HeaderSection -> Definition -> CompilerM op s ()
    GC.headerDecl HeaderSection
    GC.InitDecl [C.cedecl|void futhark_context_config_list_devices(struct futhark_context_config *cfg);|]
      HeaderSection -> Definition -> CompilerM OpenCL () ()
    forall op s. HeaderSection -> Definition -> CompilerM op s ()
    GC.headerDecl HeaderSection
    GC.InitDecl [C.cedecl|const char* futhark_context_config_get_program(struct futhark_context_config *cfg);|]
      HeaderSection -> Definition -> CompilerM OpenCL () ()
    forall op s. HeaderSection -> Definition -> CompilerM op s ()
    GC.headerDecl HeaderSection
    GC.InitDecl [C.cedecl|void futhark_context_config_set_program(struct futhark_context_config *cfg, const char* s);|]
      HeaderSection -> Definition -> CompilerM OpenCL () ()
    forall op s. HeaderSection -> Definition -> CompilerM op s ()
    GC.headerDecl HeaderSection
    GC.InitDecl [C.cedecl|void futhark_context_config_dump_binary_to(struct futhark_context_config *cfg, const char* s);|]
      HeaderSection -> Definition -> CompilerM OpenCL () ()
    forall op s. HeaderSection -> Definition -> CompilerM op s ()
    GC.headerDecl HeaderSection
    GC.InitDecl [C.cedecl|void futhark_context_config_load_binary_from(struct futhark_context_config *cfg, const char* s);|]
      HeaderSection -> Definition -> CompilerM OpenCL () ()
    forall op s. HeaderSection -> Definition -> CompilerM op s ()
    GC.headerDecl HeaderSection
    GC.InitDecl [C.cedecl|void futhark_context_config_set_command_queue(struct futhark_context_config *cfg, typename cl_command_queue);|]
      HeaderSection -> Definition -> CompilerM OpenCL () ()
    forall op s. HeaderSection -> Definition -> CompilerM op s ()
    GC.headerDecl HeaderSection
    GC.MiscDecl [C.cedecl|typename cl_command_queue futhark_context_get_command_queue(struct futhark_context* ctx);|]

    cliOptions :: [Option]
    cliOptions :: [Option]
    cliOptions =
      [Option]
    gpuOptions
        [Option] -> [Option] -> [Option]
    forall a. [a] -> [a] -> [a]
    ++ [ Option
               { optionLongName :: SpaceId
    optionLongName = SpaceId
    "platform",
                 optionShortName :: Maybe Char
    optionShortName = Char -> Maybe Char
    forall a. a -> Maybe a
    Just Char
    'p',
                 optionArgument :: OptionArgument
    optionArgument = SpaceId -> OptionArgument
    RequiredArgument SpaceId
    "NAME",
                 optionDescription :: SpaceId
    optionDescription = SpaceId
    "Use the first OpenCL platform whose name contains the given string.",
                 optionAction :: Stm
    optionAction = [C.cstm|futhark_context_config_set_platform(cfg, optarg);|]
               },
             Option
               { optionLongName :: SpaceId
    optionLongName = SpaceId
    "dump-opencl",
                 optionShortName :: Maybe Char
    optionShortName = Maybe Char
    forall a. Maybe a
    Nothing,
                 optionArgument :: OptionArgument
    optionArgument = SpaceId -> OptionArgument
    RequiredArgument SpaceId
    "FILE",
                 optionDescription :: SpaceId
    optionDescription = SpaceId
    "Dump the embedded OpenCL program to the indicated file.",
                 optionAction :: Stm
    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 :: SpaceId
    optionLongName = SpaceId
    "load-opencl",
                 optionShortName :: Maybe Char
    optionShortName = Maybe Char
    forall a. Maybe a
    Nothing,
                 optionArgument :: OptionArgument
    optionArgument = SpaceId -> OptionArgument
    RequiredArgument SpaceId
    "FILE",
                 optionDescription :: SpaceId
    optionDescription = SpaceId
    "Instead of using the embedded OpenCL program, load it from the indicated file.",
                 optionAction :: Stm
    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 :: SpaceId
    optionLongName = SpaceId
    "dump-opencl-binary",
                 optionShortName :: Maybe Char
    optionShortName = Maybe Char
    forall a. Maybe a
    Nothing,
                 optionArgument :: OptionArgument
    optionArgument = SpaceId -> OptionArgument
    RequiredArgument SpaceId
    "FILE",
                 optionDescription :: SpaceId
    optionDescription = SpaceId
    "Dump the compiled version of the embedded OpenCL program to the indicated file.",
                 optionAction :: Stm
    optionAction =
                   [C.cstm|{futhark_context_config_dump_binary_to(cfg, optarg);
                                         entry_point = NULL;}|]
               },
             Option
               { optionLongName :: SpaceId
    optionLongName = SpaceId
    "load-opencl-binary",
                 optionShortName :: Maybe Char
    optionShortName = Maybe Char
    forall a. Maybe a
    Nothing,
                 optionArgument :: OptionArgument
    optionArgument = SpaceId -> OptionArgument
    RequiredArgument SpaceId
    "FILE",
                 optionDescription :: SpaceId
    optionDescription = SpaceId
    "Load an OpenCL binary from the indicated file.",
                 optionAction :: Stm
    optionAction = [C.cstm|futhark_context_config_load_binary_from(cfg, optarg);|]
               },
             Option
               { optionLongName :: SpaceId
    optionLongName = SpaceId
    "build-option",
                 optionShortName :: Maybe Char
    optionShortName = Maybe Char
    forall a. Maybe a
    Nothing,
                 optionArgument :: OptionArgument
    optionArgument = SpaceId -> OptionArgument
    RequiredArgument SpaceId
    "OPT",
                 optionDescription :: SpaceId
    optionDescription = SpaceId
    "Add an additional build option to the string passed to clBuildProgram().",
                 optionAction :: Stm
    optionAction = [C.cstm|futhark_context_config_add_build_option(cfg, optarg);|]
               },
             Option
               { optionLongName :: SpaceId
    optionLongName = SpaceId
    "list-devices",
                 optionShortName :: Maybe Char
    optionShortName = Maybe Char
    forall a. Maybe a
    Nothing,
                 optionArgument :: OptionArgument
    optionArgument = OptionArgument
    NoArgument,
                 optionDescription :: SpaceId
    optionDescription = SpaceId
    "List all OpenCL devices and platforms available on the system.",
                 optionAction :: Stm
    optionAction =
                   [C.cstm|{futhark_context_config_list_devices(cfg);
                            entry_point = NULL;}|]
               }
           ]

    openclMemoryType :: GC.MemoryType OpenCL ()
    openclMemoryType :: MemoryType OpenCL ()
    openclMemoryType SpaceId
    "device" = Type -> CompilerM OpenCL () Type
    forall a. a -> CompilerM OpenCL () a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure [C.cty|typename cl_mem|]
    openclMemoryType SpaceId
    space = MemoryType OpenCL ()
    forall a. HasCallStack => SpaceId -> a
    error MemoryType OpenCL () -> MemoryType OpenCL ()
    forall a b. (a -> b) -> a -> b
    $ SpaceId
    "GPU backend does not support '" SpaceId -> SpaceId -> SpaceId
    forall a. [a] -> [a] -> [a]
    ++ SpaceId
    space SpaceId -> SpaceId -> SpaceId
    forall a. [a] -> [a] -> [a]
    ++ SpaceId
    "' memory space."

    -- | Compile the program to C with calls to OpenCL.
    compileProg :: (MonadFreshNames m) => T.Text -> Prog GPUMem -> m (ImpGen.Warnings, GC.CParts)
    compileProg :: forall (m :: * -> *).
    MonadFreshNames m =>
    Text -> Prog GPUMem -> m (Warnings, CParts)
    compileProg Text
    version Prog GPUMem
    prog = do
      ( ws,
        Program opencl_code opencl_prelude macros kernels types params failures prog'
        ) <-
        Prog GPUMem -> m (Warnings, Program)
    forall (m :: * -> *).
    MonadFreshNames m =>
    Prog GPUMem -> m (Warnings, Program)
    ImpGen.compileProg Prog GPUMem
    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 :: Operations OpenCL ()
    operations =
          Operations OpenCL ()
    gpuOperations
            { GC.opsMemoryType = openclMemoryType
            }
        opencl_includes :: Text
    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
           |]