{-# LANGUAGE QuasiQuotes #-}

-- | 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,
    operations,
    cliOptions,
    compileOp,
    ValueType (..),
    paramToCType,
    prepareTaskStruct,
    closureFreeStructField,
    generateParLoopFn,
    addTimingFields,
    functionTiming,
    functionIterations,
    multicoreDef,
    multicoreName,
    DefSpecifier,
    atomicOps,
  )
where

import Control.Monad
import Data.Loc
import Data.Map qualified as M
import Data.Maybe
import Data.Text qualified as T
import Futhark.CodeGen.Backends.GenericC qualified as GC
import Futhark.CodeGen.Backends.GenericC.Options
import Futhark.CodeGen.Backends.MulticoreC.Boilerplate (generateBoilerplate)
import Futhark.CodeGen.Backends.SimpleRep
import Futhark.CodeGen.ImpCode.Multicore hiding (ValueType)
import Futhark.CodeGen.ImpGen.Multicore qualified as ImpGen
import Futhark.IR.MCMem (MCMem, Prog)
import Futhark.MonadFreshNames
import Language.C.Quote.OpenCL qualified as C
import Language.C.Syntax qualified as C

-- | Compile the program to ImpCode with multicore operations.
compileProg ::
  (MonadFreshNames m) => T.Text -> Prog MCMem -> m (ImpGen.Warnings, GC.CParts)
compileProg :: forall (m :: * -> *).
MonadFreshNames m =>
Text -> Prog MCMem -> m (Warnings, CParts)
compileProg Text
version =
  (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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (Warnings, a) -> f (Warnings, b)
traverse
    ( Text
-> Text
-> Operations Multicore ()
-> CompilerM Multicore () ()
-> Text
-> (Space, [Space])
-> [Option]
-> Definitions Multicore
-> m CParts
forall (m :: * -> *) op.
MonadFreshNames m =>
Text
-> Text
-> Operations op ()
-> CompilerM op () ()
-> Text
-> (Space, [Space])
-> [Option]
-> Definitions op
-> m CParts
GC.compileProg
        Text
"multicore"
        Text
version
        Operations Multicore ()
forall s. Operations Multicore s
operations
        CompilerM Multicore () ()
forall op s. CompilerM op s ()
generateBoilerplate
        Text
"#include <pthread.h>\n"
        (Space
DefaultSpace, [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

-- | Multicore-related command line options.
cliOptions :: [Option]
cliOptions :: [Option]
cliOptions =
  [ Option
      { optionLongName :: String
optionLongName = String
"num-threads",
        optionShortName :: Maybe Char
optionShortName = Maybe Char
forall a. Maybe a
Nothing,
        optionArgument :: OptionArgument
optionArgument = String -> OptionArgument
RequiredArgument String
"INT",
        optionAction :: Stm
optionAction = [C.cstm|futhark_context_config_set_num_threads(cfg, atoi(optarg));|],
        optionDescription :: String
optionDescription = String
"Set number of threads used for execution."
      }
  ]

-- | Operations for generating multicore code.
operations :: GC.Operations Multicore s
operations :: forall s. Operations Multicore s
operations =
  Operations Multicore s
forall op s. Operations op s
GC.defaultOperations
    { GC.opsCompiler = compileOp,
      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 =
  String -> Name
nameFromString String
"free_" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Text -> Name
nameFromText (VName -> Text
forall a. Pretty a => a -> Text
prettyText VName
v)

closureRetvalStructField :: VName -> Name
closureRetvalStructField :: VName -> Name
closureRetvalStructField VName
v =
  String -> Name
nameFromString String
"retval_" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Text -> Name
nameFromText (VName -> Text
forall a. Pretty a => a -> Text
prettyText VName
v)

-- | How a value is passed to a worker through the closure struct.
data ValueType = Prim PrimType | MemBlock | RawMem | ScalarMem

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

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

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

compileSetRetvalStructValues ::
  (C.ToIdent a) =>
  a ->
  [VName] ->
  [(C.Type, C.Type, ValueType)] ->
  [C.Stm]
compileSetRetvalStructValues :: forall a.
ToIdent a =>
a -> [VName] -> [(Type, Type, ValueType)] -> [Stm]
compileSetRetvalStructValues a
struct [VName]
vnames [(Type, Type, ValueType)]
we = [[Stm]] -> [Stm]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Stm]] -> [Stm]) -> [[Stm]] -> [Stm]
forall a b. (a -> b) -> a -> b
$ (VName -> (Type, Type, ValueType) -> [Stm])
-> [VName] -> [(Type, Type, ValueType)] -> [[Stm]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith VName -> (Type, Type, ValueType) -> [Stm]
forall {b}. VName -> (Type, b, ValueType) -> [Stm]
field [VName]
vnames [(Type, Type, ValueType)]
we
  where
    field :: VName -> (Type, b, ValueType) -> [Stm]
field VName
name (Type
ct, b
_, Prim PrimType
_) =
      [C.cstms|$id:struct.$id:(closureRetvalStructField name)=(($ty:ct*)&$id:name);
               $escstm:("#if defined(ISPC)")
               $id:struct.$id:(closureRetvalStructField name)+= programIndex;
               $escstm:("#endif")|]
    field VName
name (Type
_, b
_, ValueType
MemBlock) =
      [C.cstms|$id:struct.$id:(closureRetvalStructField name)=$id:name.mem;|]
    field VName
name (Type
_, b
_, ValueType
RawMem) =
      [C.cstms|$id:struct.$id:(closureRetvalStructField name)=$id:name;|]
    field VName
name (Type
_, b
_, ValueType
ScalarMem) =
      [C.cstms|$id:struct.$id:(closureRetvalStructField name)=$id:name;|]

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

compileGetStructVals ::
  (C.ToIdent a) =>
  a ->
  [VName] ->
  [(C.Type, C.Type, ValueType)] ->
  [C.InitGroup]
compileGetStructVals :: forall a.
ToIdent a =>
a -> [VName] -> [(Type, Type, ValueType)] -> [InitGroup]
compileGetStructVals a
struct = (VName -> (Type, Type, ValueType) -> InitGroup)
-> [VName] -> [(Type, Type, ValueType)] -> [InitGroup]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith VName -> (Type, Type, ValueType) -> InitGroup
forall {b}. VName -> (Type, b, ValueType) -> InitGroup
field
  where
    field :: VName -> (Type, b, ValueType) -> InitGroup
field VName
name (Type
ty, b
_storage_ty, Prim PrimType
pt) =
      let inner :: Exp
inner = [C.cexp|$id:struct->$id:(closureFreeStructField name)|]
       in [C.cdecl|$ty:ty $id:name = $exp:(fromStorage pt inner);|]
    field VName
name (Type
ty, b
_, ValueType
ScalarMem) =
      [C.cdecl|$ty:ty $id:name = $id:struct->$id:(closureFreeStructField name);|]
    field VName
name (Type
ty, b
_, ValueType
_) =
      [C.cdecl|$ty:ty $id:name =
                 {.desc = $string:(prettyString name),
                  .mem = $id:struct->$id:(closureFreeStructField name),
                  .size = 0, .references = NULL};|]

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

paramToCType :: Param -> GC.CompilerM op s (C.Type, C.Type, ValueType)
paramToCType :: forall op s. Param -> CompilerM op s (Type, Type, ValueType)
paramToCType (ScalarParam VName
_ PrimType
pt) =
  (Type, Type, ValueType) -> CompilerM op s (Type, Type, ValueType)
forall a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrimType -> Type
primTypeToCType PrimType
pt, PrimType -> Type
primStorageType PrimType
pt, PrimType -> ValueType
Prim PrimType
pt)
paramToCType (MemParam VName
name Space
space') = do
  (ct, vt) <- VName -> Space -> CompilerM op s (Type, ValueType)
forall op s. VName -> Space -> CompilerM op s (Type, ValueType)
mcMemToCType VName
name Space
space'
  pure (ct, ct, vt)

mcMemToCType :: VName -> Space -> GC.CompilerM op s (C.Type, ValueType)
mcMemToCType :: forall op s. VName -> Space -> CompilerM op s (Type, ValueType)
mcMemToCType VName
_ (ScalarSpace [SubExp]
_ PrimType
pt) =
  (Type, ValueType) -> CompilerM op s (Type, ValueType)
forall a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([C.cty|$ty:(GC.primTypeToCType pt)*|], ValueType
ScalarMem)
mcMemToCType VName
v Space
space = do
  refcount <- Space -> CompilerM op s Bool
forall op s. Space -> CompilerM op s Bool
GC.fatMemory Space
space
  cached <- isJust <$> GC.cacheMem v
  pure
    ( GC.fatMemType space,
      if refcount && not cached
        then MemBlock
        else RawMem
    )

benchmarkCode :: Name -> [C.BlockItem] -> GC.CompilerM op s [C.BlockItem]
benchmarkCode :: forall op s. Name -> [BlockItem] -> CompilerM op s [BlockItem]
benchmarkCode Name
name [BlockItem]
code = do
  event <- Name -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => Name -> m VName
newVName Name
"event"
  provenance <- GC.provenanceExp
  pure
    [C.citems|
     struct mc_event* $id:event = mc_event_new(ctx);
     if ($id:event != NULL) {
       $id:event->bef = get_wall_time();
     }
     $items:code
     if ($id:event != NULL) {
       $id:event->aft = get_wall_time();
       lock_lock(&ctx->event_list_lock);
       add_event(ctx,
                 $string:(nameToString name),
                 $exp:provenance,
                 NULL,
                 $id:event,
                 (typename event_report_fn)mc_event_report);
       lock_unlock(&ctx->event_list_lock);
     }|]

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 :: Name -> GC.CompilerM op s Name
multicoreName :: forall op s. Name -> CompilerM op s Name
multicoreName Name
s = do
  s' <- Name -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => Name -> m VName
newVName (Name -> CompilerM op s VName) -> Name -> CompilerM op s VName
forall a b. (a -> b) -> a -> b
$ Name
"futhark_mc_" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
s
  pure $ baseName s' <> "_" <> nameFromString (show (baseTag s'))

type DefSpecifier s = Name -> (Name -> GC.CompilerM Multicore s C.Definition) -> GC.CompilerM Multicore s Name

multicoreDef :: DefSpecifier s
multicoreDef :: forall s. DefSpecifier s
multicoreDef Name
s Name -> CompilerM Multicore s Definition
f = do
  s' <- Name -> CompilerM Multicore s Name
forall op s. Name -> CompilerM op s Name
multicoreName Name
s
  GC.libDecl =<< f s'
  pure s'

generateParLoopFn ::
  (C.ToIdent a) =>
  M.Map VName Space ->
  Name ->
  MCCode ->
  a ->
  [(VName, (C.Type, C.Type, ValueType))] ->
  [(VName, (C.Type, C.Type, ValueType))] ->
  GC.CompilerM Multicore s Name
generateParLoopFn :: forall a s.
ToIdent a =>
Map VName Space
-> Name
-> MCCode
-> a
-> [(VName, (Type, Type, ValueType))]
-> [(VName, (Type, Type, ValueType))]
-> CompilerM Multicore s Name
generateParLoopFn Map VName Space
lexical Name
basename MCCode
code a
fstruct [(VName, (Type, Type, ValueType))]
free [(VName, (Type, Type, ValueType))]
retval = do
  let ([VName]
fargs, [(Type, Type, ValueType)]
fctypes) = [(VName, (Type, Type, ValueType))]
-> ([VName], [(Type, Type, ValueType)])
forall a b. [(a, b)] -> ([a], [b])
unzip [(VName, (Type, Type, ValueType))]
free
  let ([VName]
retval_args, [(Type, Type, ValueType)]
retval_ctypes) = [(VName, (Type, Type, ValueType))]
-> ([VName], [(Type, Type, ValueType)])
forall a b. [(a, b)] -> ([a], [b])
unzip [(VName, (Type, Type, ValueType))]
retval
  DefSpecifier s
forall s. DefSpecifier s
multicoreDef Name
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
    fbody <- Name -> [BlockItem] -> CompilerM Multicore s [BlockItem]
forall op s. Name -> [BlockItem] -> CompilerM op s [BlockItem]
benchmarkCode Name
s ([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
<=< CompilerM Multicore s [BlockItem]
-> CompilerM Multicore s [BlockItem]
forall op s a. CompilerM op s a -> CompilerM op s a
GC.inNewFunction (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.collect (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)|]
        code' <- CompilerM Multicore s () -> CompilerM Multicore s [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
GC.collect (CompilerM Multicore s () -> CompilerM Multicore s [BlockItem])
-> CompilerM Multicore s () -> CompilerM Multicore s [BlockItem]
forall a b. (a -> b) -> a -> b
$ MCCode -> CompilerM Multicore s ()
forall op s. Code op -> CompilerM op s ()
GC.compileCode MCCode
code
        mapM_ GC.item decl_cached
        mapM_ GC.item =<< GC.declAllocatedMem
        mapM_ GC.item code'
        free_mem <- GC.freeAllocatedMem
        GC.stm [C.cstm|cleanup: {$stms:free_cached $items:free_mem}|]
    pure
      [C.cedecl|int $id:s(void *args, typename int64_t iterations, int tid, struct scheduler_info info) {
                           int err = 0;
                           int subtask_id = tid;
                           struct $id:fstruct *$id:fstruct = (struct $id:fstruct*) args;
                           struct futhark_context *ctx = $id:fstruct->ctx;
                           $items:fbody
                           if (err == 0) {
                             $stms:(compileWriteBackResVals fstruct retval_args retval_ctypes)
                           }
                           return err;
                      }|]

prepareTaskStruct ::
  DefSpecifier s ->
  Name ->
  [VName] ->
  [(C.Type, C.Type, ValueType)] ->
  [VName] ->
  [(C.Type, C.Type, ValueType)] ->
  GC.CompilerM Multicore s Name
prepareTaskStruct :: forall s.
DefSpecifier s
-> Name
-> [VName]
-> [(Type, Type, ValueType)]
-> [VName]
-> [(Type, Type, ValueType)]
-> CompilerM Multicore s Name
prepareTaskStruct DefSpecifier s
def Name
name [VName]
free_args [(Type, Type, ValueType)]
free_ctypes [VName]
retval_args [(Type, Type, ValueType)]
retval_ctypes = do
  let makeStruct :: a -> f Definition
makeStruct a
s =
        Definition -> f Definition
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          [C.cedecl|struct $id:s {
                       struct futhark_context *ctx;
                       $sdecls:(compileFreeStructFields free_args free_ctypes)
                       $sdecls:(compileRetvalStructFields retval_args retval_ctypes)
                     };|]
  fstruct <- DefSpecifier s
def Name
name Name -> CompilerM Multicore s Definition
forall {f :: * -> *} {a}.
(Applicative f, ToIdent a) =>
a -> f Definition
makeStruct
  let fstruct' = Name
fstruct Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_"
  GC.decl [C.cdecl|struct $id:fstruct $id:fstruct';|]
  GC.stm [C.cstm|$id:fstruct'.ctx = ctx;|]
  GC.stms [C.cstms|$stms:(compileSetStructValues fstruct' free_args free_ctypes)|]
  GC.stms [C.cstms|$stms:(compileSetRetvalStructValues fstruct' retval_args retval_ctypes)|]
  pure fstruct

-- Generate a segop function for top_level and potentially nested SegOp code
compileOp :: GC.OpCompiler Multicore s
compileOp :: forall s. OpCompiler Multicore s
compileOp (GetLoopBounds VName
start VName
end) = do
  Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:start = start;|]
  Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:end = end;|]
compileOp (GetTaskId VName
v) =
  Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:v = subtask_id;|]
compileOp (GetNumTasks VName
v) =
  Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:v = info.nsubtasks;|]
compileOp (SegOp Name
name [Param]
params ParallelTask
seq_task Maybe ParallelTask
par_task [Param]
retvals (SchedulerInfo Exp
e Scheduling
sched)) = do
  let (ParallelTask MCCode
seq_code) = ParallelTask
seq_task
  free_ctypes <- (Param -> CompilerM Multicore s (Type, Type, ValueType))
-> [Param] -> CompilerM Multicore s [(Type, Type, ValueType)]
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 Multicore s (Type, Type, ValueType)
forall op s. Param -> CompilerM op s (Type, Type, ValueType)
paramToCType [Param]
params
  retval_ctypes <- mapM paramToCType retvals
  let free_args = (Param -> VName) -> [Param] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map Param -> VName
paramName [Param]
params
      retval_args = (Param -> VName) -> [Param] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map Param -> VName
paramName [Param]
retvals
      free = [VName]
-> [(Type, Type, ValueType)] -> [(VName, (Type, Type, ValueType))]
forall a b. [a] -> [b] -> [(a, b)]
zip [VName]
free_args [(Type, Type, ValueType)]
free_ctypes
      retval = [VName]
-> [(Type, Type, ValueType)] -> [(VName, (Type, Type, ValueType))]
forall a b. [a] -> [b] -> [(a, b)]
zip [VName]
retval_args [(Type, Type, ValueType)]
retval_ctypes

  e' <- GC.compileExp e

  let lexical = KernelHandling -> Function Multicore -> Map VName Space
lexicalMemoryUsageMC KernelHandling
TraverseKernels (Function Multicore -> Map VName Space)
-> Function Multicore -> Map VName Space
forall a b. (a -> b) -> a -> b
$ Maybe EntryPoint
-> [Param] -> [Param] -> Attrs -> MCCode -> Function Multicore
forall a.
Maybe EntryPoint
-> [Param] -> [Param] -> Attrs -> Code a -> FunctionT a
Function Maybe EntryPoint
forall a. Maybe a
Nothing [] [Param]
params Attrs
forall a. Monoid a => a
mempty MCCode
seq_code

  fstruct <-
    prepareTaskStruct multicoreDef "task" free_args free_ctypes retval_args retval_ctypes

  fpar_task <- generateParLoopFn lexical (name <> "_task") seq_code fstruct free retval
  addTimingFields fpar_task

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

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

  -- Generate the nested segop function if available
  case par_task of
    Just (ParallelTask MCCode
nested_code) -> do
      let lexical_nested :: Map VName Space
lexical_nested = KernelHandling -> Function Multicore -> Map VName Space
lexicalMemoryUsageMC KernelHandling
TraverseKernels (Function Multicore -> Map VName Space)
-> Function Multicore -> Map VName Space
forall a b. (a -> b) -> a -> b
$ Maybe EntryPoint
-> [Param] -> [Param] -> Attrs -> MCCode -> Function Multicore
forall a.
Maybe EntryPoint
-> [Param] -> [Param] -> Attrs -> Code a -> FunctionT a
Function Maybe EntryPoint
forall a. Maybe a
Nothing [] [Param]
params Attrs
forall a. Monoid a => a
mempty MCCode
nested_code
      fnpar_task <- Map VName Space
-> Name
-> MCCode
-> Name
-> [(VName, (Type, Type, ValueType))]
-> [(VName, (Type, Type, ValueType))]
-> CompilerM Multicore s Name
forall a s.
ToIdent a =>
Map VName Space
-> Name
-> MCCode
-> a
-> [(VName, (Type, Type, ValueType))]
-> [(VName, (Type, Type, ValueType))]
-> CompilerM Multicore s Name
generateParLoopFn Map VName Space
lexical_nested (Name
name Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_nested_task") MCCode
nested_code Name
fstruct [(VName, (Type, Type, ValueType))]
free [(VName, (Type, Type, ValueType))]
retval
      GC.stm [C.cstm|$id:ftask_name.nested_fn = $id:fnpar_task;|]
    Maybe ParallelTask
Nothing ->
      Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.nested_fn=NULL;|]

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

  mapM_ GC.item code
compileOp (ParLoop Name
s' MCCode
body [Param]
free) = do
  free_ctypes <- (Param -> CompilerM Multicore s (Type, Type, ValueType))
-> [Param] -> CompilerM Multicore s [(Type, Type, ValueType)]
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 Multicore s (Type, Type, ValueType)
forall op s. Param -> CompilerM op s (Type, Type, ValueType)
paramToCType [Param]
free
  let free_args = (Param -> VName) -> [Param] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map Param -> VName
paramName [Param]
free

  let lexical = KernelHandling -> Function Multicore -> Map VName Space
lexicalMemoryUsageMC KernelHandling
TraverseKernels (Function Multicore -> Map VName Space)
-> Function Multicore -> Map VName Space
forall a b. (a -> b) -> a -> b
$ Maybe EntryPoint
-> [Param] -> [Param] -> Attrs -> MCCode -> Function Multicore
forall a.
Maybe EntryPoint
-> [Param] -> [Param] -> Attrs -> Code a -> FunctionT a
Function Maybe EntryPoint
forall a. Maybe a
Nothing [] [Param]
free Attrs
forall a. Monoid a => a
mempty MCCode
body

  fstruct <-
    prepareTaskStruct multicoreDef (s' <> "_parloop_struct") free_args free_ctypes mempty mempty

  ftask <- multicoreDef (s' <> "_parloop") $ \Name
s -> do
    fbody <- Name -> [BlockItem] -> CompilerM Multicore s [BlockItem]
forall op s. Name -> [BlockItem] -> CompilerM op s [BlockItem]
benchmarkCode Name
s ([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
<=< CompilerM Multicore s [BlockItem]
-> CompilerM Multicore s [BlockItem]
forall op s a. CompilerM op s a -> CompilerM op s a
GC.inNewFunction (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.collect (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 ()
forall op s. [BlockItem] -> CompilerM op s ()
GC.items [C.citems|$decls:(compileGetStructVals fstruct free_args free_ctypes)|]

        InitGroup -> CompilerM Multicore s ()
forall op s. InitGroup -> CompilerM op s ()
GC.decl [C.cdecl|typename int64_t iterations = end-start;|]

        body' <- CompilerM Multicore s () -> CompilerM Multicore s [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
GC.collect (CompilerM Multicore s () -> CompilerM Multicore s [BlockItem])
-> CompilerM Multicore s () -> CompilerM Multicore s [BlockItem]
forall a b. (a -> b) -> a -> b
$ MCCode -> CompilerM Multicore s ()
forall op s. Code op -> CompilerM op s ()
GC.compileCode MCCode
body

        mapM_ GC.item decl_cached
        mapM_ GC.item =<< GC.declAllocatedMem
        free_mem <- GC.freeAllocatedMem
        mapM_ GC.item body'
        GC.stm [C.cstm|cleanup: {$stms:free_cached $items:free_mem}|]
    pure
      [C.cedecl|static int $id:s(void *args,
                                 typename int64_t start,
                                 typename int64_t end,
                                 int subtask_id,
                                 int tid) {
                       (void)subtask_id;
                       (void)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 -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_task"
  GC.decl [C.cdecl|struct scheduler_parloop $id:ftask_name;|]
  GC.stm [C.cstm|$id:ftask_name.name = $string:(nameToString ftask);|]
  GC.stm [C.cstm|$id:ftask_name.fn = $id:ftask;|]
  GC.stm [C.cstm|$id:ftask_name.args = &$id:(fstruct <> "_");|]
  GC.stm [C.cstm|$id:ftask_name.iterations = iterations;|]
  GC.stm [C.cstm|$id:ftask_name.info = info;|]

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

  mapM_ GC.item code'
compileOp (Atomic Space
space AtomicOp
aop) =
  Space
-> AtomicOp
-> (Type -> VName -> CompilerM Multicore s Type)
-> CompilerM Multicore s ()
forall op s.
Space
-> AtomicOp
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
atomicOps Space
space AtomicOp
aop (\Type
ty VName
_ -> Type -> CompilerM Multicore s Type
forall a. a -> CompilerM Multicore s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cty|$ty:ty*|])
compileOp (ISPCKernel MCCode
body [Param]
_) =
  MCCode -> CompilerM Multicore s ()
forall s. MCCode -> CompilerM Multicore s ()
scopedBlock MCCode
body
compileOp (ForEach VName
i Exp
from Exp
bound MCCode
body) = do
  let i' :: SrcLoc -> Id
i' = VName -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
C.toIdent VName
i
      t :: Type
t = PrimType -> Type
primTypeToCType (PrimType -> Type) -> PrimType -> Type
forall a b. (a -> b) -> a -> b
$ Exp -> PrimType
forall v. PrimExp v -> PrimType
primExpType Exp
bound
  from' <- Exp -> CompilerM Multicore s Exp
forall op s. Exp -> CompilerM op s Exp
GC.compileExp Exp
from
  bound' <- GC.compileExp bound
  body' <- GC.collect $ GC.compileCode body
  GC.stm
    [C.cstm|for ($ty:t $id:i' = $exp:from'; $id:i' < $exp:bound'; $id:i'++) {
            $items:body'
          }|]
compileOp (ForEachActive VName
i MCCode
body) = do
  InitGroup -> CompilerM Multicore s ()
forall op s. InitGroup -> CompilerM op s ()
GC.decl [C.cdecl|typename int64_t $id:i = 0;|]
  MCCode -> CompilerM Multicore s ()
forall s. MCCode -> CompilerM Multicore s ()
scopedBlock MCCode
body
compileOp (ExtractLane VName
dest Exp
tar Exp
_) = do
  tar' <- Exp -> CompilerM Multicore s Exp
forall op s. Exp -> CompilerM op s Exp
GC.compileExp Exp
tar
  GC.stm [C.cstm|$id:dest = $exp:tar';|]
compileOp (GetError VName
v) =
  Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:v = ctx->error != NULL;|]

scopedBlock :: MCCode -> GC.CompilerM Multicore s ()
scopedBlock :: forall s. MCCode -> CompilerM Multicore s ()
scopedBlock MCCode
code = do
  inner <- CompilerM Multicore s () -> CompilerM Multicore s [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
GC.collect (CompilerM Multicore s () -> CompilerM Multicore s [BlockItem])
-> CompilerM Multicore s () -> CompilerM Multicore s [BlockItem]
forall a b. (a -> b) -> a -> b
$ MCCode -> CompilerM Multicore s ()
forall op s. Code op -> CompilerM op s ()
GC.compileCode MCCode
code
  GC.stm [C.cstm|{$items:inner}|]

doAtomic ::
  (C.ToIdent a1) =>
  Space ->
  a1 ->
  VName ->
  Count m (TExp Int32) ->
  Exp ->
  String ->
  C.Type ->
  (C.Type -> VName -> GC.CompilerM op s C.Type) ->
  GC.CompilerM op s ()
doAtomic :: forall {k} a1 (m :: k) op s.
ToIdent a1 =>
Space
-> a1
-> VName
-> Count m (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
doAtomic Space
space a1
old VName
arr Count m (TExp Int32)
ind Exp
val String
op Type
ty Type -> VName -> CompilerM op s Type
castf = do
  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 {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped (TExp Int32 -> Exp) -> TExp Int32 -> Exp
forall a b. (a -> b) -> a -> b
$ Count m (TExp Int32) -> TExp Int32
forall {k} (u :: k) e. Count u e -> e
unCount Count m (TExp Int32)
ind
  val' <- GC.compileExp val
  cast <- castf ty arr
  arr' <- GC.rawMem arr space
  GC.stm [C.cstm|$id:old = $id:op(&(($ty:cast)$exp:arr')[$exp:ind'], ($ty:ty) $exp:val', __ATOMIC_RELAXED);|]

atomicOps :: Space -> AtomicOp -> (C.Type -> VName -> GC.CompilerM op s C.Type) -> GC.CompilerM op s ()
atomicOps :: forall op s.
Space
-> AtomicOp
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
atomicOps Space
space (AtomicCmpXchg PrimType
t VName
old VName
arr Count Elements (TExp Int32)
ind VName
res Exp
val) Type -> VName -> CompilerM op s Type
castf = do
  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 {k} (t :: k) 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 {k} (u :: k) e. Count u e -> e
unCount Count Elements (TExp Int32)
ind
  new_val' <- GC.compileExp val
  cast <- castf [C.cty|$ty:(GC.primTypeToCType t)|] arr
  arr' <- GC.rawMem arr space
  GC.stm
    [C.cstm|$id:res = $id:op(&(($ty:cast)$exp:arr')[$exp:ind'],
                 &$id:old,
                 $exp:new_val',
                 0, __ATOMIC_SEQ_CST, __ATOMIC_RELAXED);|]
  where
    op :: String
    op :: String
op = String
"__atomic_compare_exchange_n"
atomicOps Space
space (AtomicXchg PrimType
t VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val) Type -> VName -> CompilerM op s Type
castf = do
  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 {k} (t :: k) 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 {k} (u :: k) e. Count u e -> e
unCount Count Elements (TExp Int32)
ind
  val' <- GC.compileExp val
  cast <- castf [C.cty|$ty:(GC.primTypeToCType t)|] arr
  arr' <- GC.rawMem arr space
  GC.stm [C.cstm|$id:old = $id:op(&(($ty:cast)$exp:arr')[$exp:ind'], $exp:val', __ATOMIC_SEQ_CST);|]
  where
    op :: String
    op :: String
op = String
"__atomic_exchange_n"
atomicOps Space
space (AtomicLoad PrimType
t VName
ret VName
arr Count Elements (TExp Int32)
ind) Type -> VName -> CompilerM op s Type
castf = do
  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 {k} (t :: k) 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 {k} (u :: k) e. Count u e -> e
unCount Count Elements (TExp Int32)
ind
  cast <- castf [C.cty|$ty:(GC.primTypeToCType t)|] arr
  arr' <- GC.rawMem arr space
  GC.stm [C.cstm|$id:ret = $id:op(&(($ty:cast)$exp:arr')[$exp:ind'], __ATOMIC_ACQUIRE);|]
  where
    op :: String
    op :: String
op = String
"__atomic_load_n"
atomicOps Space
space (AtomicStore PrimType
t VName
arr Count Elements (TExp Int32)
ind Exp
val) Type -> VName -> CompilerM op s Type
castf = do
  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 {k} (t :: k) 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 {k} (u :: k) e. Count u e -> e
unCount Count Elements (TExp Int32)
ind
  val' <- GC.compileExp val
  cast <- castf [C.cty|$ty:(GC.primTypeToCType t)|] arr
  arr' <- GC.rawMem arr space
  GC.stm [C.cstm|$id:op(&(($ty:cast)$exp:arr')[$exp:ind'], $exp:val', __ATOMIC_RELEASE);|]
  where
    op :: String
    op :: String
op = String
"__atomic_store_n"
atomicOps Space
space (AtomicAdd IntType
t VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val) Type -> VName -> CompilerM op s Type
castf =
  Space
-> VName
-> VName
-> Count Elements (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
forall {k} a1 (m :: k) op s.
ToIdent a1 =>
Space
-> a1
-> VName
-> Count m (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
doAtomic Space
space VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val String
"__atomic_fetch_add" [C.cty|$ty:(GC.intTypeToCType t)|] Type -> VName -> CompilerM op s Type
castf
atomicOps Space
space (AtomicSub IntType
t VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val) Type -> VName -> CompilerM op s Type
castf =
  Space
-> VName
-> VName
-> Count Elements (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
forall {k} a1 (m :: k) op s.
ToIdent a1 =>
Space
-> a1
-> VName
-> Count m (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
doAtomic Space
space VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val String
"__atomic_fetch_sub" [C.cty|$ty:(GC.intTypeToCType t)|] Type -> VName -> CompilerM op s Type
castf
atomicOps Space
space (AtomicAnd IntType
t VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val) Type -> VName -> CompilerM op s Type
castf =
  Space
-> VName
-> VName
-> Count Elements (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
forall {k} a1 (m :: k) op s.
ToIdent a1 =>
Space
-> a1
-> VName
-> Count m (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
doAtomic Space
space VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val String
"__atomic_fetch_and" [C.cty|$ty:(GC.intTypeToCType t)|] Type -> VName -> CompilerM op s Type
castf
atomicOps Space
space (AtomicOr IntType
t VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val) Type -> VName -> CompilerM op s Type
castf =
  Space
-> VName
-> VName
-> Count Elements (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
forall {k} a1 (m :: k) op s.
ToIdent a1 =>
Space
-> a1
-> VName
-> Count m (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
doAtomic Space
space VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val String
"__atomic_fetch_or" [C.cty|$ty:(GC.intTypeToCType t)|] Type -> VName -> CompilerM op s Type
castf
atomicOps Space
space (AtomicXor IntType
t VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val) Type -> VName -> CompilerM op s Type
castf =
  Space
-> VName
-> VName
-> Count Elements (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
forall {k} a1 (m :: k) op s.
ToIdent a1 =>
Space
-> a1
-> VName
-> Count m (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
doAtomic Space
space VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val String
"__atomic_fetch_xor" [C.cty|$ty:(GC.intTypeToCType t)|] Type -> VName -> CompilerM op s Type
castf