{-# 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
-> ParamMap
-> Operations Multicore ()
-> CompilerM Multicore () ()
-> Text
-> (Space, [Space])
-> [Option]
-> Definitions Multicore
-> m CParts
forall (m :: * -> *) op.
MonadFreshNames m =>
Text
-> Text
-> ParamMap
-> Operations op ()
-> CompilerM op () ()
-> Text
-> (Space, [Space])
-> [Option]
-> Definitions op
-> m CParts
GC.compileProg
        Text
"multicore"
        Text
version
        ParamMap
forall a. Monoid a => a
mempty
        Operations Multicore ()
forall s. Operations Multicore s
operations
        CompilerM Multicore () ()
forall op s. CompilerM op s ()
generateBoilerplate
        Text
""
        (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
    { opsCompiler :: OpCompiler Multicore s
GC.opsCompiler = OpCompiler Multicore s
forall s. OpCompiler Multicore s
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 =
  String -> Name
nameFromString String
"free_" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> String -> Name
nameFromString (VName -> String
forall a. Pretty a => a -> String
prettyString 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
<> String -> Name
nameFromString (VName -> String
forall a. Pretty a => a -> String
prettyString VName
v)

data ValueType = Prim PrimType | 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, Prim PrimType
_) =
      [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, Prim PrimType
_) =
      [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
_, Prim PrimType
pt) =
      [C.cstm|$id:struct.$id:(closureFreeStructField name)=$exp:(toStorage pt (C.toExp name noLoc));|]
    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]
vnames [(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, ValueType) -> [Stm])
-> [VName] -> [(Type, ValueType)] -> [[Stm]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith VName -> (Type, ValueType) -> [Stm]
field [VName]
vnames [(Type, ValueType)]
we
  where
    field :: VName -> (Type, ValueType) -> [Stm]
field VName
name (Type
ct, Prim PrimType
_) =
      [C.cstms|$id:struct.$id:(closureRetvalStructField name)=(($ty:ct*)&$id:name);
               $escstm:("#if ISPC")
               $id:struct.$id:(closureRetvalStructField name)+= programIndex;
               $escstm:("#endif")|]
    field VName
name (Type
_, ValueType
MemBlock) =
      [C.cstms|$id:struct.$id:(closureRetvalStructField name)=$id:name.mem;|]
    field VName
name (Type
_, ValueType
RawMem) =
      [C.cstms|$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, Prim PrimType
pt) =
      let inner :: Exp
inner = [C.cexp|*$id:struct->$id:(closureRetvalStructField name)|]
       in [C.cdecl|$ty:ty $id:name = $exp:(fromStorage pt inner);|]
    field VName
name (Type
ty, 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, 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, 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, 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, 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
_, Prim PrimType
pt) =
      [C.cstm|*$id:struct->$id:(closureRetvalStructField name) = $exp:(toStorage pt (C.toExp name noLoc));|]
    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
primStorageType 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 (Type
t, PrimType -> ValueType
Prim PrimType
pt)
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 a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( Space -> Type
GC.fatMemType Space
space,
      if Bool
refcount Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
cached
        then ValueType
MemBlock
        else ValueType
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
  VName
event <- String -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => String -> m VName
newVName String
"event"
  [BlockItem] -> CompilerM op s [BlockItem]
forall a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
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),
                 strdup("nothing further"),
                 $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 :: String -> GC.CompilerM op s Name
multicoreName :: forall op s. String -> CompilerM op s Name
multicoreName String
s = do
  VName
s' <- String -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => String -> m VName
newVName (String
"futhark_mc_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
  Name -> CompilerM op s Name
forall a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> CompilerM op s Name) -> Name -> CompilerM op s Name
forall a b. (a -> b) -> a -> b
$ String -> Name
nameFromString (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ VName -> String
baseString VName
s' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (VName -> Int
baseTag VName
s')

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

multicoreDef :: DefSpecifier s
multicoreDef :: forall s. DefSpecifier s
multicoreDef String
s Name -> CompilerM Multicore s Definition
f = do
  Name
s' <- String -> CompilerM Multicore s Name
forall op s. String -> CompilerM op s Name
multicoreName String
s
  Definition -> CompilerM Multicore s ()
forall op s. Definition -> CompilerM op s ()
GC.libDecl (Definition -> CompilerM Multicore s ())
-> CompilerM Multicore s Definition -> CompilerM Multicore s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> CompilerM Multicore s Definition
f Name
s'
  Name -> CompilerM Multicore s Name
forall a. a -> CompilerM Multicore s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
s'

generateParLoopFn ::
  (C.ToIdent a) =>
  M.Map VName Space ->
  String ->
  MCCode ->
  a ->
  [(VName, (C.Type, ValueType))] ->
  [(VName, (C.Type, ValueType))] ->
  GC.CompilerM Multicore s Name
generateParLoopFn :: forall a s.
ToIdent a =>
Map VName Space
-> String
-> MCCode
-> a
-> [(VName, (Type, ValueType))]
-> [(VName, (Type, ValueType))]
-> CompilerM Multicore s Name
generateParLoopFn Map VName Space
lexical String
basename MCCode
code a
fstruct [(VName, (Type, ValueType))]
free [(VName, (Type, ValueType))]
retval = 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
  DefSpecifier s
forall s. DefSpecifier s
multicoreDef String
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 -> [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)|]
        [BlockItem]
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
        (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 -> 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] -> CompilerM Multicore s ())
-> CompilerM Multicore s [BlockItem] -> CompilerM Multicore s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CompilerM Multicore s [BlockItem]
forall op s. CompilerM op s [BlockItem]
GC.declAllocatedMem
        (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]
code'
        [BlockItem]
free_mem <- CompilerM Multicore s [BlockItem]
forall op s. CompilerM op s [BlockItem]
GC.freeAllocatedMem
        Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|cleanup: {$stms:free_cached $items:free_mem}|]
    Definition -> CompilerM Multicore s Definition
forall a. a -> CompilerM Multicore s a
forall (f :: * -> *) a. Applicative f => a -> f a
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 ->
  String ->
  [VName] ->
  [(C.Type, ValueType)] ->
  [VName] ->
  [(C.Type, ValueType)] ->
  GC.CompilerM Multicore s Name
prepareTaskStruct :: forall s.
DefSpecifier s
-> String
-> [VName]
-> [(Type, ValueType)]
-> [VName]
-> [(Type, ValueType)]
-> CompilerM Multicore s Name
prepareTaskStruct DefSpecifier s
def String
name [VName]
free_args [(Type, ValueType)]
free_ctypes [VName]
retval_args [(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)
                     };|]
  Name
fstruct <- DefSpecifier s
def String
name Name -> CompilerM Multicore s Definition
forall {f :: * -> *} {a}.
(Applicative f, ToIdent a) =>
a -> f Definition
makeStruct
  let fstruct' :: Name
fstruct' = Name
fstruct Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_"
  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 a. a -> CompilerM Multicore s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
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 String
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
  [(Type, ValueType)]
free_ctypes <- (Param -> CompilerM Multicore s (Type, ValueType))
-> [Param] -> CompilerM Multicore s [(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, ValueType)
forall op s. Param -> CompilerM op s (Type, ValueType)
paramToCType [Param]
params
  [(Type, ValueType)]
retval_ctypes <- (Param -> CompilerM Multicore s (Type, ValueType))
-> [Param] -> CompilerM Multicore s [(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, 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 s Exp
forall op s. Exp -> CompilerM op s Exp
GC.compileExp Exp
e

  let lexical :: Map VName Space
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] -> MCCode -> Function Multicore
forall a.
Maybe EntryPoint -> [Param] -> [Param] -> Code a -> FunctionT a
Function Maybe EntryPoint
forall a. Maybe a
Nothing [] [Param]
params MCCode
seq_code

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

  Name
fpar_task <- Map VName Space
-> String
-> MCCode
-> Name
-> [(VName, (Type, ValueType))]
-> [(VName, (Type, ValueType))]
-> CompilerM Multicore s Name
forall a s.
ToIdent a =>
Map VName Space
-> String
-> MCCode
-> a
-> [(VName, (Type, ValueType))]
-> [(VName, (Type, ValueType))]
-> CompilerM Multicore s Name
generateParLoopFn Map VName Space
lexical (String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_task") MCCode
seq_code Name
fstruct [(VName, (Type, ValueType))]
free [(VName, (Type, ValueType))]
retval
  Name -> CompilerM Multicore s ()
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 s ()
forall op s. InitGroup -> CompilerM op s ()
GC.decl [C.cdecl|struct scheduler_segop $id:ftask_name;|]
  Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.args = &$id:(fstruct <> "_");|]
  Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.top_level_fn = $id:fpar_task;|]
  Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.name = $string:(nameToString fpar_task);|]
  Stm -> CompilerM Multicore s ()
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 s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.task_time = &ctx->program->$id:(functionTiming fpar_task);|]
  Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.task_iter = &ctx->program->$id:(functionIterations fpar_task);|]

  case Scheduling
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 Maybe ParallelTask
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] -> MCCode -> Function Multicore
forall a.
Maybe EntryPoint -> [Param] -> [Param] -> Code a -> FunctionT a
Function Maybe EntryPoint
forall a. Maybe a
Nothing [] [Param]
params MCCode
nested_code
      Name
fnpar_task <- Map VName Space
-> String
-> MCCode
-> Name
-> [(VName, (Type, ValueType))]
-> [(VName, (Type, ValueType))]
-> CompilerM Multicore s Name
forall a s.
ToIdent a =>
Map VName Space
-> String
-> MCCode
-> a
-> [(VName, (Type, ValueType))]
-> [(VName, (Type, ValueType))]
-> CompilerM Multicore s Name
generateParLoopFn Map VName Space
lexical_nested (String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_nested_task") MCCode
nested_code Name
fstruct [(VName, (Type, ValueType))]
free [(VName, (Type, ValueType))]
retval
      Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
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
ftask_err = Name
fpar_task Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_err"
      code :: [BlockItem]
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;
                  }|]

  (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]
code
compileOp (ParLoop String
s' MCCode
body [Param]
free) = do
  [(Type, ValueType)]
free_ctypes <- (Param -> CompilerM Multicore s (Type, ValueType))
-> [Param] -> CompilerM Multicore s [(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, 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 = 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] -> MCCode -> Function Multicore
forall a.
Maybe EntryPoint -> [Param] -> [Param] -> Code a -> FunctionT a
Function Maybe EntryPoint
forall a. Maybe a
Nothing [] [Param]
free MCCode
body

  Name
fstruct <-
    DefSpecifier s
-> String
-> [VName]
-> [(Type, ValueType)]
-> [VName]
-> [(Type, ValueType)]
-> CompilerM Multicore s Name
forall s.
DefSpecifier s
-> String
-> [VName]
-> [(Type, ValueType)]
-> [VName]
-> [(Type, ValueType)]
-> CompilerM Multicore s Name
prepareTaskStruct DefSpecifier s
forall s. DefSpecifier s
multicoreDef (String
s' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_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 <- DefSpecifier s
forall s. DefSpecifier s
multicoreDef (String
s' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_parloop") ((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 -> [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;|]

        [BlockItem]
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

        (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 -> 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] -> CompilerM Multicore s ())
-> CompilerM Multicore s [BlockItem] -> CompilerM Multicore s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CompilerM Multicore s [BlockItem]
forall op s. CompilerM op s [BlockItem]
GC.declAllocatedMem
        [BlockItem]
free_mem <- CompilerM Multicore s [BlockItem]
forall op s. CompilerM op s [BlockItem]
GC.freeAllocatedMem
        (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]
body'
        Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|cleanup: {$stms:free_cached $items:free_mem}|]
    Definition -> CompilerM Multicore s Definition
forall a. a -> CompilerM Multicore s a
forall (f :: * -> *) a. Applicative f => a -> f a
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
ftask Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_task"
  InitGroup -> CompilerM Multicore s ()
forall op s. InitGroup -> CompilerM op s ()
GC.decl [C.cdecl|struct scheduler_parloop $id:ftask_name;|]
  Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.name = $string:(nameToString ftask);|]
  Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.fn = $id:ftask;|]
  Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.args = &$id:(fstruct <> "_");|]
  Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.iterations = iterations;|]
  Stm -> CompilerM Multicore s ()
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 -> [BlockItem] -> CompilerM Multicore s [BlockItem]
forall op s. Name -> [BlockItem] -> CompilerM op s [BlockItem]
benchmarkCode
      Name
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;
               }|]

  (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]
code'
compileOp (Atomic AtomicOp
aop) =
  AtomicOp
-> (Type -> VName -> CompilerM Multicore s Type)
-> CompilerM Multicore s ()
forall op s.
AtomicOp
-> (Type -> VName -> CompilerM op s Type) -> CompilerM op s ()
atomicOps 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
  Exp
from' <- Exp -> CompilerM Multicore s Exp
forall op s. Exp -> CompilerM op s Exp
GC.compileExp Exp
from
  Exp
bound' <- Exp -> CompilerM Multicore s Exp
forall op s. Exp -> CompilerM op s Exp
GC.compileExp Exp
bound
  [BlockItem]
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
  Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
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
  Exp
tar' <- Exp -> CompilerM Multicore s Exp
forall op s. Exp -> CompilerM op s Exp
GC.compileExp Exp
tar
  Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:dest = $exp:tar';|]

scopedBlock :: MCCode -> GC.CompilerM Multicore s ()
scopedBlock :: forall s. MCCode -> CompilerM Multicore s ()
scopedBlock MCCode
code = do
  [BlockItem]
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
  Stm -> CompilerM Multicore s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|{$items:inner}|]

doAtomic ::
  (C.ToIdent a1) =>
  a1 ->
  VName ->
  Count u (TExp Int32) ->
  Exp ->
  String ->
  C.Type ->
  (C.Type -> VName -> GC.CompilerM op s C.Type) ->
  GC.CompilerM op s ()
doAtomic :: forall {k} a1 (u :: k) op s.
ToIdent a1 =>
a1
-> VName
-> Count u (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
doAtomic a1
old VName
arr Count u (TExp Int32)
ind Exp
val String
op Type
ty Type -> VName -> CompilerM op s Type
castf = 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 {k} (t :: k) 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 {k} (u :: k) 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
  Type
cast <- Type -> VName -> CompilerM op s Type
castf Type
ty VName
arr
  Exp
arr' <- VName -> CompilerM op s Exp
forall op s. VName -> CompilerM op s Exp
GC.rawMem VName
arr
  Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:old = $id:op(&(($ty:cast)$exp:arr')[$exp:ind'], ($ty:ty) $exp:val', __ATOMIC_RELAXED);|]

atomicOps :: AtomicOp -> (C.Type -> VName -> GC.CompilerM op s C.Type) -> GC.CompilerM op s ()
atomicOps :: forall op s.
AtomicOp
-> (Type -> VName -> CompilerM op s Type) -> CompilerM op s ()
atomicOps (AtomicCmpXchg PrimType
t VName
old VName
arr Count Elements (TExp Int32)
ind VName
res Exp
val) Type -> VName -> CompilerM op s Type
castf = 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 {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
  Exp
new_val' <- Exp -> CompilerM op s Exp
forall op s. Exp -> CompilerM op s Exp
GC.compileExp Exp
val
  Type
cast <- Type -> VName -> CompilerM op s Type
castf [C.cty|$ty:(GC.primTypeToCType t)|] VName
arr
  Exp
arr' <- VName -> CompilerM op s Exp
forall op s. VName -> CompilerM op s Exp
GC.rawMem VName
arr
  Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
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 (AtomicXchg PrimType
t VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val) Type -> VName -> CompilerM op s Type
castf = 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 {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
  Exp
val' <- Exp -> CompilerM op s Exp
forall op s. Exp -> CompilerM op s Exp
GC.compileExp Exp
val
  Type
cast <- Type -> VName -> CompilerM op s Type
castf [C.cty|$ty:(GC.primTypeToCType t)|] VName
arr
  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 :: String
op = String
"__atomic_exchange_n"
atomicOps (AtomicAdd IntType
t VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val) Type -> VName -> CompilerM op s Type
castf =
  VName
-> VName
-> Count Elements (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
forall {k} a1 (u :: k) op s.
ToIdent a1 =>
a1
-> VName
-> Count u (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
doAtomic 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 (AtomicSub IntType
t VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val) Type -> VName -> CompilerM op s Type
castf =
  VName
-> VName
-> Count Elements (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
forall {k} a1 (u :: k) op s.
ToIdent a1 =>
a1
-> VName
-> Count u (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
doAtomic 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 (AtomicAnd IntType
t VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val) Type -> VName -> CompilerM op s Type
castf =
  VName
-> VName
-> Count Elements (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
forall {k} a1 (u :: k) op s.
ToIdent a1 =>
a1
-> VName
-> Count u (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
doAtomic 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 (AtomicOr IntType
t VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val) Type -> VName -> CompilerM op s Type
castf =
  VName
-> VName
-> Count Elements (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
forall {k} a1 (u :: k) op s.
ToIdent a1 =>
a1
-> VName
-> Count u (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
doAtomic 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 (AtomicXor IntType
t VName
old VName
arr Count Elements (TExp Int32)
ind Exp
val) Type -> VName -> CompilerM op s Type
castf =
  VName
-> VName
-> Count Elements (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
forall {k} a1 (u :: k) op s.
ToIdent a1 =>
a1
-> VName
-> Count u (TExp Int32)
-> Exp
-> String
-> Type
-> (Type -> VName -> CompilerM op s Type)
-> CompilerM op s ()
doAtomic 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