{-# 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
  (FilePath
formatstr, [Exp]
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
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"
  [BlockItem] -> CompilerM op s ()
forall op s. [BlockItem] -> CompilerM op 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
  Type
rm <- Space -> CompilerM op s Type
forall op s. Space -> CompilerM op s Type
rawMemCType Space
space
  Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
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.
  [BlockItem]
free <- CompilerM op s () -> CompilerM op s [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect (CompilerM op s () -> CompilerM op s [BlockItem])
-> CompilerM op s () -> CompilerM op s [BlockItem]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Space -> Exp -> CompilerM op s ()
forall a b c op s.
(ToExp a, ToExp b, ToExp c) =>
a -> b -> Space -> c -> CompilerM op s ()
freeRawMem [C.cexp|block->mem|] [C.cexp|block->size|] Space
space [C.cexp|desc|]
  Type
ctx_ty <- CompilerM op s Type
forall op s. CompilerM op s Type
contextType
  let unrefdef :: Definition
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.
  [BlockItem]
alloc <-
    CompilerM op s () -> CompilerM op s [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect (CompilerM op s () -> CompilerM op s [BlockItem])
-> CompilerM op s () -> CompilerM op s [BlockItem]
forall a b. (a -> b) -> a -> b
$
      Exp -> Exp -> Space -> Exp -> CompilerM op s ()
forall a b c op s.
(ToExp a, ToExp b, ToExp c) =>
a -> b -> Space -> c -> CompilerM op s ()
allocRawMem [C.cexp|block->mem|] [C.cexp|size|] Space
space [C.cexp|desc|]
  let allocdef :: Definition
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 :: Definition
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;
}
|]

  BlockItem -> CompilerM op s ()
forall op s. BlockItem -> CompilerM op s ()
onClear [C.citem|ctx->$id:peakname = 0;|]

  let peakmsg :: FilePath
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"
  ([Definition], BlockItem)
-> CompilerM op s ([Definition], BlockItem)
forall a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( [Definition
unrefdef, Definition
allocdef, Definition
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 `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
  VNameSource
src <- m VNameSource
forall (m :: * -> *). MonadFreshNames m => m VNameSource
getNameSource
  let ((Text
prototypes, Text
definitions, Text
entry_point_decls, Manifest
manifest), CompilerState s
endstate) =
        Operations op s
-> VNameSource
-> s
-> CompilerM op s (Text, Text, Text, Manifest)
-> ((Text, Text, Text, Manifest), CompilerState s)
forall op s a.
Operations op s
-> VNameSource -> s -> CompilerM op s a -> (a, CompilerState s)
runCompilerM Operations op s
ops VNameSource
src s
def CompilerM op s (Text, Text, Text, Manifest)
compileProgAction
      initdecls :: Text
initdecls = CompilerState s -> Text
forall s. CompilerState s -> Text
initDecls CompilerState s
endstate
      entrydecls :: Text
entrydecls = CompilerState s -> Text
forall s. CompilerState s -> Text
entryDecls CompilerState s
endstate
      arraydecls :: Text
arraydecls = CompilerState s -> Text
forall s. CompilerState s -> Text
arrayDecls CompilerState s
endstate
      opaquetypedecls :: Text
opaquetypedecls = CompilerState s -> Text
forall s. CompilerState s -> Text
opaqueTypeDecls CompilerState s
endstate
      opaquedecls :: Text
opaquedecls = CompilerState s -> Text
forall s. CompilerState s -> Text
opaqueDecls CompilerState s
endstate
      miscdecls :: Text
miscdecls = CompilerState s -> Text
forall s. CompilerState s -> Text
miscDecls CompilerState s
endstate

  let headerdefs :: Text
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 :: Text
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 :: Text
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 :: Text
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 :: Text
clidefs = [Option] -> Manifest -> Text
cliDefs [Option]
options Manifest
manifest
      serverdefs :: Text
serverdefs = [Option] -> Manifest -> Text
serverDefs [Option]
options Manifest
manifest
      libdefs :: Text
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
  |]

  (CParts, CompilerState s) -> m (CParts, CompilerState s)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( CParts
        { cHeader :: Text
cHeader = Text
headerdefs,
          cUtils :: Text
cUtils = Text
utildefs,
          cCLI :: Text
cCLI = Text
clidefs,
          cServer :: Text
cServer = Text
serverdefs,
          cLib :: Text
cLib = Text
libdefs,
          cJsonManifest :: Text
cJsonManifest = Manifest -> Text
Manifest.manifestToJSON Manifest
manifest
        },
      CompilerState s
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
      ([[Definition]]
memfuns, [BlockItem]
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

      [BlockItem]
get_consts <- Constants op -> CompilerM op s [BlockItem]
forall op s. Constants op -> CompilerM op s [BlockItem]
compileConstants Constants op
consts

      Type
ctx_ty <- CompilerM op s Type
forall op s. CompilerM op s Type
contextType

      ([Definition]
prototypes, [Func]
functions) <-
        ((Name, Function op) -> CompilerM op s (Definition, Func))
-> [(Name, Function op)] -> CompilerM op s ([Definition], [Func])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM ([BlockItem]
-> [Param]
-> (Name, Function op)
-> CompilerM op s (Definition, Func)
forall op s.
[BlockItem]
-> [Param]
-> (Name, Function op)
-> CompilerM op s (Definition, Func)
compileFun [BlockItem]
get_consts [[C.cparam|$ty:ctx_ty *ctx|]]) [(Name, Function op)]
funs

      ([Definition]
entry_points, [(Text, EntryPoint)]
entry_points_manifest) <-
        ([Maybe (Definition, (Text, EntryPoint))]
 -> ([Definition], [(Text, EntryPoint)]))
-> CompilerM op s [Maybe (Definition, (Text, EntryPoint))]
-> CompilerM op s ([Definition], [(Text, EntryPoint)])
forall a b. (a -> b) -> CompilerM op s a -> CompilerM op s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(Definition, (Text, EntryPoint))]
-> ([Definition], [(Text, EntryPoint)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Definition, (Text, EntryPoint))]
 -> ([Definition], [(Text, EntryPoint)]))
-> ([Maybe (Definition, (Text, EntryPoint))]
    -> [(Definition, (Text, EntryPoint))])
-> [Maybe (Definition, (Text, EntryPoint))]
-> ([Definition], [(Text, EntryPoint)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Definition, (Text, EntryPoint))]
-> [(Definition, (Text, EntryPoint))]
forall a. [Maybe a] -> [a]
catMaybes) (CompilerM op s [Maybe (Definition, (Text, EntryPoint))]
 -> CompilerM op s ([Definition], [(Text, EntryPoint)]))
-> CompilerM op s [Maybe (Definition, (Text, EntryPoint))]
-> CompilerM op s ([Definition], [(Text, EntryPoint)])
forall a b. (a -> b) -> a -> b
$ [(Name, Function op)]
-> ((Name, Function op)
    -> CompilerM op s (Maybe (Definition, (Text, EntryPoint))))
-> CompilerM op s [Maybe (Definition, (Text, EntryPoint))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Name, Function op)]
funs (((Name, Function op)
  -> CompilerM op s (Maybe (Definition, (Text, EntryPoint))))
 -> CompilerM op s [Maybe (Definition, (Text, EntryPoint))])
-> ((Name, Function op)
    -> CompilerM op s (Maybe (Definition, (Text, EntryPoint))))
-> CompilerM op s [Maybe (Definition, (Text, EntryPoint))]
forall a b. (a -> b) -> a -> b
$ \(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

      HeaderSection -> Definition -> CompilerM op s ()
forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl HeaderSection
InitDecl [C.cedecl|struct futhark_context_config;|]
      HeaderSection -> Definition -> CompilerM op s ()
forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl HeaderSection
InitDecl [C.cedecl|struct futhark_context_config* futhark_context_config_new(void);|]
      HeaderSection -> Definition -> CompilerM op s ()
forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl HeaderSection
InitDecl [C.cedecl|void futhark_context_config_free(struct futhark_context_config* cfg);|]
      HeaderSection -> Definition -> CompilerM op s ()
forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl HeaderSection
InitDecl [C.cedecl|int futhark_context_config_set_tuning_param(struct futhark_context_config *cfg, const char *param_name, size_t new_value);|]

      HeaderSection -> Definition -> CompilerM op s ()
forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl HeaderSection
InitDecl [C.cedecl|struct futhark_context;|]
      HeaderSection -> Definition -> CompilerM op s ()
forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl HeaderSection
InitDecl [C.cedecl|struct futhark_context* futhark_context_new(struct futhark_context_config* cfg);|]
      HeaderSection -> Definition -> CompilerM op s ()
forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl HeaderSection
InitDecl [C.cedecl|void futhark_context_free(struct futhark_context* cfg);|]
      HeaderSection -> Definition -> CompilerM op s ()
forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl HeaderSection
MiscDecl [C.cedecl|int futhark_context_sync(struct futhark_context* ctx);|]

      ParamMap -> CompilerM op s ()
forall op a. ParamMap -> CompilerM op a ()
generateTuningParams ParamMap
params
      CompilerM op s ()
extra

      let set_tuning_params :: [Stm]
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
      Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
earlyDecl
        [C.cedecl|static void set_tuning_params(struct futhark_context* ctx) {
                    (void)ctx;
                    $stms:set_tuning_params
                  }|]

      (Definition -> CompilerM op s ())
-> [Definition] -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
earlyDecl ([Definition] -> CompilerM op s ())
-> [Definition] -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ [[Definition]] -> [Definition]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Definition]]
memfuns
      Map Text Type
type_funs <- Space -> OpaqueTypes -> CompilerM op s (Map Text Type)
forall op s. Space -> OpaqueTypes -> CompilerM op s (Map Text Type)
generateAPITypes Space
arr_space OpaqueTypes
types

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

      [BlockItem] -> CompilerM op s ()
forall op s. [BlockItem] -> CompilerM op s ()
generateCommonLibFuns [BlockItem]
memreport

      (Text, Text, Text, Manifest)
-> CompilerM op s (Text, Text, Text, Manifest)
forall a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( [Definition] -> Text
definitionsText [Definition]
prototypes,
          [Func] -> Text
funcsText [Func]
functions,
          [Definition] -> Text
definitionsText [Definition]
entry_points,
          Map Text EntryPoint -> Map Text Type -> Text -> Text -> Manifest
Manifest.Manifest ([(Text, EntryPoint)] -> Map Text EntryPoint
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Text, EntryPoint)]
entry_points_manifest) Map Text Type
type_funs Text
backend Text
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
  Type
ctx <- CompilerM op s Type
forall op s. CompilerM op s Type
contextType
  Operations op s
ops <- (CompilerEnv op s -> Operations op s)
-> CompilerM op s (Operations op s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompilerEnv op s -> Operations op s
forall op s. CompilerEnv op s -> Operations op s
envOperations

  Text
sync <- Text -> CompilerM op s Text
forall op s. Text -> CompilerM op s Text
publicName Text
"context_sync"
  let comma :: BlockItem
comma = [C.citem|str_builder_char(&builder, ',');|]
  Text
-> HeaderSection
-> (Text -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
Text
-> HeaderSection
-> (Text -> (Definition, Definition))
-> CompilerM op s ()
publicDef_ Text
"context_report" HeaderSection
MiscDecl ((Text -> (Definition, Definition)) -> CompilerM op s ())
-> (Text -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \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;
                 }
               }|]
    )

  [BlockItem]
clears <- (CompilerState s -> [BlockItem]) -> CompilerM op s [BlockItem]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((CompilerState s -> [BlockItem]) -> CompilerM op s [BlockItem])
-> (CompilerState s -> [BlockItem]) -> CompilerM op s [BlockItem]
forall a b. (a -> b) -> a -> b
$ DList BlockItem -> [BlockItem]
forall a. DList a -> [a]
DL.toList (DList BlockItem -> [BlockItem])
-> (CompilerState s -> DList BlockItem)
-> CompilerState s
-> [BlockItem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerState s -> DList BlockItem
forall s. CompilerState s -> DList BlockItem
compClearItems
  Text
-> HeaderSection
-> (Text -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
Text
-> HeaderSection
-> (Text -> (Definition, Definition))
-> CompilerM op s ()
publicDef_ Text
"context_clear_caches" HeaderSection
MiscDecl ((Text -> (Definition, Definition)) -> CompilerM op s ())
-> (Text -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \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
  Type
ctx_ty <- CompilerM op s Type
forall op s. CompilerM op s Type
contextType
  [FieldGroup]
const_fields <- (Param -> CompilerM op s FieldGroup)
-> [Param] -> CompilerM op s [FieldGroup]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Param -> CompilerM op s FieldGroup
forall {op} {s}. Param -> CompilerM op s FieldGroup
constParamField [Param]
ps
  Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
earlyDecl [C.cedecl|struct constants { int dummy; $sdecls:const_fields };|]

  CompilerM op s () -> CompilerM op s ()
forall op s a. CompilerM op s a -> CompilerM op s a
inNewFunction (CompilerM op s () -> CompilerM op s ())
-> CompilerM op s () -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ 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 ([BlockItem]
defs, [BlockItem]
undefs) = [(BlockItem, BlockItem)] -> ([BlockItem], [BlockItem])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(BlockItem, BlockItem)] -> ([BlockItem], [BlockItem]))
-> [(BlockItem, BlockItem)] -> ([BlockItem], [BlockItem])
forall a b. (a -> b) -> a -> b
$ (Param -> (BlockItem, BlockItem))
-> [Param] -> [(BlockItem, BlockItem)]
forall a b. (a -> b) -> [a] -> [b]
map Param -> (BlockItem, BlockItem)
constMacro [Param]
ps
    [BlockItem]
init_consts' <- CompilerM op s () -> CompilerM op s [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect (CompilerM op s () -> CompilerM op s [BlockItem])
-> CompilerM op s () -> CompilerM op s [BlockItem]
forall a b. (a -> b) -> a -> b
$ do
      (Param -> CompilerM op s ()) -> [Param] -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Param -> CompilerM op s ()
forall {op} {s}. Param -> CompilerM op s ()
resetMemConst [Param]
ps
      Code op -> CompilerM op s ()
forall op s. Code op -> CompilerM op s ()
compileCode Code op
init_consts
    [BlockItem]
decl_mem <- CompilerM op s [BlockItem]
forall op s. CompilerM op s [BlockItem]
declAllocatedMem
    [BlockItem]
free_mem <- CompilerM op s [BlockItem]
forall op s. CompilerM op s [BlockItem]
freeAllocatedMem
    Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
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;
      }|]

  CompilerM op s () -> CompilerM op s ()
forall op s a. CompilerM op s a -> CompilerM op s a
inNewFunction (CompilerM op s () -> CompilerM op s ())
-> CompilerM op s () -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ do
    [BlockItem]
free_consts <- CompilerM op s () -> CompilerM op s [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect (CompilerM op s () -> CompilerM op s [BlockItem])
-> CompilerM op s () -> CompilerM op s [BlockItem]
forall a b. (a -> b) -> a -> b
$ (Param -> CompilerM op s ()) -> [Param] -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Param -> CompilerM op s ()
forall {op} {s}. Param -> CompilerM op s ()
freeConst [Param]
ps
    Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
libDecl
      [C.cedecl|static int free_constants($ty:ctx_ty *ctx) {
        (void)ctx;
        $items:free_consts
        return 0;
      }|]

  (Param -> CompilerM op s BlockItem)
-> [Param] -> CompilerM op s [BlockItem]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Param -> CompilerM op s BlockItem
forall {op} {s}. Param -> CompilerM op s BlockItem
getConst [Param]
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
      Type
ty <- VName -> Space -> CompilerM op s Type
forall op s. VName -> Space -> CompilerM op s Type
memToCType VName
name Space
space
      FieldGroup -> CompilerM op s FieldGroup
forall a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
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
      Type
ty <- VName -> Space -> CompilerM op s Type
forall op s. VName -> Space -> CompilerM op s Type
memToCType VName
name Space
space
      BlockItem -> CompilerM op s BlockItem
forall a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.citem|$ty:ty $id:name = ctx->constants->$id:name;|]