    {-# LANGUAGE QuasiQuotes #-}

    -- | C code generation for whole programs, built on
    -- "Futhark.CodeGen.Backends.GenericC.Monad".  Most of this module is
    -- concerned with constructing the C API.
    module Futhark.CodeGen.Backends.GenericC
      ( compileProg,
        compileProg',
        defaultOperations,
        ParamMap,
        CParts (..),
        asLibrary,
        asExecutable,
        asServer,
        module Futhark.CodeGen.Backends.GenericC.Monad,
        module Futhark.CodeGen.Backends.GenericC.Code,
      )
    where

    import Control.Monad
    import Control.Monad.Reader
    import Control.Monad.State
    import Data.Bifunctor (second)
    import Data.DList qualified as DL
    import Data.List qualified as L
    import Data.Loc
    import Data.Map.Strict qualified as M
    import Data.Maybe
    import Data.Set qualified as S
    import Data.Text qualified as T
    import Futhark.CodeGen.Backends.GenericC.CLI (cliDefs)
    import Futhark.CodeGen.Backends.GenericC.Code
    import Futhark.CodeGen.Backends.GenericC.EntryPoints
    import Futhark.CodeGen.Backends.GenericC.Fun
    import Futhark.CodeGen.Backends.GenericC.Monad
    import Futhark.CodeGen.Backends.GenericC.Options
    import Futhark.CodeGen.Backends.GenericC.Pretty
    import Futhark.CodeGen.Backends.GenericC.Server (serverDefs)
    import Futhark.CodeGen.Backends.GenericC.Types
    import Futhark.CodeGen.ImpCode
    import Futhark.CodeGen.RTS.C (cacheH, contextH, contextPrototypesH, copyH, errorsH, eventListH, freeListH, halfH, lockH, timingH, utilH)
    import Futhark.IR.GPU.Sizes
    import Futhark.Manifest qualified as Manifest
    import Futhark.MonadFreshNames
    import Futhark.Util (zEncodeText)
    import Language.C.Quote.OpenCL qualified as C
    import Language.C.Syntax qualified as C
    import NeatInterpolation (untrimming)

    defCall :: CallCompiler op s
    defCall :: forall op s. CallCompiler op s
    defCall [VName]
    dests Name
    fname [Exp]
    args = do
      let out_args :: [Exp]
    out_args = [[C.cexp|&$id:d|] | VName
    d <- [VName]
    dests]
          args' :: [Exp]
    args' = [C.cexp|ctx|] Exp -> [Exp] -> [Exp]
    forall a. a -> [a] -> [a]
    : [Exp]
    out_args [Exp] -> [Exp] -> [Exp]
    forall a. [a] -> [a] -> [a]
    ++ [Exp]
    args
      BlockItem -> CompilerM op s ()
    forall op s. BlockItem -> CompilerM op s ()
    item [C.citem|if ($id:(funName fname)($args:args') != 0) { err = 1; goto cleanup; }|]

    defError :: ErrorCompiler op s
    defError :: forall op s. ErrorCompiler op s
    defError ErrorMsg Exp
    msg FilePath
    stacktrace = do
      (formatstr, formatargs) <- ErrorMsg Exp -> CompilerM op s (FilePath, [Exp])
    forall op s. ErrorMsg Exp -> CompilerM op s (FilePath, [Exp])
    errorMsgString ErrorMsg Exp
    msg
      let formatstr' = FilePath
    "Error: " FilePath -> FilePath -> FilePath
    forall a. Semigroup a => a -> a -> a
    <> FilePath
    formatstr FilePath -> FilePath -> FilePath
    forall a. Semigroup a => a -> a -> a
    <> FilePath
    "\n\nBacktrace:\n%s"
      items
        [C.citems|set_error(ctx, msgprintf($string:formatstr', $args:formatargs, $string:stacktrace));
                  err = FUTHARK_PROGRAM_ERROR;
                  goto cleanup;|]

    lmadcopyCPU :: DoCopy op s
    lmadcopyCPU :: forall op s. DoCopy op s
    lmadcopyCPU CopyBarrier
    _ PrimType
    t [Count Elements Exp]
    shape Exp
    dst (Count Elements Exp
    dstoffset, [Count Elements Exp]
    dststride) Exp
    src (Count Elements Exp
    srcoffset, [Count Elements Exp]
    srcstride) = do
      let fname :: String
          (FilePath
    fname, Type
    ty) =
            case PrimType -> Int
    forall a. Num a => PrimType -> a
    primByteSize PrimType
    t :: Int of
              Int
    1 -> (FilePath
    "lmad_copy_1b", [C.cty|typename uint8_t|])
              Int
    2 -> (FilePath
    "lmad_copy_2b", [C.cty|typename uint16_t|])
              Int
    4 -> (FilePath
    "lmad_copy_4b", [C.cty|typename uint32_t|])
              Int
    8 -> (FilePath
    "lmad_copy_8b", [C.cty|typename uint64_t|])
              Int
    k -> FilePath -> (FilePath, Type)
    forall a. HasCallStack => FilePath -> a
    error (FilePath -> (FilePath, Type)) -> FilePath -> (FilePath, Type)
    forall a b. (a -> b) -> a -> b
    $ FilePath
    "lmadcopyCPU: " FilePath -> FilePath -> FilePath
    forall a. Semigroup a => a -> a -> a
    <> Int -> FilePath
    forall a. Show a => a -> FilePath
    show Int
    k
          r :: Int
    r = [Count Elements Exp] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Count Elements Exp]
    shape
          dststride_inits :: [Initializer]
    dststride_inits = [[C.cinit|$exp:e|] | Count Exp
    e <- [Count Elements Exp]
    dststride]
          srcstride_inits :: [Initializer]
    srcstride_inits = [[C.cinit|$exp:e|] | Count Exp
    e <- [Count Elements Exp]
    srcstride]
          shape_inits :: [Initializer]
    shape_inits = [[C.cinit|$exp:e|] | Count Exp
    e <- [Count Elements Exp]
    shape]
      Stm -> CompilerM op s ()
    forall op s. Stm -> CompilerM op s ()
    stm
        [C.cstm|
             $id:fname(ctx, $int:r,
                       ($ty:ty*) $exp:dst, $exp:(unCount dstoffset),
                       (typename int64_t[]){ $inits:dststride_inits },
                       ($ty:ty*) $exp:src, $exp:(unCount srcoffset),
                       (typename int64_t[]){ $inits:srcstride_inits },
                       (typename int64_t[]){ $inits:shape_inits });|]

    -- | A set of operations that fail for every operation involving
    -- non-default memory spaces.  Uses plain pointers and @malloc@ for
    -- memory management.
    defaultOperations :: Operations op s
    defaultOperations :: forall op s. Operations op s
    defaultOperations =
      Operations
        { opsWriteScalar :: WriteScalar op s
    opsWriteScalar = WriteScalar op s
    forall {p} {p} {p} {p} {p} {a}. p -> p -> p -> p -> p -> a
    defWriteScalar,
          opsReadScalar :: ReadScalar op s
    opsReadScalar = ReadScalar op s
    forall {p} {p} {p} {p} {a}. p -> p -> p -> p -> a
    defReadScalar,
          opsAllocate :: Allocate op s
    opsAllocate = Allocate op s
    forall {p} {p} {p} {a}. p -> p -> p -> a
    defAllocate,
          opsDeallocate :: Allocate op s
    opsDeallocate = Allocate op s
    forall {p} {p} {a}. p -> p -> a
    defDeallocate,
          opsCopy :: Copy op s
    opsCopy = Copy op s
    forall {p} {op} {s}.
    p
    -> Exp
    -> Exp
    -> Space
    -> Exp
    -> Exp
    -> Space
    -> Exp
    -> CompilerM op s ()
    defCopy,
          opsCopies :: Map (Space, Space) (DoCopy op s)
    opsCopies = (Space, Space) -> DoCopy op s -> Map (Space, Space) (DoCopy op s)
    forall k a. k -> a -> Map k a
    M.singleton (Space
    DefaultSpace, Space
    DefaultSpace) DoCopy op s
    forall op s. DoCopy op s
    lmadcopyCPU,
          opsMemoryType :: MemoryType op s
    opsMemoryType = MemoryType op s
    forall {p} {a}. p -> a
    defMemoryType,
          opsCompiler :: OpCompiler op s
    opsCompiler = OpCompiler op s
    forall {p} {a}. p -> a
    defCompiler,
          opsFatMemory :: Bool
    opsFatMemory = Bool
    True,
          opsError :: ErrorCompiler op s
    opsError = ErrorCompiler op s
    forall op s. ErrorCompiler op s
    defError,
          opsCall :: CallCompiler op s
    opsCall = CallCompiler op s
    forall op s. CallCompiler op s
    defCall,
          opsCritical :: ([BlockItem], [BlockItem])
    opsCritical = ([BlockItem], [BlockItem])
    forall a. Monoid a => a
    mempty
        }
      where
        defWriteScalar :: p -> p -> p -> p -> p -> a
    defWriteScalar p
    _ p
    _ p
    _ p
    _ p
    _ =
          FilePath -> a
    forall a. HasCallStack => FilePath -> a
    error FilePath
    "Cannot write to non-default memory space because I am dumb"
        defReadScalar :: p -> p -> p -> p -> a
    defReadScalar p
    _ p
    _ p
    _ p
    _ =
          FilePath -> a
    forall a. HasCallStack => FilePath -> a
    error FilePath
    "Cannot read from non-default memory space"
        defAllocate :: p -> p -> p -> a
    defAllocate p
    _ p
    _ p
    _ =
          FilePath -> a
    forall a. HasCallStack => FilePath -> a
    error FilePath
    "Cannot allocate in non-default memory space"
        defDeallocate :: p -> p -> a
    defDeallocate p
    _ p
    _ =
          FilePath -> a
    forall a. HasCallStack => FilePath -> a
    error FilePath
    "Cannot deallocate in non-default memory space"
        defCopy :: p
    -> Exp
    -> Exp
    -> Space
    -> Exp
    -> Exp
    -> Space
    -> Exp
    -> CompilerM op s ()
    defCopy p
    _ Exp
    destmem Exp
    destoffset Space
    DefaultSpace Exp
    srcmem Exp
    srcoffset Space
    DefaultSpace Exp
    size =
          Exp -> Exp -> Exp -> Exp -> Exp -> CompilerM op s ()
    forall op s. Exp -> Exp -> Exp -> Exp -> Exp -> CompilerM op s ()
    copyMemoryDefaultSpace Exp
    destmem Exp
    destoffset Exp
    srcmem Exp
    srcoffset Exp
    size
        defCopy p
    _ Exp
    _ Exp
    _ Space
    _ Exp
    _ Exp
    _ Space
    _ Exp
    _ =
          FilePath -> CompilerM op s ()
    forall a. HasCallStack => FilePath -> a
    error FilePath
    "Cannot copy to or from non-default memory space"
        defMemoryType :: p -> a
    defMemoryType p
    _ =
          FilePath -> a
    forall a. HasCallStack => FilePath -> a
    error FilePath
    "Has no type for non-default memory space"
        defCompiler :: p -> a
    defCompiler p
    _ =
          FilePath -> a
    forall a. HasCallStack => FilePath -> a
    error FilePath
    "The default compiler cannot compile extended operations"

    declsCode :: (HeaderSection -> Bool) -> CompilerState s -> T.Text
    declsCode :: forall s. (HeaderSection -> Bool) -> CompilerState s -> Text
    declsCode HeaderSection -> Bool
    p =
      [Definition] -> Text
    definitionsText
        ([Definition] -> Text)
    -> (CompilerState s -> [Definition]) -> CompilerState s -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((HeaderSection, DList Definition) -> [Definition])
    -> [(HeaderSection, DList Definition)] -> [Definition]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (DList Definition -> [Definition]
    forall a. DList a -> [a]
    DL.toList (DList Definition -> [Definition])
    -> ((HeaderSection, DList Definition) -> DList Definition)
    -> (HeaderSection, DList Definition)
    -> [Definition]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (HeaderSection, DList Definition) -> DList Definition
    forall a b. (a, b) -> b
    snd)
        ([(HeaderSection, DList Definition)] -> [Definition])
    -> (CompilerState s -> [(HeaderSection, DList Definition)])
    -> CompilerState s
    -> [Definition]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((HeaderSection, DList Definition) -> Bool)
    -> [(HeaderSection, DList Definition)]
    -> [(HeaderSection, DList Definition)]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (HeaderSection -> Bool
    p (HeaderSection -> Bool)
    -> ((HeaderSection, DList Definition) -> HeaderSection)
    -> (HeaderSection, DList Definition)
    -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (HeaderSection, DList Definition) -> HeaderSection
    forall a b. (a, b) -> a
    fst)
        ([(HeaderSection, DList Definition)]
     -> [(HeaderSection, DList Definition)])
    -> (CompilerState s -> [(HeaderSection, DList Definition)])
    -> CompilerState s
    -> [(HeaderSection, DList Definition)]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Map HeaderSection (DList Definition)
    -> [(HeaderSection, DList Definition)]
    forall k a. Map k a -> [(k, a)]
    M.toList
        (Map HeaderSection (DList Definition)
     -> [(HeaderSection, DList Definition)])
    -> (CompilerState s -> Map HeaderSection (DList Definition))
    -> CompilerState s
    -> [(HeaderSection, DList Definition)]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CompilerState s -> Map HeaderSection (DList Definition)
    forall s. CompilerState s -> Map HeaderSection (DList Definition)
    compHeaderDecls

    initDecls, arrayDecls, opaqueDecls, opaqueTypeDecls, entryDecls, miscDecls :: CompilerState s -> T.Text
    initDecls :: forall s. CompilerState s -> Text
    initDecls = (HeaderSection -> Bool) -> CompilerState s -> Text
    forall s. (HeaderSection -> Bool) -> CompilerState s -> Text
    declsCode (HeaderSection -> HeaderSection -> Bool
    forall a. Eq a => a -> a -> Bool
    == HeaderSection
    InitDecl)
    arrayDecls :: forall s. CompilerState s -> Text
    arrayDecls = (HeaderSection -> Bool) -> CompilerState s -> Text
    forall s. (HeaderSection -> Bool) -> CompilerState s -> Text
    declsCode HeaderSection -> Bool
    isArrayDecl
      where
        isArrayDecl :: HeaderSection -> Bool
    isArrayDecl ArrayDecl {} = Bool
    True
        isArrayDecl HeaderSection
    _ = Bool
    False
    opaqueTypeDecls :: forall s. CompilerState s -> Text
    opaqueTypeDecls = (HeaderSection -> Bool) -> CompilerState s -> Text
    forall s. (HeaderSection -> Bool) -> CompilerState s -> Text
    declsCode HeaderSection -> Bool
    isOpaqueTypeDecl
      where
        isOpaqueTypeDecl :: HeaderSection -> Bool
    isOpaqueTypeDecl OpaqueTypeDecl {} = Bool
    True
        isOpaqueTypeDecl HeaderSection
    _ = Bool
    False
    opaqueDecls :: forall s. CompilerState s -> Text
    opaqueDecls = (HeaderSection -> Bool) -> CompilerState s -> Text
    forall s. (HeaderSection -> Bool) -> CompilerState s -> Text
    declsCode HeaderSection -> Bool
    isOpaqueDecl
      where
        isOpaqueDecl :: HeaderSection -> Bool
    isOpaqueDecl OpaqueDecl {} = Bool
    True
        isOpaqueDecl HeaderSection
    _ = Bool
    False
    entryDecls :: forall s. CompilerState s -> Text
    entryDecls = (HeaderSection -> Bool) -> CompilerState s -> Text
    forall s. (HeaderSection -> Bool) -> CompilerState s -> Text
    declsCode (HeaderSection -> HeaderSection -> Bool
    forall a. Eq a => a -> a -> Bool
    == HeaderSection
    EntryDecl)
    miscDecls :: forall s. CompilerState s -> Text
    miscDecls = (HeaderSection -> Bool) -> CompilerState s -> Text
    forall s. (HeaderSection -> Bool) -> CompilerState s -> Text
    declsCode (HeaderSection -> HeaderSection -> Bool
    forall a. Eq a => a -> a -> Bool
    == HeaderSection
    MiscDecl)

    defineMemorySpace :: Space -> CompilerM op s ([C.Definition], C.BlockItem)
    defineMemorySpace :: forall op s. Space -> CompilerM op s ([Definition], BlockItem)
    defineMemorySpace Space
    space = do
      rm <- Space -> CompilerM op s Type
    forall op s. Space -> CompilerM op s Type
    rawMemCType Space
    space
      earlyDecl
        [C.cedecl|struct $id:sname { int *references;
                                     $ty:rm mem;
                                     typename int64_t size;
                                     const char *desc; };|]

      -- Unreferencing a memory block consists of decreasing its reference
      -- count and freeing the corresponding memory if the count reaches
      -- zero.
      free <- collect $ freeRawMem [C.cexp|block->mem|] [C.cexp|block->size|] space [C.cexp|desc|]
      ctx_ty <- contextType
      let unrefdef =
            [C.cedecl|int $id:(fatMemUnRef space) ($ty:ctx_ty *ctx, $ty:mty *block, const char *desc) {
      if (block->references != NULL) {
        *(block->references) -= 1;
        if (ctx->detail_memory) {
          fprintf(ctx->log, "Unreferencing block %s (allocated as %s) in %s: %d references remaining.\n",
                          desc, block->desc, $string:spacedesc, *(block->references));
        }
        if (*(block->references) == 0) {
          ctx->$id:usagename -= block->size;
          $items:free
          free(block->references);
          if (ctx->detail_memory) {
            fprintf(ctx->log, "%lld bytes freed (now allocated: %lld bytes)\n",
                    (long long) block->size, (long long) ctx->$id:usagename);
          }
        }
        block->references = NULL;
      }
      return 0;
    }|]

      -- When allocating a memory block we initialise the reference count to 1.
      alloc <-
        collect $
          allocRawMem [C.cexp|block->mem|] [C.cexp|size|] space [C.cexp|desc|]
      let allocdef =
            [C.cedecl|int $id:(fatMemAlloc space) ($ty:ctx_ty *ctx, $ty:mty *block, typename int64_t size, const char *desc) {
      if (size < 0) {
        futhark_panic(1, "Negative allocation of %lld bytes attempted for %s in %s.\n",
              (long long)size, desc, $string:spacedesc, ctx->$id:usagename);
      }
      int ret = $id:(fatMemUnRef space)(ctx, block, desc);

      if (ret != FUTHARK_SUCCESS) {
        return ret;
      }

      if (ctx->detail_memory) {
        fprintf(ctx->log, "Allocating %lld bytes for %s in %s (currently allocated: %lld bytes).\n",
                (long long) size,
                desc, $string:spacedesc,
                (long long) ctx->$id:usagename);
      }

      $items:alloc

      if (ctx->error == NULL) {
        block->references = (int*) malloc(sizeof(int));
        *(block->references) = 1;
        block->size = size;
        block->desc = desc;
        long long new_usage = ctx->$id:usagename + size;
        if (ctx->detail_memory) {
          fprintf(ctx->log, "Received block of %lld bytes; now allocated: %lld bytes",
                  (long long)block->size, new_usage);
        }
        ctx->$id:usagename = new_usage;
        if (new_usage > ctx->$id:peakname) {
          ctx->$id:peakname = new_usage;
          if (ctx->detail_memory) {
            fprintf(ctx->log, " (new peak).\n");
          }
        } else if (ctx->detail_memory) {
            fprintf(ctx->log, ".\n");
        }
        return FUTHARK_SUCCESS;
      } else {
        // We are naively assuming that any memory allocation error is due to OOM.
        // We preserve the original error so that a savvy user can perhaps find
        // glory despite our naiveté.

        // We cannot use set_error() here because we want to replace the old error.
        lock_lock(&ctx->error_lock);
        char *old_error = ctx->error;
        ctx->error = msgprintf("Failed to allocate memory in %s.\nAttempted allocation: %12lld bytes\nCurrently allocated:  %12lld bytes\n%s",
                               $string:spacedesc,
                               (long long) size,
                               (long long) ctx->$id:usagename,
                               old_error);
        free(old_error);
        lock_unlock(&ctx->error_lock);
        return FUTHARK_OUT_OF_MEMORY;
      }
      }|]

      -- Memory setting - unreference the destination and increase the
      -- count of the source by one.
      let setdef =
            [C.cedecl|int $id:(fatMemSet space) ($ty:ctx_ty *ctx, $ty:mty *lhs, $ty:mty *rhs, const char *lhs_desc) {
      int ret = $id:(fatMemUnRef space)(ctx, lhs, lhs_desc);
      if (rhs->references != NULL) {
        (*(rhs->references))++;
      }
      *lhs = *rhs;
      return ret;
    }
    |]

      onClear [C.citem|ctx->$id:peakname = 0;|]

      let peakmsg = FilePath
    "\"" FilePath -> FilePath -> FilePath
    forall a. Semigroup a => a -> a -> a
    <> FilePath
    spacedesc FilePath -> FilePath -> FilePath
    forall a. Semigroup a => a -> a -> a
    <> FilePath
    "\": %lld"
      pure
        ( [unrefdef, allocdef, setdef],
          [C.citem|str_builder(&builder, $string:peakmsg, (long long) ctx->$id:peakname);|]
        )
      where
        mty :: Type
    mty = Space -> Type
    fatMemType Space
    space
        (Id
    peakname, Id
    usagename, Id
    sname, FilePath
    spacedesc) = case Space
    space of
          Space FilePath
    sid ->
            ( FilePath -> SrcLoc -> Id
    forall a. ToIdent a => a -> SrcLoc -> Id
    C.toIdent (FilePath
    "peak_mem_usage_" FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    sid) SrcLoc
    forall a. IsLocation a => a
    noLoc,
              FilePath -> SrcLoc -> Id
    forall a. ToIdent a => a -> SrcLoc -> Id
    C.toIdent (FilePath
    "cur_mem_usage_" FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    sid) SrcLoc
    forall a. IsLocation a => a
    noLoc,
              FilePath -> SrcLoc -> Id
    forall a. ToIdent a => a -> SrcLoc -> Id
    C.toIdent (FilePath
    "memblock_" FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    sid) SrcLoc
    forall a. IsLocation a => a
    noLoc,
              FilePath
    "space '" FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    sid FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    "'"
            )
          Space
    _ ->
            ( Id
    "peak_mem_usage_default",
              Id
    "cur_mem_usage_default",
              Id
    "memblock",
              FilePath
    "default space"
            )

    -- | The result of compilation to C is multiple parts, which can be
    -- put together in various ways.  The obvious way is to concatenate
    -- all of them, which yields a CLI program.  Another is to compile the
    -- library part by itself, and use the header file to call into it.
    data CParts = CParts
      { CParts -> Text
    cHeader :: T.Text,
        -- | Utility definitions that must be visible
        -- to both CLI and library parts.
        CParts -> Text
    cUtils :: T.Text,
        CParts -> Text
    cCLI :: T.Text,
        CParts -> Text
    cServer :: T.Text,
        CParts -> Text
    cLib :: T.Text,
        -- | The manifest, in JSON format.
        CParts -> Text
    cJsonManifest :: T.Text
      }

    gnuSource :: T.Text
    gnuSource :: Text
    gnuSource =
      [untrimming|
    // We need to define _GNU_SOURCE before
    // _any_ headers files are imported to get
    // the usage statistics of a thread (i.e. have RUSAGE_THREAD) on GNU/Linux
    // https://manpages.courier-mta.org/htmlman2/getrusage.2.html
    #ifndef _GNU_SOURCE // Avoid possible double-definition warning.
    #define _GNU_SOURCE
    #endif
    |]

    -- We may generate variables that are never used (e.g. for
    -- certificates) or functions that are never called (e.g. unused
    -- intrinsics), and generated code may have other cosmetic issues that
    -- compilers warn about.  We disable these warnings to not clutter the
    -- compilation logs.
    disableWarnings :: T.Text
    disableWarnings :: Text
    disableWarnings =
      [untrimming|
    #ifdef __clang__
    #pragma clang diagnostic ignored "-Wunused-function"
    #pragma clang diagnostic ignored "-Wunused-variable"
    #pragma clang diagnostic ignored "-Wunused-const-variable"
    #pragma clang diagnostic ignored "-Wparentheses"
    #pragma clang diagnostic ignored "-Wunused-label"
    #pragma clang diagnostic ignored "-Wunused-but-set-variable"
    #elif __GNUC__
    #pragma GCC diagnostic ignored "-Wunused-function"
    #pragma GCC diagnostic ignored "-Wunused-variable"
    #pragma GCC diagnostic ignored "-Wunused-const-variable"
    #pragma GCC diagnostic ignored "-Wparentheses"
    #pragma GCC diagnostic ignored "-Wunused-label"
    #pragma GCC diagnostic ignored "-Wunused-but-set-variable"
    #endif
    |]

    -- | Produce header, implementation, and manifest files.
    asLibrary :: CParts -> (T.Text, T.Text, T.Text)
    asLibrary :: CParts -> (Text, Text, Text)
    asLibrary CParts
    parts =
      ( Text
    "#pragma once\n\n" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> CParts -> Text
    cHeader CParts
    parts,
        Text
    gnuSource Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    disableWarnings Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> CParts -> Text
    cHeader CParts
    parts Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> CParts -> Text
    cUtils CParts
    parts Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> CParts -> Text
    cLib CParts
    parts,
        CParts -> Text
    cJsonManifest CParts
    parts
      )

    -- | As executable with command-line interface.
    asExecutable :: CParts -> T.Text
    asExecutable :: CParts -> Text
    asExecutable CParts
    parts =
      Text
    gnuSource Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    disableWarnings Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> CParts -> Text
    cHeader CParts
    parts Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> CParts -> Text
    cUtils CParts
    parts Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> CParts -> Text
    cCLI CParts
    parts Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> CParts -> Text
    cLib CParts
    parts

    -- | As server executable.
    asServer :: CParts -> T.Text
    asServer :: CParts -> Text
    asServer CParts
    parts =
      Text
    gnuSource Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    disableWarnings Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> CParts -> Text
    cHeader CParts
    parts Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> CParts -> Text
    cUtils CParts
    parts Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> CParts -> Text
    cServer CParts
    parts Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> CParts -> Text
    cLib CParts
    parts

    relevantParams :: Name -> ParamMap -> [Name]
    relevantParams :: Name -> ParamMap -> [Name]
    relevantParams Name
    fname ParamMap
    m =
      ((Name, (SizeClass, Set Name)) -> Name)
    -> [(Name, (SizeClass, Set Name))] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map (Name, (SizeClass, Set Name)) -> Name
    forall a b. (a, b) -> a
    fst ([(Name, (SizeClass, Set Name))] -> [Name])
    -> [(Name, (SizeClass, Set Name))] -> [Name]
    forall a b. (a -> b) -> a -> b
    $ ((Name, (SizeClass, Set Name)) -> Bool)
    -> [(Name, (SizeClass, Set Name))]
    -> [(Name, (SizeClass, Set Name))]
    forall a. (a -> Bool) -> [a] -> [a]
    filter ((Name
    fname Name -> Set Name -> Bool
    forall a. Ord a => a -> Set a -> Bool
    `S.member`) (Set Name -> Bool)
    -> ((Name, (SizeClass, Set Name)) -> Set Name)
    -> (Name, (SizeClass, Set Name))
    -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (SizeClass, Set Name) -> Set Name
    forall a b. (a, b) -> b
    snd ((SizeClass, Set Name) -> Set Name)
    -> ((Name, (SizeClass, Set Name)) -> (SizeClass, Set Name))
    -> (Name, (SizeClass, Set Name))
    -> Set Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Name, (SizeClass, Set Name)) -> (SizeClass, Set Name)
    forall a b. (a, b) -> b
    snd) ([(Name, (SizeClass, Set Name))]
     -> [(Name, (SizeClass, Set Name))])
    -> [(Name, (SizeClass, Set Name))]
    -> [(Name, (SizeClass, Set Name))]
    forall a b. (a -> b) -> a -> b
    $ ParamMap -> [(Name, (SizeClass, Set Name))]
    forall k a. Map k a -> [(k, a)]
    M.toList ParamMap
    m

    compileProg' ::
      (MonadFreshNames m) =>
      T.Text ->
      T.Text ->
      ParamMap ->
      Operations op s ->
      s ->
      CompilerM op s () ->
      T.Text ->
      (Space, [Space]) ->
      [Option] ->
      Definitions op ->
      m (CParts, CompilerState s)
    compileProg' :: forall (m :: * -> *) op s.
    MonadFreshNames m =>
    Text
    -> Text
    -> ParamMap
    -> Operations op s
    -> s
    -> CompilerM op s ()
    -> Text
    -> (Space, [Space])
    -> [Option]
    -> Definitions op
    -> m (CParts, CompilerState s)
    compileProg' Text
    backend Text
    version ParamMap
    params Operations op s
    ops s
    def CompilerM op s ()
    extra Text
    header_extra (Space
    arr_space, [Space]
    spaces) [Option]
    options Definitions op
    prog = do
      src <- m VNameSource
    forall (m :: * -> *). MonadFreshNames m => m VNameSource
    getNameSource
      let ((prototypes, definitions, entry_point_decls, manifest), endstate) =
            runCompilerM ops src def compileProgAction
          initdecls = CompilerState s -> Text
    forall s. CompilerState s -> Text
    initDecls CompilerState s
    endstate
          entrydecls = CompilerState s -> Text
    forall s. CompilerState s -> Text
    entryDecls CompilerState s
    endstate
          arraydecls = CompilerState s -> Text
    forall s. CompilerState s -> Text
    arrayDecls CompilerState s
    endstate
          opaquetypedecls = CompilerState s -> Text
    forall s. CompilerState s -> Text
    opaqueTypeDecls CompilerState s
    endstate
          opaquedecls = CompilerState s -> Text
    forall s. CompilerState s -> Text
    opaqueDecls CompilerState s
    endstate
          miscdecls = CompilerState s -> Text
    forall s. CompilerState s -> Text
    miscDecls CompilerState s
    endstate

      let headerdefs =
            [untrimming|
    // Headers
    #include <stdint.h>
    #include <stddef.h>
    #include <stdbool.h>
    #include <stdio.h>
    #include <float.h>
    $header_extra
    #ifdef __cplusplus
    extern "C" {
    #endif

    // Initialisation
    $initdecls

    // Arrays
    $arraydecls

    // Opaque values
    $opaquetypedecls
    $opaquedecls

    // Entry points
    $entrydecls

    // Miscellaneous
    $miscdecls
    #define FUTHARK_BACKEND_$backend
    $errorsH

    #ifdef __cplusplus
    }
    #endif
    |]

      let utildefs =
            [untrimming|
    #include <stdio.h>
    #include <stdlib.h>
    #include <stdbool.h>
    #include <math.h>
    #include <stdint.h>
    // If NDEBUG is set, the assert() macro will do nothing. Since Futhark
    // (unfortunately) makes use of assert() for error detection (and even some
    // side effects), we want to avoid that.
    #undef NDEBUG
    #include <assert.h>
    #include <stdarg.h>
    #define SCALAR_FUN_ATTR static inline
    $utilH
    $cacheH
    $halfH
    $timingH
    $lockH
    $freeListH
    $eventListH
    |]

      let early_decls = [Definition] -> Text
    definitionsText ([Definition] -> Text) -> [Definition] -> Text
    forall a b. (a -> b) -> a -> b
    $ DList Definition -> [Definition]
    forall a. DList a -> [a]
    DL.toList (DList Definition -> [Definition])
    -> DList Definition -> [Definition]
    forall a b. (a -> b) -> a -> b
    $ CompilerState s -> DList Definition
    forall s. CompilerState s -> DList Definition
    compEarlyDecls CompilerState s
    endstate
          lib_decls = [Definition] -> Text
    definitionsText ([Definition] -> Text) -> [Definition] -> Text
    forall a b. (a -> b) -> a -> b
    $ DList Definition -> [Definition]
    forall a. DList a -> [a]
    DL.toList (DList Definition -> [Definition])
    -> DList Definition -> [Definition]
    forall a b. (a -> b) -> a -> b
    $ CompilerState s -> DList Definition
    forall s. CompilerState s -> DList Definition
    compLibDecls CompilerState s
    endstate
          clidefs = [Option] -> Manifest -> Text
    cliDefs [Option]
    options Manifest
    manifest
          serverdefs = [Option] -> Manifest -> Text
    serverDefs [Option]
    options Manifest
    manifest
          libdefs =
            [untrimming|
    #ifdef _MSC_VER
    #define inline __inline
    #endif
    #include <string.h>
    #include <string.h>
    #include <errno.h>
    #include <assert.h>
    #include <ctype.h>

    $header_extra

    #define FUTHARK_F64_ENABLED

    $cScalarDefs

    $contextPrototypesH

    $early_decls

    $contextH

    $copyH

    #define FUTHARK_FUN_ATTR static

    $prototypes

    $lib_decls

    $definitions

    $entry_point_decls
      |]

      pure
        ( CParts
            { cHeader = headerdefs,
              cUtils = utildefs,
              cCLI = clidefs,
              cServer = serverdefs,
              cLib = libdefs,
              cJsonManifest = Manifest.manifestToJSON manifest
            },
          endstate
        )
      where
        Definitions OpaqueTypes
    types Constants op
    consts (Functions [(Name, Function op)]
    funs) = Definitions op
    prog

        compileProgAction :: CompilerM op s (Text, Text, Text, Manifest)
    compileProgAction = do
          (memfuns, memreport) <- (Space -> CompilerM op s ([Definition], BlockItem))
    -> [Space] -> CompilerM op s ([[Definition]], [BlockItem])
    forall (m :: * -> *) a b c.
    Applicative m =>
    (a -> m (b, c)) -> [a] -> m ([b], [c])
    mapAndUnzipM Space -> CompilerM op s ([Definition], BlockItem)
    forall op s. Space -> CompilerM op s ([Definition], BlockItem)
    defineMemorySpace [Space]
    spaces

          get_consts <- compileConstants consts

          ctx_ty <- contextType

          (prototypes, functions) <-
            mapAndUnzipM (compileFun get_consts [[C.cparam|$ty:ctx_ty *ctx|]]) funs

          (entry_points, entry_points_manifest) <-
            fmap (unzip . catMaybes) $ forM funs $ \(Name
    fname, Function op
    fun) ->
              [BlockItem]
    -> [Name]
    -> Name
    -> Function op
    -> CompilerM op s (Maybe (Definition, (Text, EntryPoint)))
    forall op s.
    [BlockItem]
    -> [Name]
    -> Name
    -> Function op
    -> CompilerM op s (Maybe (Definition, (Text, EntryPoint)))
    onEntryPoint [BlockItem]
    get_consts (Name -> ParamMap -> [Name]
    relevantParams Name
    fname ParamMap
    params) Name
    fname Function op
    fun

          headerDecl InitDecl [C.cedecl|struct futhark_context_config;|]
          headerDecl InitDecl [C.cedecl|struct futhark_context_config* futhark_context_config_new(void);|]
          headerDecl InitDecl [C.cedecl|void futhark_context_config_free(struct futhark_context_config* cfg);|]
          headerDecl InitDecl [C.cedecl|int futhark_context_config_set_tuning_param(struct futhark_context_config *cfg, const char *param_name, size_t new_value);|]

          headerDecl InitDecl [C.cedecl|struct futhark_context;|]
          headerDecl InitDecl [C.cedecl|struct futhark_context* futhark_context_new(struct futhark_context_config* cfg);|]
          headerDecl InitDecl [C.cedecl|void futhark_context_free(struct futhark_context* ctx);|]
          headerDecl MiscDecl [C.cedecl|int futhark_context_sync(struct futhark_context* ctx);|]

          generateTuningParams params
          extra

          let set_tuning_params =
                (Int -> Name -> Stm) -> [Int] -> [Name] -> [Stm]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith
                  (\Int
    i Name
    k -> [C.cstm|ctx->tuning_params.$id:k = &ctx->cfg->tuning_params[$int:i];|])
                  [(Int
    0 :: Int) ..]
                  ([Name] -> [Stm]) -> [Name] -> [Stm]
    forall a b. (a -> b) -> a -> b
    $ ParamMap -> [Name]
    forall k a. Map k a -> [k]
    M.keys ParamMap
    params
          earlyDecl
            [C.cedecl|static void set_tuning_params(struct futhark_context* ctx) {
                        (void)ctx;
                        $stms:set_tuning_params
                      }|]

          mapM_ earlyDecl $ concat memfuns
          type_funs <- generateAPITypes arr_space types

          headerDecl InitDecl [C.cedecl|void futhark_context_config_set_debugging(struct futhark_context_config* cfg, int flag);|]
          headerDecl InitDecl [C.cedecl|void futhark_context_config_set_profiling(struct futhark_context_config* cfg, int flag);|]
          headerDecl InitDecl [C.cedecl|void futhark_context_config_set_logging(struct futhark_context_config* cfg, int flag);|]
          headerDecl MiscDecl [C.cedecl|void futhark_context_config_set_cache_file(struct futhark_context_config* cfg, const char *f);|]
          headerDecl InitDecl [C.cedecl|int futhark_get_tuning_param_count(void);|]
          headerDecl InitDecl [C.cedecl|const char* futhark_get_tuning_param_name(int);|]
          headerDecl InitDecl [C.cedecl|const char* futhark_get_tuning_param_class(int);|]
          headerDecl MiscDecl [C.cedecl|char* futhark_context_get_error(struct futhark_context* ctx);|]
          headerDecl MiscDecl [C.cedecl|void futhark_context_set_logging_file(struct futhark_context* ctx, typename FILE* f);|]
          headerDecl MiscDecl [C.cedecl|void futhark_context_pause_profiling(struct futhark_context* ctx);|]
          headerDecl MiscDecl [C.cedecl|void futhark_context_unpause_profiling(struct futhark_context* ctx);|]

          generateCommonLibFuns memreport

          pure
            ( definitionsText prototypes,
              funcsText functions,
              definitionsText entry_points,
              Manifest.Manifest (M.fromList entry_points_manifest) type_funs backend version
            )

    -- | Compile imperative program to a C program.  Always uses the
    -- function named "main" as entry point, so make sure it is defined.
    compileProg ::
      (MonadFreshNames m) =>
      T.Text ->
      T.Text ->
      ParamMap ->
      Operations op () ->
      CompilerM op () () ->
      T.Text ->
      (Space, [Space]) ->
      [Option] ->
      Definitions op ->
      m CParts
    compileProg :: forall (m :: * -> *) op.
    MonadFreshNames m =>
    Text
    -> Text
    -> ParamMap
    -> Operations op ()
    -> CompilerM op () ()
    -> Text
    -> (Space, [Space])
    -> [Option]
    -> Definitions op
    -> m CParts
    compileProg Text
    backend Text
    version ParamMap
    params Operations op ()
    ops CompilerM op () ()
    extra Text
    header_extra (Space
    arr_space, [Space]
    spaces) [Option]
    options Definitions op
    prog =
      (CParts, CompilerState ()) -> CParts
    forall a b. (a, b) -> a
    fst ((CParts, CompilerState ()) -> CParts)
    -> m (CParts, CompilerState ()) -> m CParts
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Text
    -> Text
    -> ParamMap
    -> Operations op ()
    -> ()
    -> CompilerM op () ()
    -> Text
    -> (Space, [Space])
    -> [Option]
    -> Definitions op
    -> m (CParts, CompilerState ())
    forall (m :: * -> *) op s.
    MonadFreshNames m =>
    Text
    -> Text
    -> ParamMap
    -> Operations op s
    -> s
    -> CompilerM op s ()
    -> Text
    -> (Space, [Space])
    -> [Option]
    -> Definitions op
    -> m (CParts, CompilerState s)
    compileProg' Text
    backend Text
    version ParamMap
    params Operations op ()
    ops () CompilerM op () ()
    extra Text
    header_extra (Space
    arr_space, [Space]
    spaces) [Option]
    options Definitions op
    prog

    generateTuningParams :: ParamMap -> CompilerM op a ()
    generateTuningParams :: forall op a. ParamMap -> CompilerM op a ()
    generateTuningParams ParamMap
    params = do
      let ([Name]
    param_names, ([SizeClass]
    param_classes, [Set Name]
    _param_users)) =
            ([(SizeClass, Set Name)] -> ([SizeClass], [Set Name]))
    -> ([Name], [(SizeClass, Set Name)])
    -> ([Name], ([SizeClass], [Set Name]))
    forall b c a. (b -> c) -> (a, b) -> (a, c)
    forall (p :: * -> * -> *) b c a.
    Bifunctor p =>
    (b -> c) -> p a b -> p a c
    second [(SizeClass, Set Name)] -> ([SizeClass], [Set Name])
    forall a b. [(a, b)] -> ([a], [b])
    unzip (([Name], [(SizeClass, Set Name)])
     -> ([Name], ([SizeClass], [Set Name])))
    -> ([Name], [(SizeClass, Set Name)])
    -> ([Name], ([SizeClass], [Set Name]))
    forall a b. (a -> b) -> a -> b
    $ [(Name, (SizeClass, Set Name))]
    -> ([Name], [(SizeClass, Set Name)])
    forall a b. [(a, b)] -> ([a], [b])
    unzip ([(Name, (SizeClass, Set Name))]
     -> ([Name], [(SizeClass, Set Name)]))
    -> [(Name, (SizeClass, Set Name))]
    -> ([Name], [(SizeClass, Set Name)])
    forall a b. (a -> b) -> a -> b
    $ ParamMap -> [(Name, (SizeClass, Set Name))]
    forall k a. Map k a -> [(k, a)]
    M.toList ParamMap
    params
          strinit :: Text -> Initializer
    strinit Text
    s = [C.cinit|$string:(T.unpack s)|]
          intinit :: a -> Initializer
    intinit a
    x = [C.cinit|$int:x|]
          size_name_inits :: [Initializer]
    size_name_inits = (Name -> Initializer) -> [Name] -> [Initializer]
    forall a b. (a -> b) -> [a] -> [b]
    map (Text -> Initializer
    strinit (Text -> Initializer) -> (Name -> Text) -> Name -> Initializer
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> Text
    forall a. Pretty a => a -> Text
    prettyText) [Name]
    param_names
          size_var_inits :: [Initializer]
    size_var_inits = (Name -> Initializer) -> [Name] -> [Initializer]
    forall a b. (a -> b) -> [a] -> [b]
    map (Text -> Initializer
    strinit (Text -> Initializer) -> (Name -> Text) -> Name -> Initializer
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> Text
    zEncodeText (Text -> Text) -> (Name -> Text) -> Name -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> Text
    forall a. Pretty a => a -> Text
    prettyText) [Name]
    param_names
          size_class_inits :: [Initializer]
    size_class_inits = (SizeClass -> Initializer) -> [SizeClass] -> [Initializer]
    forall a b. (a -> b) -> [a] -> [b]
    map (Text -> Initializer
    strinit (Text -> Initializer)
    -> (SizeClass -> Text) -> SizeClass -> Initializer
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . SizeClass -> Text
    forall a. Pretty a => a -> Text
    prettyText) [SizeClass]
    param_classes
          size_default_inits :: [Initializer]
    size_default_inits = (SizeClass -> Initializer) -> [SizeClass] -> [Initializer]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int64 -> Initializer
    forall {a}. (Show a, Integral a) => a -> Initializer
    intinit (Int64 -> Initializer)
    -> (SizeClass -> Int64) -> SizeClass -> Initializer
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int64 -> Maybe Int64 -> Int64
    forall a. a -> Maybe a -> a
    fromMaybe Int64
    0 (Maybe Int64 -> Int64)
    -> (SizeClass -> Maybe Int64) -> SizeClass -> Int64
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . SizeClass -> Maybe Int64
    sizeDefault) [SizeClass]
    param_classes
          size_decls :: [FieldGroup]
    size_decls = (Name -> FieldGroup) -> [Name] -> [FieldGroup]
    forall a b. (a -> b) -> [a] -> [b]
    map (\Name
    k -> [C.csdecl|typename int64_t *$id:k;|]) [Name]
    param_names
          num_params :: Int
    num_params = ParamMap -> Int
    forall a. Map Name a -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length ParamMap
    params
      Definition -> CompilerM op a ()
    forall op s. Definition -> CompilerM op s ()
    earlyDecl [C.cedecl|struct tuning_params { int dummy; $sdecls:size_decls };|]
      Definition -> CompilerM op a ()
    forall op s. Definition -> CompilerM op s ()
    earlyDecl [C.cedecl|static const int num_tuning_params = $int:num_params;|]
      Definition -> CompilerM op a ()
    forall op s. Definition -> CompilerM op s ()
    earlyDecl [C.cedecl|static const char *tuning_param_names[] = { $inits:size_name_inits, NULL };|]
      Definition -> CompilerM op a ()
    forall op s. Definition -> CompilerM op s ()
    earlyDecl [C.cedecl|static const char *tuning_param_vars[] = { $inits:size_var_inits, NULL };|]
      Definition -> CompilerM op a ()
    forall op s. Definition -> CompilerM op s ()
    earlyDecl [C.cedecl|static const char *tuning_param_classes[] = { $inits:size_class_inits, NULL };|]
      Definition -> CompilerM op a ()
    forall op s. Definition -> CompilerM op s ()
    earlyDecl [C.cedecl|static typename int64_t tuning_param_defaults[] = { $inits:size_default_inits, 0 };|]

    generateCommonLibFuns :: [C.BlockItem] -> CompilerM op s ()
    generateCommonLibFuns :: forall op s. [BlockItem] -> CompilerM op s ()
    generateCommonLibFuns [BlockItem]
    memreport = do
      ctx <- CompilerM op s Type
    forall op s. CompilerM op s Type
    contextType
      ops <- asks envOperations

      sync <- publicName "context_sync"
      let comma = [C.citem|str_builder_char(&builder, ',');|]
      publicDef_ "context_report" MiscDecl $ \Text
    s ->
        ( [C.cedecl|char* $id:s($ty:ctx *ctx);|],
          [C.cedecl|char* $id:s($ty:ctx *ctx) {
                     if ($id:sync(ctx) != 0) {
                       return NULL;
                     }

                     struct str_builder builder;
                     str_builder_init(&builder);
                     str_builder_char(&builder, '{');
                     str_builder_str(&builder, "\"memory\":{");
                     $items:(L.intersperse comma memreport)
                     str_builder_str(&builder, "},\"events\":[");
                     if (report_events_in_list(&ctx->event_list, &builder) != 0) {
                       free(builder.str);
                       return NULL;
                     } else {
                       str_builder_str(&builder, "]}");
                       return builder.str;
                     }
                   }|]
        )

      clears <- gets $ DL.toList . compClearItems
      publicDef_ "context_clear_caches" MiscDecl $ \Text
    s ->
        ( [C.cedecl|int $id:s($ty:ctx* ctx);|],
          [C.cedecl|int $id:s($ty:ctx* ctx) {
                      $items:(criticalSection ops clears)
                      return ctx->error != NULL;
                    }|]
        )

    compileConstants :: Constants op -> CompilerM op s [C.BlockItem]
    compileConstants :: forall op s. Constants op -> CompilerM op s [BlockItem]
    compileConstants (Constants [Param]
    ps Code op
    init_consts) = do
      ctx_ty <- CompilerM op s Type
    forall op s. CompilerM op s Type
    contextType
      const_fields <- mapM constParamField ps
      earlyDecl [C.cedecl|struct constants { int dummy; $sdecls:const_fields };|]

      inNewFunction $ do
        -- We locally define macros for the constants, so that when we
        -- generate assignments to local variables, we actually assign into
        -- the constants struct.  This is not needed for functions, because
        -- they can only read constants, not write them.
        let (defs, undefs) = unzip $ map constMacro ps
        init_consts' <- collect $ do
          mapM_ resetMemConst ps
          compileCode init_consts
        decl_mem <- declAllocatedMem
        free_mem <- freeAllocatedMem
        libDecl
          [C.cedecl|static int init_constants($ty:ctx_ty *ctx) {
            (void)ctx;
            int err = 0;
            $items:defs
            $items:decl_mem
            $items:init_consts'
            $items:free_mem
            $items:undefs
            cleanup:
            return err;
          }|]

      inNewFunction $ do
        free_consts <- collect $ mapM_ freeConst ps
        libDecl
          [C.cedecl|static int free_constants($ty:ctx_ty *ctx) {
            (void)ctx;
            $items:free_consts
            return 0;
          }|]

      mapM getConst ps
      where
        constParamField :: Param -> CompilerM op s FieldGroup
    constParamField (ScalarParam VName
    name PrimType
    bt) = do
          let ctp :: Type
    ctp = PrimType -> Type
    primTypeToCType PrimType
    bt
          FieldGroup -> CompilerM op s FieldGroup
    forall a. a -> CompilerM op s a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure [C.csdecl|$ty:ctp $id:name;|]
        constParamField (MemParam VName
    name Space
    space) = do
          ty <- VName -> Space -> CompilerM op s Type
    forall op s. VName -> Space -> CompilerM op s Type
    memToCType VName
    name Space
    space
          pure [C.csdecl|$ty:ty $id:name;|]

        constMacro :: Param -> (BlockItem, BlockItem)
    constMacro Param
    p = ([C.citem|$escstm:def|], [C.citem|$escstm:undef|])
          where
            p' :: FilePath
    p' = Text -> FilePath
    T.unpack (Text -> FilePath) -> Text -> FilePath
    forall a b. (a -> b) -> a -> b
    $ Id -> Text
    idText (VName -> SrcLoc -> Id
    forall a. ToIdent a => a -> SrcLoc -> Id
    C.toIdent (Param -> VName
    paramName Param
    p) SrcLoc
    forall a. Monoid a => a
    mempty)
            def :: FilePath
    def = FilePath
    "#define " FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    p' FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    " (" FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    "ctx->constants->" FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    p' FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    ")"
            undef :: FilePath
    undef = FilePath
    "#undef " FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    p'

        resetMemConst :: Param -> CompilerM op s ()
    resetMemConst ScalarParam {} = () -> CompilerM op s ()
    forall a. a -> CompilerM op s a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
        resetMemConst (MemParam VName
    name Space
    space) = VName -> Space -> CompilerM op s ()
    forall a op s. ToExp a => a -> Space -> CompilerM op s ()
    resetMem VName
    name Space
    space

        freeConst :: Param -> CompilerM op s ()
    freeConst ScalarParam {} = () -> CompilerM op s ()
    forall a. a -> CompilerM op s a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
        freeConst (MemParam VName
    name Space
    space) = Exp -> Space -> CompilerM op s ()
    forall a op s. ToExp a => a -> Space -> CompilerM op s ()
    unRefMem [C.cexp|ctx->constants->$id:name|] Space
    space

        getConst :: Param -> CompilerM op s BlockItem
    getConst (ScalarParam VName
    name PrimType
    bt) = do
          let ctp :: Type
    ctp = PrimType -> Type
    primTypeToCType PrimType
    bt
          BlockItem -> CompilerM op s BlockItem
    forall a. a -> CompilerM op s a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure [C.citem|$ty:ctp $id:name = ctx->constants->$id:name;|]
        getConst (MemParam VName
    name Space
    space) = do
          ty <- VName -> Space -> CompilerM op s Type
    forall op s. VName -> Space -> CompilerM op s Type
    memToCType VName
    name Space
    space
          pure [C.citem|$ty:ty $id:name = ctx->constants->$id:name;|]