{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

-- | C code generator.  This module can convert a correct ImpCode
-- program to an equivalent C program.
module Futhark.CodeGen.Backends.MulticoreC
  ( compileProg,
    GC.CParts (..),
    GC.asLibrary,
    GC.asExecutable,
    GC.asServer,
  )
where

import Control.Monad
import Data.FileEmbed
import qualified Data.Map as M
import Data.Maybe
import qualified Futhark.CodeGen.Backends.GenericC as GC
import Futhark.CodeGen.Backends.GenericC.Options
import Futhark.CodeGen.Backends.SimpleRep
import Futhark.CodeGen.ImpCode.Multicore
import qualified Futhark.CodeGen.ImpGen.Multicore as ImpGen
import Futhark.IR.MCMem (MCMem, Prog)
import Futhark.MonadFreshNames
import qualified Language.C.Quote.OpenCL as C
import qualified Language.C.Syntax as C

-- | Compile the program to ImpCode with multicore operations.
compileProg ::
  MonadFreshNames m =>
  Prog MCMem ->
  m (ImpGen.Warnings, GC.CParts)
compileProg :: forall (m :: * -> *).
MonadFreshNames m =>
Prog MCMem -> m (Warnings, CParts)
compileProg =
  (Definitions Multicore -> m CParts)
-> (Warnings, Definitions Multicore) -> m (Warnings, CParts)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
    ( [Char]
-> Operations Multicore ()
-> CompilerM Multicore () ()
-> [Char]
-> [Space]
-> [Option]
-> Definitions Multicore
-> m CParts
forall (m :: * -> *) op.
MonadFreshNames m =>
[Char]
-> Operations op ()
-> CompilerM op () ()
-> [Char]
-> [Space]
-> [Option]
-> Definitions op
-> m CParts
GC.compileProg
        [Char]
"multicore"
        Operations Multicore ()
operations
        CompilerM Multicore () ()
forall {op} {s}. CompilerM op s ()
generateContext
        [Char]
""
        [Space
DefaultSpace]
        [Option]
cliOptions
    )
    ((Warnings, Definitions Multicore) -> m (Warnings, CParts))
-> (Prog MCMem -> m (Warnings, Definitions Multicore))
-> Prog MCMem
-> m (Warnings, CParts)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Prog MCMem -> m (Warnings, Definitions Multicore)
forall (m :: * -> *).
MonadFreshNames m =>
Prog MCMem -> m (Warnings, Definitions Multicore)
ImpGen.compileProg
  where
    generateContext :: CompilerM op s ()
generateContext = do
      let scheduler_h :: [Char]
scheduler_h = $(embedStringFile "rts/c/scheduler.h")
      (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 ()
GC.earlyDecl [C.cunit|$esc:scheduler_h|]

      [Char]
cfg <- [Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s [Char]
forall op s.
[Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s [Char]
GC.publicDef [Char]
"context_config" HeaderSection
GC.InitDecl (([Char] -> (Definition, Definition)) -> CompilerM op s [Char])
-> ([Char] -> (Definition, Definition)) -> CompilerM op s [Char]
forall a b. (a -> b) -> a -> b
$ \[Char]
s ->
        ( [C.cedecl|struct $id:s;|],
          [C.cedecl|struct $id:s { int debugging;
                                   int profiling;
                                   int num_threads;
                                 };|]
        )

      [Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
[Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s ()
GC.publicDef_ [Char]
"context_config_new" HeaderSection
GC.InitDecl (([Char] -> (Definition, Definition)) -> CompilerM op s ())
-> ([Char] -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \[Char]
s ->
        ( [C.cedecl|struct $id:cfg* $id:s(void);|],
          [C.cedecl|struct $id:cfg* $id:s(void) {
                                 struct $id:cfg *cfg = (struct $id:cfg*) malloc(sizeof(struct $id:cfg));
                                 if (cfg == NULL) {
                                   return NULL;
                                 }
                                 cfg->debugging = 0;
                                 cfg->profiling = 0;
                                 cfg->num_threads = 0;
                                 return cfg;
                               }|]
        )

      [Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
[Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s ()
GC.publicDef_ [Char]
"context_config_free" HeaderSection
GC.InitDecl (([Char] -> (Definition, Definition)) -> CompilerM op s ())
-> ([Char] -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \[Char]
s ->
        ( [C.cedecl|void $id:s(struct $id:cfg* cfg);|],
          [C.cedecl|void $id:s(struct $id:cfg* cfg) {
                                 free(cfg);
                               }|]
        )

      [Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
[Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s ()
GC.publicDef_ [Char]
"context_config_set_debugging" HeaderSection
GC.InitDecl (([Char] -> (Definition, Definition)) -> CompilerM op s ())
-> ([Char] -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \[Char]
s ->
        ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|],
          [C.cedecl|void $id:s(struct $id:cfg* cfg, int detail) {
                          cfg->debugging = detail;
                        }|]
        )

      [Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
[Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s ()
GC.publicDef_ [Char]
"context_config_set_profiling" HeaderSection
GC.InitDecl (([Char] -> (Definition, Definition)) -> CompilerM op s ())
-> ([Char] -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \[Char]
s ->
        ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|],
          [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag) {
                          cfg->profiling = flag;
                        }|]
        )

      [Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
[Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s ()
GC.publicDef_ [Char]
"context_config_set_logging" HeaderSection
GC.InitDecl (([Char] -> (Definition, Definition)) -> CompilerM op s ())
-> ([Char] -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \[Char]
s ->
        ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|],
          [C.cedecl|void $id:s(struct $id:cfg* cfg, int detail) {
                                 /* Does nothing for this backend. */
                                 (void)cfg; (void)detail;
                               }|]
        )

      [Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
[Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s ()
GC.publicDef_ [Char]
"context_config_set_num_threads" HeaderSection
GC.InitDecl (([Char] -> (Definition, Definition)) -> CompilerM op s ())
-> ([Char] -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \[Char]
s ->
        ( [C.cedecl|void $id:s(struct $id:cfg *cfg, int n);|],
          [C.cedecl|void $id:s(struct $id:cfg *cfg, int n) {
                                 cfg->num_threads = n;
                               }|]
        )

      ([FieldGroup]
fields, [Stm]
init_fields) <- CompilerM op s ([FieldGroup], [Stm])
forall op s. CompilerM op s ([FieldGroup], [Stm])
GC.contextContents

      [Char]
ctx <- [Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s [Char]
forall op s.
[Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s [Char]
GC.publicDef [Char]
"context" HeaderSection
GC.InitDecl (([Char] -> (Definition, Definition)) -> CompilerM op s [Char])
-> ([Char] -> (Definition, Definition)) -> CompilerM op s [Char]
forall a b. (a -> b) -> a -> b
$ \[Char]
s ->
        ( [C.cedecl|struct $id:s;|],
          [C.cedecl|struct $id:s {
                          struct scheduler scheduler;
                          int detail_memory;
                          int debugging;
                          int profiling;
                          int profiling_paused;
                          int logging;
                          typename lock_t lock;
                          char *error;
                          typename FILE *log;
                          int total_runs;
                          long int total_runtime;
                          $sdecls:fields

                          // Tuning parameters
                          typename int64_t tuning_timing;
                          typename int64_t tuning_iter;
                        };|]
        )

      [Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
[Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s ()
GC.publicDef_ [Char]
"context_new" HeaderSection
GC.InitDecl (([Char] -> (Definition, Definition)) -> CompilerM op s ())
-> ([Char] -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \[Char]
s ->
        ( [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg);|],
          [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg) {
                 struct $id:ctx* ctx = (struct $id:ctx*) malloc(sizeof(struct $id:ctx));
                 if (ctx == NULL) {
                   return NULL;
                 }

                 // Initialize rand()
                 fast_srand(time(0));
                 ctx->detail_memory = cfg->debugging;
                 ctx->debugging = cfg->debugging;
                 ctx->profiling = cfg->profiling;
                 ctx->profiling_paused = 0;
                 ctx->logging = 0;
                 ctx->error = NULL;
                 ctx->log = stderr;
                 create_lock(&ctx->lock);

                 int tune_kappa = 0;
                 double kappa = 5.1f * 1000;

                 if (tune_kappa) {
                   if (determine_kappa(&kappa) != 0) {
                     return NULL;
                   }
                 }

                 if (scheduler_init(&ctx->scheduler,
                                    cfg->num_threads > 0 ?
                                    cfg->num_threads : num_processors(),
                                    kappa) != 0) {
                   return NULL;
                 }

                 $stms:init_fields

                 init_constants(ctx);

                 return ctx;
              }|]
        )

      [Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
[Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s ()
GC.publicDef_ [Char]
"context_free" HeaderSection
GC.InitDecl (([Char] -> (Definition, Definition)) -> CompilerM op s ())
-> ([Char] -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \[Char]
s ->
        ( [C.cedecl|void $id:s(struct $id:ctx* ctx);|],
          [C.cedecl|void $id:s(struct $id:ctx* ctx) {
                 free_constants(ctx);
                 (void)scheduler_destroy(&ctx->scheduler);
                 free_lock(&ctx->lock);
                 free(ctx);
               }|]
        )

      [Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
[Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s ()
GC.publicDef_ [Char]
"context_sync" HeaderSection
GC.InitDecl (([Char] -> (Definition, Definition)) -> CompilerM op s ())
-> ([Char] -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \[Char]
s ->
        ( [C.cedecl|int $id:s(struct $id:ctx* ctx);|],
          [C.cedecl|int $id:s(struct $id:ctx* ctx) {
                                 (void)ctx;
                                 return 0;
                               }|]
        )

      Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
GC.earlyDecl [C.cedecl|static const char *size_names[0];|]
      Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
GC.earlyDecl [C.cedecl|static const char *size_vars[0];|]
      Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
GC.earlyDecl [C.cedecl|static const char *size_classes[0];|]

      [Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
[Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s ()
GC.publicDef_ [Char]
"context_config_set_size" HeaderSection
GC.InitDecl (([Char] -> (Definition, Definition)) -> CompilerM op s ())
-> ([Char] -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \[Char]
s ->
        ( [C.cedecl|int $id:s(struct $id:cfg* cfg, const char *size_name, size_t size_value);|],
          [C.cedecl|int $id:s(struct $id:cfg* cfg, const char *size_name, size_t size_value) {
                         (void)cfg; (void)size_name; (void)size_value;
                         return 1;
                       }|]
        )

cliOptions :: [Option]
cliOptions :: [Option]
cliOptions =
  [ Option :: [Char] -> Maybe Char -> OptionArgument -> [Char] -> Stm -> Option
Option
      { optionLongName :: [Char]
optionLongName = [Char]
"profile",
        optionShortName :: Maybe Char
optionShortName = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'P',
        optionArgument :: OptionArgument
optionArgument = OptionArgument
NoArgument,
        optionAction :: Stm
optionAction = [C.cstm|futhark_context_config_set_profiling(cfg, 1);|],
        optionDescription :: [Char]
optionDescription = [Char]
"Gather profiling information."
      },
    Option :: [Char] -> Maybe Char -> OptionArgument -> [Char] -> Stm -> Option
Option
      { optionLongName :: [Char]
optionLongName = [Char]
"num-threads",
        optionShortName :: Maybe Char
optionShortName = Maybe Char
forall a. Maybe a
Nothing,
        optionArgument :: OptionArgument
optionArgument = [Char] -> OptionArgument
RequiredArgument [Char]
"INT",
        optionAction :: Stm
optionAction = [C.cstm|futhark_context_config_set_num_threads(cfg, atoi(optarg));|],
        optionDescription :: [Char]
optionDescription = [Char]
"Set number of threads used for execution."
      }
  ]

operations :: GC.Operations Multicore ()
operations :: Operations Multicore ()
operations =
  Operations Multicore ()
forall op s. Operations op s
GC.defaultOperations
    { opsCompiler :: OpCompiler Multicore ()
GC.opsCompiler = OpCompiler Multicore ()
compileOp,
      opsCritical :: ([BlockItem], [BlockItem])
GC.opsCritical =
        -- The thread entering an API function is always considered
        -- the "first worker" - note that this might differ from the
        -- thread that created the context!  This likely only matters
        -- for entry points, since they are the only API functions
        -- that contain parallel operations.
        ( [C.citems|worker_local = &ctx->scheduler.workers[0];|],
          []
        )
    }

closureFreeStructField :: VName -> Name
closureFreeStructField :: VName -> Name
closureFreeStructField VName
v =
  [Char] -> Name
nameFromString [Char]
"free_" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> [Char] -> Name
nameFromString (VName -> [Char]
forall a. Pretty a => a -> [Char]
pretty VName
v)

closureRetvalStructField :: VName -> Name
closureRetvalStructField :: VName -> Name
closureRetvalStructField VName
v =
  [Char] -> Name
nameFromString [Char]
"retval_" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> [Char] -> Name
nameFromString (VName -> [Char]
forall a. Pretty a => a -> [Char]
pretty VName
v)

data ValueType = Prim | MemBlock | RawMem

compileFreeStructFields :: [VName] -> [(C.Type, ValueType)] -> [C.FieldGroup]
compileFreeStructFields :: [VName] -> [(Type, ValueType)] -> [FieldGroup]
compileFreeStructFields = (VName -> (Type, ValueType) -> FieldGroup)
-> [VName] -> [(Type, ValueType)] -> [FieldGroup]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith VName -> (Type, ValueType) -> FieldGroup
field
  where
    field :: VName -> (Type, ValueType) -> FieldGroup
field VName
name (Type
ty, ValueType
Prim) =
      [C.csdecl|$ty:ty $id:(closureFreeStructField name);|]
    field VName
name (Type
_, ValueType
_) =
      [C.csdecl|$ty:defaultMemBlockType $id:(closureFreeStructField name);|]

compileRetvalStructFields :: [VName] -> [(C.Type, ValueType)] -> [C.FieldGroup]
compileRetvalStructFields :: [VName] -> [(Type, ValueType)] -> [FieldGroup]
compileRetvalStructFields = (VName -> (Type, ValueType) -> FieldGroup)
-> [VName] -> [(Type, ValueType)] -> [FieldGroup]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith VName -> (Type, ValueType) -> FieldGroup
field
  where
    field :: VName -> (Type, ValueType) -> FieldGroup
field VName
name (Type
ty, ValueType
Prim) =
      [C.csdecl|$ty:ty *$id:(closureRetvalStructField name);|]
    field VName
name (Type
_, ValueType
_) =
      [C.csdecl|$ty:defaultMemBlockType $id:(closureRetvalStructField name);|]

compileSetStructValues ::
  C.ToIdent a =>
  a ->
  [VName] ->
  [(C.Type, ValueType)] ->
  [C.Stm]
compileSetStructValues :: forall a. ToIdent a => a -> [VName] -> [(Type, ValueType)] -> [Stm]
compileSetStructValues a
struct = (VName -> (Type, ValueType) -> Stm)
-> [VName] -> [(Type, ValueType)] -> [Stm]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith VName -> (Type, ValueType) -> Stm
forall {a}. VName -> (a, ValueType) -> Stm
field
  where
    field :: VName -> (a, ValueType) -> Stm
field VName
name (a
_, ValueType
Prim) =
      [C.cstm|$id:struct.$id:(closureFreeStructField name)=$id:name;|]
    field VName
name (a
_, ValueType
MemBlock) =
      [C.cstm|$id:struct.$id:(closureFreeStructField name)=$id:name.mem;|]
    field VName
name (a
_, ValueType
RawMem) =
      [C.cstm|$id:struct.$id:(closureFreeStructField name)=$id:name;|]

compileSetRetvalStructValues ::
  C.ToIdent a =>
  a ->
  [VName] ->
  [(C.Type, ValueType)] ->
  [C.Stm]
compileSetRetvalStructValues :: forall a. ToIdent a => a -> [VName] -> [(Type, ValueType)] -> [Stm]
compileSetRetvalStructValues a
struct = (VName -> (Type, ValueType) -> Stm)
-> [VName] -> [(Type, ValueType)] -> [Stm]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith VName -> (Type, ValueType) -> Stm
forall {a}. VName -> (a, ValueType) -> Stm
field
  where
    field :: VName -> (a, ValueType) -> Stm
field VName
name (a
_, ValueType
Prim) =
      [C.cstm|$id:struct.$id:(closureRetvalStructField name)=&$id:name;|]
    field VName
name (a
_, ValueType
MemBlock) =
      [C.cstm|$id:struct.$id:(closureRetvalStructField name)=$id:name.mem;|]
    field VName
name (a
_, ValueType
RawMem) =
      [C.cstm|$id:struct.$id:(closureRetvalStructField name)=$id:name;|]

compileGetRetvalStructVals :: C.ToIdent a => a -> [VName] -> [(C.Type, ValueType)] -> [C.InitGroup]
compileGetRetvalStructVals :: forall a.
ToIdent a =>
a -> [VName] -> [(Type, ValueType)] -> [InitGroup]
compileGetRetvalStructVals a
struct = (VName -> (Type, ValueType) -> InitGroup)
-> [VName] -> [(Type, ValueType)] -> [InitGroup]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith VName -> (Type, ValueType) -> InitGroup
field
  where
    field :: VName -> (Type, ValueType) -> InitGroup
field VName
name (Type
ty, ValueType
Prim) =
      [C.cdecl|$ty:ty $id:name = *$id:struct->$id:(closureRetvalStructField name);|]
    field VName
name (Type
ty, ValueType
_) =
      [C.cdecl|$ty:ty $id:name =
                 {.desc = $string:(pretty name),
                 .mem = $id:struct->$id:(closureRetvalStructField name),
                 .size = 0, .references = NULL};|]

compileGetStructVals ::
  C.ToIdent a =>
  a ->
  [VName] ->
  [(C.Type, ValueType)] ->
  [C.InitGroup]
compileGetStructVals :: forall a.
ToIdent a =>
a -> [VName] -> [(Type, ValueType)] -> [InitGroup]
compileGetStructVals a
struct = (VName -> (Type, ValueType) -> InitGroup)
-> [VName] -> [(Type, ValueType)] -> [InitGroup]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith VName -> (Type, ValueType) -> InitGroup
field
  where
    field :: VName -> (Type, ValueType) -> InitGroup
field VName
name (Type
ty, ValueType
Prim) =
      [C.cdecl|$ty:ty $id:name = $id:struct->$id:(closureFreeStructField name);|]
    field VName
name (Type
ty, ValueType
_) =
      [C.cdecl|$ty:ty $id:name =
                 {.desc = $string:(pretty name),
                  .mem = $id:struct->$id:(closureFreeStructField name),
                  .size = 0, .references = NULL};|]

compileWriteBackResVals :: C.ToIdent a => a -> [VName] -> [(C.Type, ValueType)] -> [C.Stm]
compileWriteBackResVals :: forall a. ToIdent a => a -> [VName] -> [(Type, ValueType)] -> [Stm]
compileWriteBackResVals a
struct = (VName -> (Type, ValueType) -> Stm)
-> [VName] -> [(Type, ValueType)] -> [Stm]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith VName -> (Type, ValueType) -> Stm
forall {a}. VName -> (a, ValueType) -> Stm
field
  where
    field :: VName -> (a, ValueType) -> Stm
field VName
name (a
_, ValueType
Prim) =
      [C.cstm|*$id:struct->$id:(closureRetvalStructField name) = $id:name;|]
    field VName
name (a
_, ValueType
_) =
      [C.cstm|$id:struct->$id:(closureRetvalStructField name) = $id:name.mem;|]

paramToCType :: Param -> GC.CompilerM op s (C.Type, ValueType)
paramToCType :: forall op s. Param -> CompilerM op s (Type, ValueType)
paramToCType (ScalarParam VName
_ PrimType
pt) = do
  let t :: Type
t = PrimType -> Type
GC.primTypeToCType PrimType
pt
  (Type, ValueType) -> CompilerM op s (Type, ValueType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
t, ValueType
Prim)
paramToCType (MemParam VName
name Space
space') = VName -> Space -> CompilerM op s (Type, ValueType)
forall op s. VName -> Space -> CompilerM op s (Type, ValueType)
mcMemToCType VName
name Space
space'

mcMemToCType :: VName -> Space -> GC.CompilerM op s (C.Type, ValueType)
mcMemToCType :: forall op s. VName -> Space -> CompilerM op s (Type, ValueType)
mcMemToCType VName
v Space
space = do
  Bool
refcount <- Space -> CompilerM op s Bool
forall op s. Space -> CompilerM op s Bool
GC.fatMemory Space
space
  Bool
cached <- Maybe VName -> Bool
forall a. Maybe a -> Bool
isJust (Maybe VName -> Bool)
-> CompilerM op s (Maybe VName) -> CompilerM op s Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> CompilerM op s (Maybe VName)
forall a op s. ToExp a => a -> CompilerM op s (Maybe VName)
GC.cacheMem VName
v
  (Type, ValueType) -> CompilerM op s (Type, ValueType)
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( Space -> Type
GC.fatMemType Space
space,
      if Bool
refcount Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
cached
        then ValueType
MemBlock
        else ValueType
RawMem
    )

functionRuntime :: Name -> C.Id
functionRuntime :: Name -> Id
functionRuntime = (Name -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
`C.toIdent` SrcLoc
forall a. Monoid a => a
mempty) (Name -> Id) -> (Name -> Name) -> Name -> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_total_runtime")

functionRuns :: Name -> C.Id
functionRuns :: Name -> Id
functionRuns = (Name -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
`C.toIdent` SrcLoc
forall a. Monoid a => a
mempty) (Name -> Id) -> (Name -> Name) -> Name -> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_runs")

functionIter :: Name -> C.Id
functionIter :: Name -> Id
functionIter = (Name -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
`C.toIdent` SrcLoc
forall a. Monoid a => a
mempty) (Name -> Id) -> (Name -> Name) -> Name -> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_iter")

multiCoreReport :: [(Name, Bool)] -> [C.BlockItem]
multiCoreReport :: [(Name, Bool)] -> [BlockItem]
multiCoreReport [(Name, Bool)]
names = [BlockItem]
report_kernels
  where
    report_kernels :: [BlockItem]
report_kernels = ((Name, Bool) -> [BlockItem]) -> [(Name, Bool)] -> [BlockItem]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name, Bool) -> [BlockItem]
reportKernel [(Name, Bool)]
names
    max_name_len_pad :: Int
max_name_len_pad = Int
40
    format_string :: Name -> Bool -> [Char]
format_string Name
name Bool
True =
      let name_s :: [Char]
name_s = Name -> [Char]
nameToString Name
name
          padding :: [Char]
padding = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
max_name_len_pad Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
name_s) Char
' '
       in [[Char]] -> [Char]
unwords [[Char]
"tid %2d -", [Char]
name_s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
padding, [Char]
"ran %10d times; avg: %10ldus; total: %10ldus; time pr. iter %9.6f; iters %9ld; avg %ld\n"]
    format_string Name
name Bool
False =
      let name_s :: [Char]
name_s = Name -> [Char]
nameToString Name
name
          padding :: [Char]
padding = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
max_name_len_pad Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
name_s) Char
' '
       in [[Char]] -> [Char]
unwords [[Char]
"        ", [Char]
name_s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
padding, [Char]
"ran %10d times; avg: %10ldus; total: %10ldus; time pr. iter %9.6f; iters %9ld; avg %ld\n"]
    reportKernel :: (Name, Bool) -> [BlockItem]
reportKernel (Name
name, Bool
is_array) =
      let runs :: Id
runs = Name -> Id
functionRuns Name
name
          total_runtime :: Id
total_runtime = Name -> Id
functionRuntime Name
name
          iters :: Id
iters = Name -> Id
functionIter Name
name
       in if Bool
is_array
            then
              [ [C.citem|
                     for (int i = 0; i < ctx->scheduler.num_threads; i++) {
                       fprintf(ctx->log,
                         $string:(format_string name is_array),
                         i,
                         ctx->$id:runs[i],
                         (long int) ctx->$id:total_runtime[i] / (ctx->$id:runs[i] != 0 ? ctx->$id:runs[i] : 1),
                         (long int) ctx->$id:total_runtime[i],
                         (double) ctx->$id:total_runtime[i] /  (ctx->$id:iters[i] == 0 ? 1 : (double)ctx->$id:iters[i]),
                         (long int) (ctx->$id:iters[i]),
                         (long int) (ctx->$id:iters[i]) / (ctx->$id:runs[i] != 0 ? ctx->$id:runs[i] : 1)
                         );
                     }
                   |]
              ]
            else
              [ [C.citem|
                    fprintf(ctx->log,
                       $string:(format_string name is_array),
                       ctx->$id:runs,
                       (long int) ctx->$id:total_runtime / (ctx->$id:runs != 0 ? ctx->$id:runs : 1),
                       (long int) ctx->$id:total_runtime,
                       (double) ctx->$id:total_runtime /  (ctx->$id:iters == 0 ? 1 : (double)ctx->$id:iters),
                       (long int) (ctx->$id:iters),
                       (long int) (ctx->$id:iters) / (ctx->$id:runs != 0 ? ctx->$id:runs : 1));
                   |],
                [C.citem|ctx->total_runtime += ctx->$id:total_runtime;|],
                [C.citem|ctx->total_runs += ctx->$id:runs;|]
              ]

addBenchmarkFields :: Name -> Maybe VName -> GC.CompilerM op s ()
addBenchmarkFields :: forall op s. Name -> Maybe VName -> CompilerM op s ()
addBenchmarkFields Name
name (Just VName
_) = do
  Id -> Type -> Maybe Exp -> CompilerM op s ()
forall op s. Id -> Type -> Maybe Exp -> CompilerM op s ()
GC.contextField (Name -> Id
functionRuntime Name
name) [C.cty|typename int64_t*|] (Maybe Exp -> CompilerM op s ()) -> Maybe Exp -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ Exp -> Maybe Exp
forall a. a -> Maybe a
Just [C.cexp|calloc(sizeof(typename int64_t), ctx->scheduler.num_threads)|]
  Id -> Type -> Maybe Exp -> CompilerM op s ()
forall op s. Id -> Type -> Maybe Exp -> CompilerM op s ()
GC.contextField (Name -> Id
functionRuns Name
name) [C.cty|int*|] (Maybe Exp -> CompilerM op s ()) -> Maybe Exp -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ Exp -> Maybe Exp
forall a. a -> Maybe a
Just [C.cexp|calloc(sizeof(int), ctx->scheduler.num_threads)|]
  Id -> Type -> Maybe Exp -> CompilerM op s ()
forall op s. Id -> Type -> Maybe Exp -> CompilerM op s ()
GC.contextField (Name -> Id
functionIter Name
name) [C.cty|typename int64_t*|] (Maybe Exp -> CompilerM op s ()) -> Maybe Exp -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ Exp -> Maybe Exp
forall a. a -> Maybe a
Just [C.cexp|calloc(sizeof(sizeof(typename int64_t)), ctx->scheduler.num_threads)|]
addBenchmarkFields Name
name Maybe VName
Nothing = do
  Id -> Type -> Maybe Exp -> CompilerM op s ()
forall op s. Id -> Type -> Maybe Exp -> CompilerM op s ()
GC.contextField (Name -> Id
functionRuntime Name
name) [C.cty|typename int64_t|] (Maybe Exp -> CompilerM op s ()) -> Maybe Exp -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ Exp -> Maybe Exp
forall a. a -> Maybe a
Just [C.cexp|0|]
  Id -> Type -> Maybe Exp -> CompilerM op s ()
forall op s. Id -> Type -> Maybe Exp -> CompilerM op s ()
GC.contextField (Name -> Id
functionRuns Name
name) [C.cty|int|] (Maybe Exp -> CompilerM op s ()) -> Maybe Exp -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ Exp -> Maybe Exp
forall a. a -> Maybe a
Just [C.cexp|0|]
  Id -> Type -> Maybe Exp -> CompilerM op s ()
forall op s. Id -> Type -> Maybe Exp -> CompilerM op s ()
GC.contextField (Name -> Id
functionIter Name
name) [C.cty|typename int64_t|] (Maybe Exp -> CompilerM op s ()) -> Maybe Exp -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ Exp -> Maybe Exp
forall a. a -> Maybe a
Just [C.cexp|0|]

benchmarkCode :: Name -> Maybe VName -> [C.BlockItem] -> GC.CompilerM op s [C.BlockItem]
benchmarkCode :: forall op s.
Name -> Maybe VName -> [BlockItem] -> CompilerM op s [BlockItem]
benchmarkCode Name
name Maybe VName
tid [BlockItem]
code = do
  Name -> Maybe VName -> CompilerM op s ()
forall op s. Name -> Maybe VName -> CompilerM op s ()
addBenchmarkFields Name
name Maybe VName
tid
  [BlockItem] -> CompilerM op s [BlockItem]
forall (m :: * -> *) a. Monad m => a -> m a
return
    [C.citems|
     typename uint64_t $id:start = 0;
     if (ctx->profiling && !ctx->profiling_paused) {
       $id:start = get_wall_time();
     }
     $items:code
     if (ctx->profiling && !ctx->profiling_paused) {
       typename uint64_t $id:end = get_wall_time();
       typename uint64_t elapsed = $id:end - $id:start;
       $items:(updateFields tid)
     }
     |]
  where
    start :: Name
start = Name
name Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_start"
    end :: Name
end = Name
name Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_end"
    updateFields :: Maybe a -> [BlockItem]
updateFields Maybe a
Nothing =
      [C.citems|__atomic_fetch_add(&ctx->$id:(functionRuns name), 1, __ATOMIC_RELAXED);
                                            __atomic_fetch_add(&ctx->$id:(functionRuntime name), elapsed, __ATOMIC_RELAXED);
                                            __atomic_fetch_add(&ctx->$id:(functionIter name), iterations, __ATOMIC_RELAXED);|]
    updateFields (Just a
_tid') =
      [C.citems|ctx->$id:(functionRuns name)[tid]++;
                                            ctx->$id:(functionRuntime name)[tid] += elapsed;
                                            ctx->$id:(functionIter name)[tid] += iterations;|]

functionTiming :: Name -> C.Id
functionTiming :: Name -> Id
functionTiming = (Name -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
`C.toIdent` SrcLoc
forall a. Monoid a => a
mempty) (Name -> Id) -> (Name -> Name) -> Name -> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_total_time")

functionIterations :: Name -> C.Id
functionIterations :: Name -> Id
functionIterations = (Name -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
`C.toIdent` SrcLoc
forall a. Monoid a => a
mempty) (Name -> Id) -> (Name -> Name) -> Name -> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_total_iter")

addTimingFields :: Name -> GC.CompilerM op s ()
addTimingFields :: forall op s. Name -> CompilerM op s ()
addTimingFields Name
name = do
  Id -> Type -> Maybe Exp -> CompilerM op s ()
forall op s. Id -> Type -> Maybe Exp -> CompilerM op s ()
GC.contextField (Name -> Id
functionTiming Name
name) [C.cty|typename int64_t|] (Maybe Exp -> CompilerM op s ()) -> Maybe Exp -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ Exp -> Maybe Exp
forall a. a -> Maybe a
Just [C.cexp|0|]
  Id -> Type -> Maybe Exp -> CompilerM op s ()
forall op s. Id -> Type -> Maybe Exp -> CompilerM op s ()
GC.contextField (Name -> Id
functionIterations Name
name) [C.cty|typename int64_t|] (Maybe Exp -> CompilerM op s ()) -> Maybe Exp -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ Exp -> Maybe Exp
forall a. a -> Maybe a
Just [C.cexp|0|]

multicoreName :: String -> GC.CompilerM op s Name
multicoreName :: forall op s. [Char] -> CompilerM op s Name
multicoreName [Char]
s = do
  VName
s' <- [Char] -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => [Char] -> m VName
newVName ([Char]
"futhark_mc_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s)
  Name -> CompilerM op s Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> CompilerM op s Name) -> Name -> CompilerM op s Name
forall a b. (a -> b) -> a -> b
$ [Char] -> Name
nameFromString ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ VName -> [Char]
baseString VName
s' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (VName -> Int
baseTag VName
s')

multicoreDef :: String -> (Name -> GC.CompilerM op s C.Definition) -> GC.CompilerM op s Name
multicoreDef :: forall op s.
[Char]
-> (Name -> CompilerM op s Definition) -> CompilerM op s Name
multicoreDef [Char]
s Name -> CompilerM op s Definition
f = do
  Name
s' <- [Char] -> CompilerM op s Name
forall op s. [Char] -> CompilerM op s Name
multicoreName [Char]
s
  Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
GC.libDecl (Definition -> CompilerM op s ())
-> CompilerM op s Definition -> CompilerM op s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> CompilerM op s Definition
f Name
s'
  Name -> CompilerM op s Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
s'

generateParLoopFn ::
  C.ToIdent a =>
  M.Map VName Space ->
  String ->
  Code ->
  a ->
  [(VName, (C.Type, ValueType))] ->
  [(VName, (C.Type, ValueType))] ->
  VName ->
  VName ->
  GC.CompilerM Multicore s Name
generateParLoopFn :: forall a s.
ToIdent a =>
Map VName Space
-> [Char]
-> Code
-> a
-> [(VName, (Type, ValueType))]
-> [(VName, (Type, ValueType))]
-> VName
-> VName
-> CompilerM Multicore s Name
generateParLoopFn Map VName Space
lexical [Char]
basename Code
code a
fstruct [(VName, (Type, ValueType))]
free [(VName, (Type, ValueType))]
retval VName
tid VName
ntasks = do
  let ([VName]
fargs, [(Type, ValueType)]
fctypes) = [(VName, (Type, ValueType))] -> ([VName], [(Type, ValueType)])
forall a b. [(a, b)] -> ([a], [b])
unzip [(VName, (Type, ValueType))]
free
  let ([VName]
retval_args, [(Type, ValueType)]
retval_ctypes) = [(VName, (Type, ValueType))] -> ([VName], [(Type, ValueType)])
forall a b. [(a, b)] -> ([a], [b])
unzip [(VName, (Type, ValueType))]
retval
  [Char]
-> (Name -> CompilerM Multicore s Definition)
-> CompilerM Multicore s Name
forall op s.
[Char]
-> (Name -> CompilerM op s Definition) -> CompilerM op s Name
multicoreDef [Char]
basename ((Name -> CompilerM Multicore s Definition)
 -> CompilerM Multicore s Name)
-> (Name -> CompilerM Multicore s Definition)
-> CompilerM Multicore s Name
forall a b. (a -> b) -> a -> b
$ \Name
s -> do
    [BlockItem]
fbody <- Name
-> Maybe VName -> [BlockItem] -> CompilerM Multicore s [BlockItem]
forall op s.
Name -> Maybe VName -> [BlockItem] -> CompilerM op s [BlockItem]
benchmarkCode Name
s (VName -> Maybe VName
forall a. a -> Maybe a
Just VName
tid) ([BlockItem] -> CompilerM Multicore s [BlockItem])
-> (CompilerM Multicore s [BlockItem]
    -> CompilerM Multicore s [BlockItem])
-> CompilerM Multicore s [BlockItem]
-> CompilerM Multicore s [BlockItem]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Bool
-> CompilerM Multicore s [BlockItem]
-> CompilerM Multicore s [BlockItem]
forall op s a. Bool -> CompilerM op s a -> CompilerM op s a
GC.inNewFunction Bool
False (CompilerM Multicore s [BlockItem]
 -> CompilerM Multicore s [BlockItem])
-> CompilerM Multicore s [BlockItem]
-> CompilerM Multicore s [BlockItem]
forall a b. (a -> b) -> a -> b
$
      Map VName Space
-> ([BlockItem] -> [Stm] -> CompilerM Multicore s [BlockItem])
-> CompilerM Multicore s [BlockItem]
forall op s a.
Map VName Space
-> ([BlockItem] -> [Stm] -> CompilerM op s a) -> CompilerM op s a
GC.cachingMemory Map VName Space
lexical (([BlockItem] -> [Stm] -> CompilerM Multicore s [BlockItem])
 -> CompilerM Multicore s [BlockItem])
-> ([BlockItem] -> [Stm] -> CompilerM Multicore s [BlockItem])
-> CompilerM Multicore s [BlockItem]
forall a b. (a -> b) -> a -> b
$
        \[BlockItem]
decl_cached [Stm]
free_cached -> CompilerM Multicore s () -> CompilerM Multicore s [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
GC.blockScope (CompilerM Multicore s () -> CompilerM Multicore s [BlockItem])
-> CompilerM Multicore s () -> CompilerM Multicore s [BlockItem]
forall a b. (a -> b) -> a -> b
$ do
          (BlockItem -> CompilerM Multicore s ())
-> [BlockItem] -> CompilerM Multicore s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BlockItem -> CompilerM Multicore s ()
forall op s. BlockItem -> CompilerM op s ()
GC.item [C.citems|$decls:(compileGetStructVals fstruct fargs fctypes)|]
          (BlockItem -> CompilerM Multicore s ())
-> [BlockItem] -> CompilerM Multicore s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BlockItem -> CompilerM Multicore s ()
forall op s. BlockItem -> CompilerM op s ()
GC.item [C.citems|$decls:(compileGetRetvalStructVals fstruct retval_args retval_ctypes)|]
          (BlockItem -> CompilerM Multicore s ())
-> [BlockItem] -> CompilerM Multicore s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BlockItem -> CompilerM Multicore s ()
forall op s. BlockItem -> CompilerM op s ()
GC.item [BlockItem]
decl_cached
          [BlockItem]
code' <- CompilerM Multicore s () -> CompilerM Multicore s [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
GC.blockScope (CompilerM Multicore s () -> CompilerM Multicore s [BlockItem])
-> CompilerM Multicore s () -> CompilerM Multicore s [BlockItem]
forall a b. (a -> b) -> a -> b
$ Code -> CompilerM Multicore s ()
forall op s. Code op -> CompilerM op s ()
GC.compileCode Code
code
          (BlockItem -> CompilerM Multicore s ())
-> [BlockItem] -> CompilerM Multicore s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BlockItem -> CompilerM Multicore s ()
forall op s. BlockItem -> CompilerM op s ()
GC.item [C.citems|$items:code'|]
          (Stm -> CompilerM Multicore s ())
-> [Stm] -> CompilerM Multicore s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [Stm]
free_cached
    Definition -> CompilerM Multicore s Definition
forall (m :: * -> *) a. Monad m => a -> m a
return
      [C.cedecl|int $id:s(void *args, typename int64_t iterations, int tid, struct scheduler_info info) {
                           int err = 0;
                           int $id:tid = tid;
                           int $id:ntasks = info.nsubtasks;
                           struct $id:fstruct *$id:fstruct = (struct $id:fstruct*) args;
                           struct futhark_context *ctx = $id:fstruct->ctx;
                           $items:fbody
                           $stms:(compileWriteBackResVals fstruct retval_args retval_ctypes)
                           cleanup: {}
                           return err;
                      }|]

prepareTaskStruct ::
  String ->
  [VName] ->
  [(C.Type, ValueType)] ->
  [VName] ->
  [(C.Type, ValueType)] ->
  GC.CompilerM Multicore s Name
prepareTaskStruct :: forall s.
[Char]
-> [VName]
-> [(Type, ValueType)]
-> [VName]
-> [(Type, ValueType)]
-> CompilerM Multicore s Name
prepareTaskStruct [Char]
name [VName]
free_args [(Type, ValueType)]
free_ctypes [VName]
retval_args [(Type, ValueType)]
retval_ctypes = do
  Name
fstruct <- [Char]
-> (Name -> CompilerM Multicore s Definition)
-> CompilerM Multicore s Name
forall op s.
[Char]
-> (Name -> CompilerM op s Definition) -> CompilerM op s Name
multicoreDef [Char]
name ((Name -> CompilerM Multicore s Definition)
 -> CompilerM Multicore s Name)
-> (Name -> CompilerM Multicore s Definition)
-> CompilerM Multicore s Name
forall a b. (a -> b) -> a -> b
$ \Name
s ->
    Definition -> CompilerM Multicore s Definition
forall (m :: * -> *) a. Monad m => a -> m a
return
      [C.cedecl|struct $id:s {
                       struct futhark_context *ctx;
                       $sdecls:(compileFreeStructFields free_args free_ctypes)
                       $sdecls:(compileRetvalStructFields retval_args retval_ctypes)
                     };|]
  InitGroup -> CompilerM Multicore s ()
forall op s. InitGroup -> CompilerM op s ()
GC.decl [C.cdecl|struct $id:fstruct $id:fstruct;|]
  Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:fstruct.ctx = ctx;|]
  [Stm] -> CompilerM Multicore s ()
forall op s. [Stm] -> CompilerM op s ()
GC.stms [C.cstms|$stms:(compileSetStructValues fstruct free_args free_ctypes)|]
  [Stm] -> CompilerM Multicore s ()
forall op s. [Stm] -> CompilerM op s ()
GC.stms [C.cstms|$stms:(compileSetRetvalStructValues fstruct retval_args retval_ctypes)|]
  Name -> CompilerM Multicore s Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
fstruct

-- Generate a segop function for top_level and potentially nested SegOp code
compileOp :: GC.OpCompiler Multicore ()
compileOp :: OpCompiler Multicore ()
compileOp (Segop [Char]
name [Param]
params ParallelTask
seq_task Maybe ParallelTask
par_task [Param]
retvals (SchedulerInfo VName
nsubtask Exp
e Scheduling
sched)) = do
  let (ParallelTask Code
seq_code VName
tid) = ParallelTask
seq_task
  [(Type, ValueType)]
free_ctypes <- (Param -> CompilerM Multicore () (Type, ValueType))
-> [Param] -> CompilerM Multicore () [(Type, ValueType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Param -> CompilerM Multicore () (Type, ValueType)
forall op s. Param -> CompilerM op s (Type, ValueType)
paramToCType [Param]
params
  [(Type, ValueType)]
retval_ctypes <- (Param -> CompilerM Multicore () (Type, ValueType))
-> [Param] -> CompilerM Multicore () [(Type, ValueType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Param -> CompilerM Multicore () (Type, ValueType)
forall op s. Param -> CompilerM op s (Type, ValueType)
paramToCType [Param]
retvals
  let free_args :: [VName]
free_args = (Param -> VName) -> [Param] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map Param -> VName
paramName [Param]
params
      retval_args :: [VName]
retval_args = (Param -> VName) -> [Param] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map Param -> VName
paramName [Param]
retvals
      free :: [(VName, (Type, ValueType))]
free = [VName] -> [(Type, ValueType)] -> [(VName, (Type, ValueType))]
forall a b. [a] -> [b] -> [(a, b)]
zip [VName]
free_args [(Type, ValueType)]
free_ctypes
      retval :: [(VName, (Type, ValueType))]
retval = [VName] -> [(Type, ValueType)] -> [(VName, (Type, ValueType))]
forall a b. [a] -> [b] -> [(a, b)]
zip [VName]
retval_args [(Type, ValueType)]
retval_ctypes

  Exp
e' <- Exp -> CompilerM Multicore () Exp
forall op s. Exp -> CompilerM op s Exp
GC.compileExp Exp
e

  let lexical :: Map VName Space
lexical = Function Multicore -> Map VName Space
forall a. Function a -> Map VName Space
lexicalMemoryUsage (Function Multicore -> Map VName Space)
-> Function Multicore -> Map VName Space
forall a b. (a -> b) -> a -> b
$ Bool
-> [Param]
-> [Param]
-> Code
-> [ExternalValue]
-> [ExternalValue]
-> Function Multicore
forall a.
Bool
-> [Param]
-> [Param]
-> Code a
-> [ExternalValue]
-> [ExternalValue]
-> FunctionT a
Function Bool
False [] [Param]
params Code
seq_code [] []

  Name
fstruct <-
    [Char]
-> [VName]
-> [(Type, ValueType)]
-> [VName]
-> [(Type, ValueType)]
-> CompilerM Multicore () Name
forall s.
[Char]
-> [VName]
-> [(Type, ValueType)]
-> [VName]
-> [(Type, ValueType)]
-> CompilerM Multicore s Name
prepareTaskStruct [Char]
"task" [VName]
free_args [(Type, ValueType)]
free_ctypes [VName]
retval_args [(Type, ValueType)]
retval_ctypes

  Name
fpar_task <- Map VName Space
-> [Char]
-> Code
-> Name
-> [(VName, (Type, ValueType))]
-> [(VName, (Type, ValueType))]
-> VName
-> VName
-> CompilerM Multicore () Name
forall a s.
ToIdent a =>
Map VName Space
-> [Char]
-> Code
-> a
-> [(VName, (Type, ValueType))]
-> [(VName, (Type, ValueType))]
-> VName
-> VName
-> CompilerM Multicore s Name
generateParLoopFn Map VName Space
lexical ([Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_task") Code
seq_code Name
fstruct [(VName, (Type, ValueType))]
free [(VName, (Type, ValueType))]
retval VName
tid VName
nsubtask
  Name -> CompilerM Multicore () ()
forall op s. Name -> CompilerM op s ()
addTimingFields Name
fpar_task

  let ftask_name :: Name
ftask_name = Name
fstruct Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_task"
  InitGroup -> CompilerM Multicore () ()
forall op s. InitGroup -> CompilerM op s ()
GC.decl [C.cdecl|struct scheduler_segop $id:ftask_name;|]
  Stm -> CompilerM Multicore () ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.args = &$id:fstruct;|]
  Stm -> CompilerM Multicore () ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.top_level_fn = $id:fpar_task;|]
  Stm -> CompilerM Multicore () ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.name = $string:(nameToString fpar_task);|]
  Stm -> CompilerM Multicore () ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.iterations = $exp:e';|]
  -- Create the timing fields for the task
  Stm -> CompilerM Multicore () ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.task_time = &ctx->$id:(functionTiming fpar_task);|]
  Stm -> CompilerM Multicore () ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.task_iter = &ctx->$id:(functionIterations fpar_task);|]

  case Scheduling
sched of
    Scheduling
Dynamic -> Stm -> CompilerM Multicore () ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.sched = DYNAMIC;|]
    Scheduling
Static -> Stm -> CompilerM Multicore () ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.sched = STATIC;|]

  -- Generate the nested segop function if available
  [(Name, Bool)]
fnpar_task <- case Maybe ParallelTask
par_task of
    Just (ParallelTask Code
nested_code VName
nested_tid) -> do
      let lexical_nested :: Map VName Space
lexical_nested = Function Multicore -> Map VName Space
forall a. Function a -> Map VName Space
lexicalMemoryUsage (Function Multicore -> Map VName Space)
-> Function Multicore -> Map VName Space
forall a b. (a -> b) -> a -> b
$ Bool
-> [Param]
-> [Param]
-> Code
-> [ExternalValue]
-> [ExternalValue]
-> Function Multicore
forall a.
Bool
-> [Param]
-> [Param]
-> Code a
-> [ExternalValue]
-> [ExternalValue]
-> FunctionT a
Function Bool
False [] [Param]
params Code
nested_code [] []
      Name
fnpar_task <- Map VName Space
-> [Char]
-> Code
-> Name
-> [(VName, (Type, ValueType))]
-> [(VName, (Type, ValueType))]
-> VName
-> VName
-> CompilerM Multicore () Name
forall a s.
ToIdent a =>
Map VName Space
-> [Char]
-> Code
-> a
-> [(VName, (Type, ValueType))]
-> [(VName, (Type, ValueType))]
-> VName
-> VName
-> CompilerM Multicore s Name
generateParLoopFn Map VName Space
lexical_nested ([Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_nested_task") Code
nested_code Name
fstruct [(VName, (Type, ValueType))]
free [(VName, (Type, ValueType))]
retval VName
nested_tid VName
nsubtask
      Stm -> CompilerM Multicore () ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.nested_fn = $id:fnpar_task;|]
      [(Name, Bool)] -> CompilerM Multicore () [(Name, Bool)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, Bool)] -> CompilerM Multicore () [(Name, Bool)])
-> [(Name, Bool)] -> CompilerM Multicore () [(Name, Bool)]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Bool] -> [(Name, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name
fnpar_task] [Bool
True]
    Maybe ParallelTask
Nothing -> do
      Stm -> CompilerM Multicore () ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.nested_fn=NULL;|]
      [(Name, Bool)] -> CompilerM Multicore () [(Name, Bool)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name, Bool)]
forall a. Monoid a => a
mempty

  let ftask_err :: Name
ftask_err = Name
fpar_task Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_err"
  let code :: [BlockItem]
code =
        [C.citems|int $id:ftask_err = scheduler_prepare_task(&ctx->scheduler, &$id:ftask_name);
                  if ($id:ftask_err != 0) {
                    err = 1; goto cleanup;
                  }|]

  (BlockItem -> CompilerM Multicore () ())
-> [BlockItem] -> CompilerM Multicore () ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BlockItem -> CompilerM Multicore () ()
forall op s. BlockItem -> CompilerM op s ()
GC.item [BlockItem]
code

  -- Add profile fields for -P option
  (BlockItem -> CompilerM Multicore () ())
-> [BlockItem] -> CompilerM Multicore () ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BlockItem -> CompilerM Multicore () ()
forall op s. BlockItem -> CompilerM op s ()
GC.profileReport ([BlockItem] -> CompilerM Multicore () ())
-> [BlockItem] -> CompilerM Multicore () ()
forall a b. (a -> b) -> a -> b
$ [(Name, Bool)] -> [BlockItem]
multiCoreReport ([(Name, Bool)] -> [BlockItem]) -> [(Name, Bool)] -> [BlockItem]
forall a b. (a -> b) -> a -> b
$ (Name
fpar_task, Bool
True) (Name, Bool) -> [(Name, Bool)] -> [(Name, Bool)]
forall a. a -> [a] -> [a]
: [(Name, Bool)]
fnpar_task
compileOp (ParLoop [Char]
s' VName
i Code
prebody Code
body Code
postbody [Param]
free VName
tid) = do
  [(Type, ValueType)]
free_ctypes <- (Param -> CompilerM Multicore () (Type, ValueType))
-> [Param] -> CompilerM Multicore () [(Type, ValueType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Param -> CompilerM Multicore () (Type, ValueType)
forall op s. Param -> CompilerM op s (Type, ValueType)
paramToCType [Param]
free
  let free_args :: [VName]
free_args = (Param -> VName) -> [Param] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map Param -> VName
paramName [Param]
free

  let lexical :: Map VName Space
lexical =
        Function Multicore -> Map VName Space
forall a. Function a -> Map VName Space
lexicalMemoryUsage (Function Multicore -> Map VName Space)
-> Function Multicore -> Map VName Space
forall a b. (a -> b) -> a -> b
$
          Bool
-> [Param]
-> [Param]
-> Code
-> [ExternalValue]
-> [ExternalValue]
-> Function Multicore
forall a.
Bool
-> [Param]
-> [Param]
-> Code a
-> [ExternalValue]
-> [ExternalValue]
-> FunctionT a
Function Bool
False [] [Param]
free (Code
prebody Code -> Code -> Code
forall a. Semigroup a => a -> a -> a
<> Code
body) [] []

  Name
fstruct <-
    [Char]
-> [VName]
-> [(Type, ValueType)]
-> [VName]
-> [(Type, ValueType)]
-> CompilerM Multicore () Name
forall s.
[Char]
-> [VName]
-> [(Type, ValueType)]
-> [VName]
-> [(Type, ValueType)]
-> CompilerM Multicore s Name
prepareTaskStruct ([Char]
s' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_parloop_struct") [VName]
free_args [(Type, ValueType)]
free_ctypes [VName]
forall a. Monoid a => a
mempty [(Type, ValueType)]
forall a. Monoid a => a
mempty

  Name
ftask <- [Char]
-> (Name -> CompilerM Multicore () Definition)
-> CompilerM Multicore () Name
forall op s.
[Char]
-> (Name -> CompilerM op s Definition) -> CompilerM op s Name
multicoreDef ([Char]
s' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_parloop") ((Name -> CompilerM Multicore () Definition)
 -> CompilerM Multicore () Name)
-> (Name -> CompilerM Multicore () Definition)
-> CompilerM Multicore () Name
forall a b. (a -> b) -> a -> b
$ \Name
s -> do
    [BlockItem]
fbody <- Name
-> Maybe VName -> [BlockItem] -> CompilerM Multicore () [BlockItem]
forall op s.
Name -> Maybe VName -> [BlockItem] -> CompilerM op s [BlockItem]
benchmarkCode Name
s (VName -> Maybe VName
forall a. a -> Maybe a
Just VName
tid)
      ([BlockItem] -> CompilerM Multicore () [BlockItem])
-> (CompilerM Multicore () [BlockItem]
    -> CompilerM Multicore () [BlockItem])
-> CompilerM Multicore () [BlockItem]
-> CompilerM Multicore () [BlockItem]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Bool
-> CompilerM Multicore () [BlockItem]
-> CompilerM Multicore () [BlockItem]
forall op s a. Bool -> CompilerM op s a -> CompilerM op s a
GC.inNewFunction Bool
False
      (CompilerM Multicore () [BlockItem]
 -> CompilerM Multicore () [BlockItem])
-> CompilerM Multicore () [BlockItem]
-> CompilerM Multicore () [BlockItem]
forall a b. (a -> b) -> a -> b
$ Map VName Space
-> ([BlockItem] -> [Stm] -> CompilerM Multicore () [BlockItem])
-> CompilerM Multicore () [BlockItem]
forall op s a.
Map VName Space
-> ([BlockItem] -> [Stm] -> CompilerM op s a) -> CompilerM op s a
GC.cachingMemory Map VName Space
lexical (([BlockItem] -> [Stm] -> CompilerM Multicore () [BlockItem])
 -> CompilerM Multicore () [BlockItem])
-> ([BlockItem] -> [Stm] -> CompilerM Multicore () [BlockItem])
-> CompilerM Multicore () [BlockItem]
forall a b. (a -> b) -> a -> b
$
        \[BlockItem]
decl_cached [Stm]
free_cached -> CompilerM Multicore () () -> CompilerM Multicore () [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
GC.blockScope (CompilerM Multicore () () -> CompilerM Multicore () [BlockItem])
-> CompilerM Multicore () () -> CompilerM Multicore () [BlockItem]
forall a b. (a -> b) -> a -> b
$ do
          (BlockItem -> CompilerM Multicore () ())
-> [BlockItem] -> CompilerM Multicore () ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
            BlockItem -> CompilerM Multicore () ()
forall op s. BlockItem -> CompilerM op s ()
GC.item
            [C.citems|$decls:(compileGetStructVals fstruct free_args free_ctypes)|]

          (BlockItem -> CompilerM Multicore () ())
-> [BlockItem] -> CompilerM Multicore () ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BlockItem -> CompilerM Multicore () ()
forall op s. BlockItem -> CompilerM op s ()
GC.item [BlockItem]
decl_cached

          InitGroup -> CompilerM Multicore () ()
forall op s. InitGroup -> CompilerM op s ()
GC.decl [C.cdecl|typename int64_t iterations = end - start;|]
          InitGroup -> CompilerM Multicore () ()
forall op s. InitGroup -> CompilerM op s ()
GC.decl [C.cdecl|typename int64_t $id:i = start;|]
          Code -> CompilerM Multicore () ()
forall op s. Code op -> CompilerM op s ()
GC.compileCode Code
prebody
          [BlockItem]
body' <- CompilerM Multicore () () -> CompilerM Multicore () [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
GC.blockScope (CompilerM Multicore () () -> CompilerM Multicore () [BlockItem])
-> CompilerM Multicore () () -> CompilerM Multicore () [BlockItem]
forall a b. (a -> b) -> a -> b
$ Code -> CompilerM Multicore () ()
forall op s. Code op -> CompilerM op s ()
GC.compileCode Code
body
          Stm -> CompilerM Multicore () ()
forall op s. Stm -> CompilerM op s ()
GC.stm
            [C.cstm|for (; $id:i < end; $id:i++) {
                       $items:body'
                     }|]
          Code -> CompilerM Multicore () ()
forall op s. Code op -> CompilerM op s ()
GC.compileCode Code
postbody
          Stm -> CompilerM Multicore () ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|cleanup: {}|]
          (Stm -> CompilerM Multicore () ())
-> [Stm] -> CompilerM Multicore () ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Stm -> CompilerM Multicore () ()
forall op s. Stm -> CompilerM op s ()
GC.stm [Stm]
free_cached

    Definition -> CompilerM Multicore () Definition
forall (m :: * -> *) a. Monad m => a -> m a
return
      [C.cedecl|static int $id:s(void *args, typename int64_t start, typename int64_t end, int $id:tid, int tid) {
                       int err = 0;
                       struct $id:fstruct *$id:fstruct = (struct $id:fstruct*) args;
                       struct futhark_context *ctx = $id:fstruct->ctx;
                       $items:fbody
                       return err;
                     }|]

  let ftask_name :: Name
ftask_name = Name
ftask Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_task"
  InitGroup -> CompilerM Multicore () ()
forall op s. InitGroup -> CompilerM op s ()
GC.decl [C.cdecl|struct scheduler_parloop $id:ftask_name;|]
  Stm -> CompilerM Multicore () ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.name = $string:(nameToString ftask);|]
  Stm -> CompilerM Multicore () ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.fn = $id:ftask;|]
  Stm -> CompilerM Multicore () ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.args = &$id:fstruct;|]
  Stm -> CompilerM Multicore () ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.iterations = iterations;|]
  Stm -> CompilerM Multicore () ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.info = info;|]

  let ftask_err :: Name
ftask_err = Name
ftask Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_err"
      ftask_total :: Name
ftask_total = Name
ftask Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_total"
  [BlockItem]
code' <-
    Name
-> Maybe VName -> [BlockItem] -> CompilerM Multicore () [BlockItem]
forall op s.
Name -> Maybe VName -> [BlockItem] -> CompilerM op s [BlockItem]
benchmarkCode
      Name
ftask_total
      Maybe VName
forall a. Maybe a
Nothing
      [C.citems|int $id:ftask_err = scheduler_execute_task(&ctx->scheduler,
                                                           &$id:ftask_name);
               if ($id:ftask_err != 0) {
                 err = 1;
                 goto cleanup;
               }|]

  (BlockItem -> CompilerM Multicore () ())
-> [BlockItem] -> CompilerM Multicore () ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BlockItem -> CompilerM Multicore () ()
forall op s. BlockItem -> CompilerM op s ()
GC.item [BlockItem]
code'
  (BlockItem -> CompilerM Multicore () ())
-> [BlockItem] -> CompilerM Multicore () ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BlockItem -> CompilerM Multicore () ()
forall op s. BlockItem -> CompilerM op s ()
GC.profileReport ([BlockItem] -> CompilerM Multicore () ())
-> [BlockItem] -> CompilerM Multicore () ()
forall a b. (a -> b) -> a -> b
$ [(Name, Bool)] -> [BlockItem]
multiCoreReport ([(Name, Bool)] -> [BlockItem]) -> [(Name, Bool)] -> [BlockItem]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Bool] -> [(Name, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name
ftask, Name
ftask_total] [Bool
True, Bool
False]
compileOp (Atomic AtomicOp
aop) =
  AtomicOp -> CompilerM Multicore () ()
forall op s. AtomicOp -> CompilerM op s ()
atomicOps AtomicOp
aop

doAtomic ::
  (C.ToIdent a1, C.ToIdent a2) =>
  a1 ->
  a2 ->
  Count u (TExp Int32) ->
  Exp ->
  String ->
  C.Type ->
  GC.CompilerM op s ()
doAtomic :: forall a1 a2 u op s.
(ToIdent a1, ToIdent a2) =>
a1
-> a2
-> Count u (TExp Int32)
-> Exp
-> [Char]
-> Type
-> CompilerM op s ()
doAtomic a1
old a2
arr Count u (TExp Int32)
ind Exp
val [Char]
op Type
ty = do
  Exp
ind' <- Exp -> CompilerM op s Exp
forall op s. Exp -> CompilerM op s Exp
GC.compileExp (Exp -> CompilerM op s Exp) -> Exp -> CompilerM op s Exp
forall a b. (a -> b) -> a -> b
$ TExp Int32 -> Exp
forall t v. TPrimExp t v -> PrimExp v
untyped (TExp Int32 -> Exp) -> TExp Int32 -> Exp
forall a b. (a -> b) -> a -> b
$ Count u (TExp Int32) -> TExp Int32
forall u e. Count u e -> e
unCount Count u (TExp Int32)
ind
  Exp
val' <- Exp -> CompilerM op s Exp
forall op s. Exp -> CompilerM op s Exp
GC.compileExp Exp
val
  Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:old = $id:op(&(($ty:ty*)$id:arr.mem)[$exp:ind'], ($ty:ty) $exp:val', __ATOMIC_RELAXED);|]

atomicOps :: AtomicOp -> GC.CompilerM op s ()
atomicOps :: forall op s. AtomicOp -> CompilerM op s ()
atomicOps (AtomicCmpXchg PrimType
t VName
old VName
arr Count Elements (TExp Int32)
ind VName
res Exp
val) = do
  Exp
ind' <- Exp -> CompilerM op s Exp
forall op s. Exp -> CompilerM op s Exp
GC.compileExp (Exp -> CompilerM op s Exp) -> Exp -> CompilerM op s Exp
forall a b. (a -> b) -> a -> b
$ TExp Int32 -> Exp
forall t v. TPrimExp t v -> PrimExp v
untyped (TExp Int32 -> Exp) -> TExp Int32 -> Exp
forall a b. (a -> b) -> a -> b
$ Count Elements (TExp Int32) -> TExp Int32
forall u e. Count u e -> e
unCount Count Elements (TExp Int32)
ind
  Exp
new_val' <- Exp -> CompilerM op s Exp
forall op s. Exp -> CompilerM op s Exp
GC.compileExp Exp
val
  let cast :: Type
cast = [C.cty|$ty:(GC.primTypeToCType t)*|]
  Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
GC.stm
    [C.cstm|$id:res = $id:op(&(($ty:cast)$id:arr.mem)[$exp:ind'],
                ($ty:cast)&$id:old,
                 $exp:new_val',
                 0, __ATOMIC_SEQ_CST, __ATOMIC_RELAXED);|]
  where
    op :: String
    op :: [Char]
op = [Char]
"__atomic_compare_exchange_n"
atomicOps (AtomicXchg PrimType
t VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val) = do
  Exp
ind' <- Exp -> CompilerM op s Exp
forall op s. Exp -> CompilerM op s Exp
GC.compileExp (Exp -> CompilerM op s Exp) -> Exp -> CompilerM op s Exp
forall a b. (a -> b) -> a -> b
$ TExp Int32 -> Exp
forall t v. TPrimExp t v -> PrimExp v
untyped (TExp Int32 -> Exp) -> TExp Int32 -> Exp
forall a b. (a -> b) -> a -> b
$ Count Elements (TExp Int32) -> TExp Int32
forall u e. Count u e -> e
unCount Count Elements (TExp Int32)
ind
  Exp
val' <- Exp -> CompilerM op s Exp
forall op s. Exp -> CompilerM op s Exp
GC.compileExp Exp
val
  let cast :: Type
cast = [C.cty|$ty:(GC.primTypeToCType t)*|]
  Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:old = $id:op(&(($ty:cast)$id:arr.mem)[$exp:ind'], $exp:val', __ATOMIC_SEQ_CST);|]
  where
    op :: String
    op :: [Char]
op = [Char]
"__atomic_exchange_n"
atomicOps (AtomicAdd IntType
t VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val) =
  VName
-> VName
-> Count Elements (TExp Int32)
-> Exp
-> [Char]
-> Type
-> CompilerM op s ()
forall a1 a2 u op s.
(ToIdent a1, ToIdent a2) =>
a1
-> a2
-> Count u (TExp Int32)
-> Exp
-> [Char]
-> Type
-> CompilerM op s ()
doAtomic VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val [Char]
"__atomic_fetch_add" [C.cty|$ty:(GC.intTypeToCType t)|]
atomicOps (AtomicSub IntType
t VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val) =
  VName
-> VName
-> Count Elements (TExp Int32)
-> Exp
-> [Char]
-> Type
-> CompilerM op s ()
forall a1 a2 u op s.
(ToIdent a1, ToIdent a2) =>
a1
-> a2
-> Count u (TExp Int32)
-> Exp
-> [Char]
-> Type
-> CompilerM op s ()
doAtomic VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val [Char]
"__atomic_fetch_sub" [C.cty|$ty:(GC.intTypeToCType t)|]
atomicOps (AtomicAnd IntType
t VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val) =
  VName
-> VName
-> Count Elements (TExp Int32)
-> Exp
-> [Char]
-> Type
-> CompilerM op s ()
forall a1 a2 u op s.
(ToIdent a1, ToIdent a2) =>
a1
-> a2
-> Count u (TExp Int32)
-> Exp
-> [Char]
-> Type
-> CompilerM op s ()
doAtomic VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val [Char]
"__atomic_fetch_and" [C.cty|$ty:(GC.intTypeToCType t)|]
atomicOps (AtomicOr IntType
t VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val) =
  VName
-> VName
-> Count Elements (TExp Int32)
-> Exp
-> [Char]
-> Type
-> CompilerM op s ()
forall a1 a2 u op s.
(ToIdent a1, ToIdent a2) =>
a1
-> a2
-> Count u (TExp Int32)
-> Exp
-> [Char]
-> Type
-> CompilerM op s ()
doAtomic VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val [Char]
"__atomic_fetch_or" [C.cty|$ty:(GC.intTypeToCType t)|]
atomicOps (AtomicXor IntType
t VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val) =
  VName
-> VName
-> Count Elements (TExp Int32)
-> Exp
-> [Char]
-> Type
-> CompilerM op s ()
forall a1 a2 u op s.
(ToIdent a1, ToIdent a2) =>
a1
-> a2
-> Count u (TExp Int32)
-> Exp
-> [Char]
-> Type
-> CompilerM op s ()
doAtomic VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val [Char]
"__atomic_fetch_xor" [C.cty|$ty:(GC.intTypeToCType t)|]