{-# LANGUAGE QuasiQuotes #-}

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

import Control.Lens (each, over)
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State
import Data.Bifunctor
import Data.DList qualified as DL
import Data.List (unzip4)
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.Pretty
import Futhark.CodeGen.Backends.MulticoreC qualified as MC
import Futhark.CodeGen.Backends.MulticoreC.Boilerplate (generateBoilerplate)
import Futhark.CodeGen.Backends.SimpleRep
import Futhark.CodeGen.ImpCode.Multicore
import Futhark.CodeGen.ImpGen.Multicore qualified as ImpGen
import Futhark.CodeGen.RTS.C (errorsH, ispcUtilH, uniformH)
import Futhark.IR.MCMem (MCMem, Prog)
import Futhark.IR.Prop (isBuiltInFunction)
import Futhark.MonadFreshNames
import Language.C.Quote.OpenCL qualified as C
import Language.C.Syntax qualified as C
import NeatInterpolation (untrimming)

type ISPCCompilerM a = GC.CompilerM Multicore ISPCState a

-- | Transient state tracked by the ISPC backend.
data ISPCState = ISPCState
  { ISPCState -> DList Definition
sDefs :: DL.DList C.Definition,
    ISPCState -> Names
sUniform :: Names
  }

uniform :: C.TypeQual
uniform :: TypeQual
uniform = String -> SrcLoc -> TypeQual
C.EscTypeQual String
"uniform" SrcLoc
forall a. IsLocation a => a
noLoc

unmasked :: C.TypeQual
unmasked :: TypeQual
unmasked = String -> SrcLoc -> TypeQual
C.EscTypeQual String
"unmasked" SrcLoc
forall a. IsLocation a => a
noLoc

export :: C.TypeQual
export :: TypeQual
export = String -> SrcLoc -> TypeQual
C.EscTypeQual String
"export" SrcLoc
forall a. IsLocation a => a
noLoc

varying :: C.TypeQual
varying :: TypeQual
varying = String -> SrcLoc -> TypeQual
C.EscTypeQual String
"varying" SrcLoc
forall a. IsLocation a => a
noLoc

-- | Compile the program to C and ISPC code using multicore operations.
compileProg ::
  (MonadFreshNames m) => T.Text -> Prog MCMem -> m (ImpGen.Warnings, (GC.CParts, T.Text))
compileProg :: forall (m :: * -> *).
MonadFreshNames m =>
Text -> Prog MCMem -> m (Warnings, (CParts, Text))
compileProg Text
version Prog MCMem
prog = do
  -- Dynamic scheduling seems completely broken currently, so we disable it.
  (Warnings
ws, Definitions Multicore
defs) <- Prog MCMem -> m (Warnings, Definitions Multicore)
forall (m :: * -> *).
MonadFreshNames m =>
Prog MCMem -> m (Warnings, Definitions Multicore)
ImpGen.compileProg Prog MCMem
prog
  let Functions [(Name, Function Multicore)]
funs = Definitions Multicore -> Functions Multicore
forall a. Definitions a -> Functions a
defFuns Definitions Multicore
defs

  (Warnings
ws', (CParts
cparts, CompilerState ISPCState
endstate)) <-
    (Definitions Multicore -> m (CParts, CompilerState ISPCState))
-> (Warnings, Definitions Multicore)
-> m (Warnings, (CParts, CompilerState ISPCState))
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 ISPCState
-> ISPCState
-> CompilerM Multicore ISPCState ()
-> Text
-> (Space, [Space])
-> [Option]
-> Definitions Multicore
-> m (CParts, CompilerState ISPCState)
forall (m :: * -> *) op s.
MonadFreshNames m =>
Text
-> Text
-> ParamMap
-> Operations op s
-> s
-> CompilerM op s ()
-> Text
-> (Space, [Space])
-> [Option]
-> Definitions op
-> m (CParts, CompilerState s)
GC.compileProg'
          Text
"ispc"
          Text
version
          ParamMap
forall a. Monoid a => a
mempty
          Operations Multicore ISPCState
operations
          (DList Definition -> Names -> ISPCState
ISPCState DList Definition
forall a. Monoid a => a
mempty Names
forall a. Monoid a => a
mempty)
          ( do
              CompilerM Multicore ISPCState ()
forall op s. CompilerM op s ()
generateBoilerplate
              ((Name, Function Multicore) -> CompilerM Multicore ISPCState ())
-> [(Name, Function Multicore)] -> CompilerM Multicore ISPCState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name, Function Multicore) -> CompilerM Multicore ISPCState ()
forall op. (Name, Function op) -> CompilerM Multicore ISPCState ()
compileBuiltinFun [(Name, Function Multicore)]
funs
          )
          Text
"#include <pthread.h>\n"
          (Space
DefaultSpace, [Space
DefaultSpace])
          [Option]
MC.cliOptions
      )
      (Warnings
ws, Definitions Multicore
defs)

  let ispc_decls :: Text
ispc_decls = [Definition] -> Text
definitionsText ([Definition] -> Text) -> [Definition] -> Text
forall a b. (a -> b) -> a -> b
$ DList Definition -> [Definition]
forall a. DList a -> [a]
DL.toList (DList Definition -> [Definition])
-> DList Definition -> [Definition]
forall a b. (a -> b) -> a -> b
$ ISPCState -> DList Definition
sDefs (ISPCState -> DList Definition) -> ISPCState -> DList Definition
forall a b. (a -> b) -> a -> b
$ CompilerState ISPCState -> ISPCState
forall s. CompilerState s -> s
GC.compUserState CompilerState ISPCState
endstate

  -- The bool #define is a workaround around an ISPC bug, stdbool doesn't get included.
  let ispcdefs :: Text
ispcdefs =
        [untrimming|
#define bool uint8
typedef int64 int64_t;
typedef int32 int32_t;
typedef int16 int16_t;
typedef int8 int8_t;
typedef int8 char;
typedef unsigned int64 uint64_t;
typedef unsigned int32 uint32_t;
typedef unsigned int16 uint16_t;
typedef unsigned int8 uint8_t;
#define volatile
#define SCALAR_FUN_ATTR static inline

$errorsH

#define INFINITY (floatbits((uniform int)0x7f800000))
#define NAN (floatbits((uniform int)0x7fc00000))
#define fabs(x) abs(x)
#define FUTHARK_F64_ENABLED
$cScalarDefs

$uniformH

$ispcUtilH

$ispc_decls|]

  (Warnings, (CParts, Text)) -> m (Warnings, (CParts, Text))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Warnings
ws', (CParts
cparts, Text
ispcdefs))

-- | Compiler operations specific to the ISPC multicore backend.
operations :: GC.Operations Multicore ISPCState
operations :: Operations Multicore ISPCState
operations =
  Operations Multicore ISPCState
forall s. Operations Multicore s
MC.operations
    { GC.opsCompiler = compileOp,
      -- FIXME: the default codegen for LMAD copies does not work for ISPC.
      GC.opsCopies = mempty
    }

ispcDecl :: C.Definition -> ISPCCompilerM ()
ispcDecl :: Definition -> CompilerM Multicore ISPCState ()
ispcDecl Definition
def =
  (ISPCState -> ISPCState) -> CompilerM Multicore ISPCState ()
forall s op. (s -> s) -> CompilerM op s ()
GC.modifyUserState (\ISPCState
s -> ISPCState
s {sDefs = sDefs s <> DL.singleton def})

ispcEarlyDecl :: C.Definition -> ISPCCompilerM ()
ispcEarlyDecl :: Definition -> CompilerM Multicore ISPCState ()
ispcEarlyDecl Definition
def =
  (ISPCState -> ISPCState) -> CompilerM Multicore ISPCState ()
forall s op. (s -> s) -> CompilerM op s ()
GC.modifyUserState (\ISPCState
s -> ISPCState
s {sDefs = DL.singleton def <> sDefs s})

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

-- | Expose a struct to both ISPC and C.
sharedDef :: MC.DefSpecifier ISPCState
sharedDef :: DefSpecifier ISPCState
sharedDef String
s Name -> CompilerM Multicore ISPCState Definition
f = do
  Name
s' <- String -> CompilerM Multicore ISPCState Name
forall op s. String -> CompilerM op s Name
MC.multicoreName String
s
  Definition -> CompilerM Multicore ISPCState ()
ispcDecl (Definition -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState Definition
-> CompilerM Multicore ISPCState ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> CompilerM Multicore ISPCState Definition
f Name
s'
  Definition -> CompilerM Multicore ISPCState ()
forall op s. Definition -> CompilerM op s ()
GC.earlyDecl (Definition -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState Definition
-> CompilerM Multicore ISPCState ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> CompilerM Multicore ISPCState Definition
f Name
s'
  Name -> CompilerM Multicore ISPCState Name
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
s'

-- | ISPC has no string literals, so this makes one in C and exposes it via an
-- external function, returning the name.
makeStringLiteral :: String -> ISPCCompilerM Name
makeStringLiteral :: String -> CompilerM Multicore ISPCState Name
makeStringLiteral String
str = do
  Name
name <- DefSpecifier ISPCState
forall s. DefSpecifier s
MC.multicoreDef String
"strlit_shim" ((Name -> CompilerM Multicore ISPCState Definition)
 -> CompilerM Multicore ISPCState Name)
-> (Name -> CompilerM Multicore ISPCState Definition)
-> CompilerM Multicore ISPCState Name
forall a b. (a -> b) -> a -> b
$ \Name
s ->
    Definition -> CompilerM Multicore ISPCState Definition
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cedecl|char* $id:s() { return $string:str; }|]
  Definition -> CompilerM Multicore ISPCState ()
ispcDecl
    [C.cedecl|extern "C" $tyqual:unmasked $tyqual:uniform char* $tyqual:uniform $id:name();|]
  Name -> CompilerM Multicore ISPCState Name
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
name

-- | Set memory in ISPC
setMem :: (C.ToExp a, C.ToExp b) => a -> b -> Space -> ISPCCompilerM ()
setMem :: forall a b.
(ToExp a, ToExp b) =>
a -> b -> Space -> CompilerM Multicore ISPCState ()
setMem a
dest b
src Space
space = do
  let src_s :: String
src_s = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Exp -> Text
expText (Exp -> Text) -> Exp -> Text
forall a b. (a -> b) -> a -> b
$ b -> SrcLoc -> Exp
forall a. ToExp a => a -> SrcLoc -> Exp
C.toExp b
src SrcLoc
forall a. IsLocation a => a
noLoc
  Name
strlit <- String -> CompilerM Multicore ISPCState Name
makeStringLiteral String
src_s
  Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm
    [C.cstm|if ($id:(GC.fatMemSet space)(ctx, &$exp:dest, &$exp:src,
                                            $id:strlit()) != 0) {
                    $escstm:("unmasked { return 1; }")
                  }|]

-- | Unref memory in ISPC
unRefMem :: (C.ToExp a) => a -> Space -> ISPCCompilerM ()
unRefMem :: forall a. ToExp a => a -> Space -> CompilerM Multicore ISPCState ()
unRefMem a
mem Space
space = do
  Bool
cached <- Maybe VName -> Bool
forall a. Maybe a -> Bool
isJust (Maybe VName -> Bool)
-> CompilerM Multicore ISPCState (Maybe VName)
-> CompilerM Multicore ISPCState Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> CompilerM Multicore ISPCState (Maybe VName)
forall a op s. ToExp a => a -> CompilerM op s (Maybe VName)
GC.cacheMem a
mem
  let mem_s :: String
mem_s = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Exp -> Text
expText (Exp -> Text) -> Exp -> Text
forall a b. (a -> b) -> a -> b
$ a -> SrcLoc -> Exp
forall a. ToExp a => a -> SrcLoc -> Exp
C.toExp a
mem SrcLoc
forall a. IsLocation a => a
noLoc
  Name
strlit <- String -> CompilerM Multicore ISPCState Name
makeStringLiteral String
mem_s
  Bool
-> CompilerM Multicore ISPCState ()
-> CompilerM Multicore ISPCState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
cached (CompilerM Multicore ISPCState ()
 -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState ()
-> CompilerM Multicore ISPCState ()
forall a b. (a -> b) -> a -> b
$
    Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm
      [C.cstm|if ($id:(GC.fatMemUnRef space)(ctx, &$exp:mem, $id:strlit()) != 0) {
                  $escstm:("unmasked { return 1; }")
                }|]

-- | Allocate memory in ISPC
allocMem ::
  (C.ToExp a, C.ToExp b) =>
  a ->
  b ->
  Space ->
  C.Stm ->
  ISPCCompilerM ()
allocMem :: forall a b.
(ToExp a, ToExp b) =>
a -> b -> Space -> Stm -> CompilerM Multicore ISPCState ()
allocMem a
mem b
size Space
space Stm
on_failure = do
  let mem_s :: String
mem_s = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Exp -> Text
expText (Exp -> Text) -> Exp -> Text
forall a b. (a -> b) -> a -> b
$ a -> SrcLoc -> Exp
forall a. ToExp a => a -> SrcLoc -> Exp
C.toExp a
mem SrcLoc
forall a. IsLocation a => a
noLoc
  Name
strlit <- String -> CompilerM Multicore ISPCState Name
makeStringLiteral String
mem_s
  Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm
    [C.cstm|if ($id:(GC.fatMemAlloc space)(ctx, &$exp:mem, $exp:size, $id:strlit())) {
                    $stm:on_failure
            }|]

-- | Free memory in ISPC
freeAllocatedMem :: ISPCCompilerM [C.BlockItem]
freeAllocatedMem :: ISPCCompilerM [BlockItem]
freeAllocatedMem = CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
GC.collect (CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem])
-> CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall a b. (a -> b) -> a -> b
$ ((VName, Space) -> CompilerM Multicore ISPCState ())
-> [(VName, Space)] -> CompilerM Multicore ISPCState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((VName -> Space -> CompilerM Multicore ISPCState ())
-> (VName, Space) -> CompilerM Multicore ISPCState ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry VName -> Space -> CompilerM Multicore ISPCState ()
forall a. ToExp a => a -> Space -> CompilerM Multicore ISPCState ()
unRefMem) ([(VName, Space)] -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState [(VName, Space)]
-> CompilerM Multicore ISPCState ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (CompilerState ISPCState -> [(VName, Space)])
-> CompilerM Multicore ISPCState [(VName, Space)]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState ISPCState -> [(VName, Space)]
forall s. CompilerState s -> [(VName, Space)]
GC.compDeclaredMem

-- | Given a ImpCode function, generate all the required machinery for calling
-- it in ISPC, both in a varying or uniform context. This involves handling
-- for the fact that ISPC cannot pass structs by value to external functions.
compileBuiltinFun :: (Name, Function op) -> ISPCCompilerM ()
compileBuiltinFun :: forall op. (Name, Function op) -> CompilerM Multicore ISPCState ()
compileBuiltinFun (Name
fname, func :: Function op
func@(Function Maybe EntryPoint
_ [Param]
outputs [Param]
inputs Code op
_))
  | Maybe EntryPoint -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe EntryPoint -> Bool) -> Maybe EntryPoint -> Bool
forall a b. (a -> b) -> a -> b
$ Function op -> Maybe EntryPoint
forall a. FunctionT a -> Maybe EntryPoint
functionEntry Function op
func = do
      let extra :: [Param]
extra = [[C.cparam|$tyqual:uniform struct futhark_context * $tyqual:uniform ctx|]]
          extra_c :: [Param]
extra_c = [[C.cparam|struct futhark_context * ctx|]]
          extra_exp :: [Exp]
extra_exp = [[C.cexp|$id:p|] | C.Param (Just Id
p) DeclSpec
_ Decl
_ SrcLoc
_ <- [Param]
extra]

      ([Param]
inparams_c, [Exp]
in_args_c) <- (Param -> CompilerM Multicore ISPCState (Param, Exp))
-> [Param] -> CompilerM Multicore ISPCState ([Param], [Exp])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM ([TypeQual] -> Param -> CompilerM Multicore ISPCState (Param, Exp)
forall {op} {s}. [TypeQual] -> Param -> CompilerM op s (Param, Exp)
compileInputsExtern []) [Param]
inputs
      ([Param]
outparams_c, [Exp]
out_args_c) <- (Param -> CompilerM Multicore ISPCState (Param, Exp))
-> [Param] -> CompilerM Multicore ISPCState ([Param], [Exp])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM ([TypeQual] -> Param -> CompilerM Multicore ISPCState (Param, Exp)
forall {op} {s}. [TypeQual] -> Param -> CompilerM op s (Param, Exp)
compileOutputsExtern []) [Param]
outputs

      ([Param]
inparams_extern, [Exp]
_) <- (Param -> CompilerM Multicore ISPCState (Param, Exp))
-> [Param] -> CompilerM Multicore ISPCState ([Param], [Exp])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM ([TypeQual] -> Param -> CompilerM Multicore ISPCState (Param, Exp)
forall {op} {s}. [TypeQual] -> Param -> CompilerM op s (Param, Exp)
compileInputsExtern [C.ctyquals|$tyqual:uniform|]) [Param]
inputs
      ([Param]
outparams_extern, [Exp]
_) <- (Param -> CompilerM Multicore ISPCState (Param, Exp))
-> [Param] -> CompilerM Multicore ISPCState ([Param], [Exp])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM ([TypeQual] -> Param -> CompilerM Multicore ISPCState (Param, Exp)
forall {op} {s}. [TypeQual] -> Param -> CompilerM op s (Param, Exp)
compileOutputsExtern [C.ctyquals|$tyqual:uniform|]) [Param]
outputs

      ([Param]
inparams_uni, [Exp]
in_args_noderef) <- (Param -> CompilerM Multicore ISPCState (Param, Exp))
-> [Param] -> CompilerM Multicore ISPCState ([Param], [Exp])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM Param -> CompilerM Multicore ISPCState (Param, Exp)
forall {op} {s}. Param -> CompilerM op s (Param, Exp)
compileInputsUniform [Param]
inputs
      ([Param]
outparams_uni, [Exp]
out_args_noderef) <- (Param -> CompilerM Multicore ISPCState (Param, Exp))
-> [Param] -> CompilerM Multicore ISPCState ([Param], [Exp])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM Param -> CompilerM Multicore ISPCState (Param, Exp)
forall {op} {s}. Param -> CompilerM op s (Param, Exp)
compileOutputsUniform [Param]
outputs

      ([Param]
inparams_varying, [Exp]
in_args_vary, [[BlockItem]]
prebody_in') <- [(Param, Exp, [BlockItem])] -> ([Param], [Exp], [[BlockItem]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(Param, Exp, [BlockItem])] -> ([Param], [Exp], [[BlockItem]]))
-> CompilerM Multicore ISPCState [(Param, Exp, [BlockItem])]
-> CompilerM Multicore ISPCState ([Param], [Exp], [[BlockItem]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Param -> CompilerM Multicore ISPCState (Param, Exp, [BlockItem]))
-> [Param]
-> CompilerM Multicore ISPCState [(Param, Exp, [BlockItem])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Param -> CompilerM Multicore ISPCState (Param, Exp, [BlockItem])
forall {op} {s}. Param -> CompilerM op s (Param, Exp, [BlockItem])
compileInputsVarying [Param]
inputs
      ([Param]
outparams_varying, [Exp]
out_args_vary, [[BlockItem]]
prebody_out', [[BlockItem]]
postbody_out') <- [(Param, Exp, [BlockItem], [BlockItem])]
-> ([Param], [Exp], [[BlockItem]], [[BlockItem]])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([(Param, Exp, [BlockItem], [BlockItem])]
 -> ([Param], [Exp], [[BlockItem]], [[BlockItem]]))
-> CompilerM
     Multicore ISPCState [(Param, Exp, [BlockItem], [BlockItem])]
-> CompilerM
     Multicore ISPCState ([Param], [Exp], [[BlockItem]], [[BlockItem]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Param
 -> CompilerM
      Multicore ISPCState (Param, Exp, [BlockItem], [BlockItem]))
-> [Param]
-> CompilerM
     Multicore ISPCState [(Param, Exp, [BlockItem], [BlockItem])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Param
-> CompilerM
     Multicore ISPCState (Param, Exp, [BlockItem], [BlockItem])
forall {op} {s}.
Param -> CompilerM op s (Param, Exp, [BlockItem], [BlockItem])
compileOutputsVarying [Param]
outputs
      let ([BlockItem]
prebody_in, [BlockItem]
prebody_out, [BlockItem]
postbody_out) = ASetter
  ([[BlockItem]], [[BlockItem]], [[BlockItem]])
  ([BlockItem], [BlockItem], [BlockItem])
  [[BlockItem]]
  [BlockItem]
-> ([[BlockItem]] -> [BlockItem])
-> ([[BlockItem]], [[BlockItem]], [[BlockItem]])
-> ([BlockItem], [BlockItem], [BlockItem])
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  ([[BlockItem]], [[BlockItem]], [[BlockItem]])
  ([BlockItem], [BlockItem], [BlockItem])
  [[BlockItem]]
  [BlockItem]
forall s t a b. Each s t a b => Traversal s t a b
Traversal
  ([[BlockItem]], [[BlockItem]], [[BlockItem]])
  ([BlockItem], [BlockItem], [BlockItem])
  [[BlockItem]]
  [BlockItem]
each [[BlockItem]] -> [BlockItem]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[BlockItem]]
prebody_in', [[BlockItem]]
prebody_out', [[BlockItem]]
postbody_out')

      Definition -> CompilerM Multicore ISPCState ()
forall op s. Definition -> CompilerM op s ()
GC.libDecl
        [C.cedecl|int $id:(funName fname <> "_extern")($params:extra_c, $params:outparams_c, $params:inparams_c) {
                  return $id:(funName fname)($args:extra_exp, $args:out_args_c, $args:in_args_c);
                }|]

      let ispc_extern :: Definition
ispc_extern =
            [C.cedecl|extern "C" $tyqual:unmasked $tyqual:uniform int $id:((funName fname) <> "_extern")
                      ($params:extra, $params:outparams_extern, $params:inparams_extern);|]

          ispc_uniform :: Definition
ispc_uniform =
            [C.cedecl|$tyqual:uniform int $id:(funName fname)
                    ($params:extra, $params:outparams_uni, $params:inparams_uni) {
                      return $id:(funName (fname<>"_extern"))(
                        $args:extra_exp,
                        $args:out_args_noderef,
                        $args:in_args_noderef);
                    }|]

          ispc_varying :: Definition
ispc_varying =
            [C.cedecl|$tyqual:uniform int $id:(funName fname)
                    ($params:extra, $params:outparams_varying, $params:inparams_varying) {
                        $tyqual:uniform int err = 0;
                        $items:prebody_in
                        $items:prebody_out
                        $escstm:("foreach_active (i)")
                        {
                          err |= $id:(funName $ fname<>"_extern")(
                            $args:extra_exp,
                            $args:out_args_vary,
                            $args:in_args_vary);
                        }
                        $items:postbody_out
                        return err;
                    }|]

      (Definition -> CompilerM Multicore ISPCState ())
-> [Definition] -> CompilerM Multicore ISPCState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Definition -> CompilerM Multicore ISPCState ()
ispcEarlyDecl [Definition
ispc_varying, Definition
ispc_uniform, Definition
ispc_extern]
  | Bool
otherwise = () -> CompilerM Multicore ISPCState ()
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    compileInputsExtern :: [TypeQual] -> Param -> CompilerM op s (Param, Exp)
compileInputsExtern [TypeQual]
vari (ScalarParam VName
name PrimType
bt) = do
      let ctp :: Type
ctp = PrimType -> Type
GC.primTypeToCType PrimType
bt
      (Param, Exp) -> CompilerM op s (Param, Exp)
forall a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([C.cparam|$tyquals:vari $ty:ctp $id:name|], [C.cexp|$id:name|])
    compileInputsExtern [TypeQual]
vari (MemParam VName
name Space
space) = do
      Type
ty <- VName -> Space -> CompilerM op s Type
forall op s. VName -> Space -> CompilerM op s Type
GC.memToCType VName
name Space
space
      (Param, Exp) -> CompilerM op s (Param, Exp)
forall a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([C.cparam|$tyquals:vari $ty:ty * $tyquals:vari $id:name|], [C.cexp|*$id:name|])

    compileOutputsExtern :: [TypeQual] -> Param -> CompilerM op s (Param, Exp)
compileOutputsExtern [TypeQual]
vari (ScalarParam VName
name PrimType
bt) = do
      VName
p_name <- String -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => String -> m VName
newVName (String -> CompilerM op s VName) -> String -> CompilerM op s VName
forall a b. (a -> b) -> a -> b
$ String
"out_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ VName -> String
baseString VName
name
      let ctp :: Type
ctp = PrimType -> Type
GC.primTypeToCType PrimType
bt
      (Param, Exp) -> CompilerM op s (Param, Exp)
forall a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([C.cparam|$tyquals:vari $ty:ctp * $tyquals:vari $id:p_name|], [C.cexp|$id:p_name|])
    compileOutputsExtern [TypeQual]
vari (MemParam VName
name Space
space) = do
      Type
ty <- VName -> Space -> CompilerM op s Type
forall op s. VName -> Space -> CompilerM op s Type
GC.memToCType VName
name Space
space
      VName
p_name <- String -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => String -> m VName
newVName (String -> CompilerM op s VName) -> String -> CompilerM op s VName
forall a b. (a -> b) -> a -> b
$ VName -> String
baseString VName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_p"
      (Param, Exp) -> CompilerM op s (Param, Exp)
forall a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([C.cparam|$tyquals:vari $ty:ty * $tyquals:vari $id:p_name|], [C.cexp|$id:p_name|])

    compileInputsUniform :: Param -> CompilerM op s (Param, Exp)
compileInputsUniform (ScalarParam VName
name PrimType
bt) = do
      let ctp :: Type
ctp = PrimType -> Type
GC.primTypeToCType PrimType
bt
          params :: Param
params = [C.cparam|$tyqual:uniform $ty:ctp $id:name|]
          args :: Exp
args = [C.cexp|$id:name|]
      (Param, Exp) -> CompilerM op s (Param, Exp)
forall a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Param
params, Exp
args)
    compileInputsUniform (MemParam VName
name Space
space) = do
      Type
ty <- VName -> Space -> CompilerM op s Type
forall op s. VName -> Space -> CompilerM op s Type
GC.memToCType VName
name Space
space
      let params :: Param
params = [C.cparam|$tyqual:uniform $ty:ty $id:name|]
          args :: Exp
args = [C.cexp|&$id:name|]
      (Param, Exp) -> CompilerM op s (Param, Exp)
forall a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Param
params, Exp
args)

    compileOutputsUniform :: Param -> CompilerM op s (Param, Exp)
compileOutputsUniform (ScalarParam VName
name PrimType
bt) = do
      VName
p_name <- String -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => String -> m VName
newVName (String -> CompilerM op s VName) -> String -> CompilerM op s VName
forall a b. (a -> b) -> a -> b
$ String
"out_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ VName -> String
baseString VName
name
      let ctp :: Type
ctp = PrimType -> Type
GC.primTypeToCType PrimType
bt
          params :: Param
params = [C.cparam|$tyqual:uniform $ty:ctp *$tyqual:uniform $id:p_name|]
          args :: Exp
args = [C.cexp|$id:p_name|]
      (Param, Exp) -> CompilerM op s (Param, Exp)
forall a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Param
params, Exp
args)
    compileOutputsUniform (MemParam VName
name Space
space) = do
      Type
ty <- VName -> Space -> CompilerM op s Type
forall op s. VName -> Space -> CompilerM op s Type
GC.memToCType VName
name Space
space
      VName
p_name <- String -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => String -> m VName
newVName (String -> CompilerM op s VName) -> String -> CompilerM op s VName
forall a b. (a -> b) -> a -> b
$ VName -> String
baseString VName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_p"
      let params :: Param
params = [C.cparam|$tyqual:uniform $ty:ty $id:p_name|]
          args :: Exp
args = [C.cexp|&$id:p_name|]
      (Param, Exp) -> CompilerM op s (Param, Exp)
forall a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Param
params, Exp
args)

    compileInputsVarying :: Param -> CompilerM op s (Param, Exp, [BlockItem])
compileInputsVarying (ScalarParam VName
name PrimType
bt) = do
      let ctp :: Type
ctp = PrimType -> Type
GC.primTypeToCType PrimType
bt
          params :: Param
params = [C.cparam|$ty:ctp $id:name|]
          args :: Exp
args = [C.cexp|extract($id:name,i)|]
          pre_body :: [a]
pre_body = []
      (Param, Exp, [BlockItem])
-> CompilerM op s (Param, Exp, [BlockItem])
forall a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Param
params, Exp
args, [BlockItem]
forall a. [a]
pre_body)
    compileInputsVarying (MemParam VName
name Space
space) = do
      Type
typ <- VName -> Space -> CompilerM op s Type
forall op s. VName -> Space -> CompilerM op s Type
GC.memToCType VName
name Space
space
      VName
newvn <- String -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => String -> m VName
newVName (String -> CompilerM op s VName) -> String -> CompilerM op s VName
forall a b. (a -> b) -> a -> b
$ String
"aos_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> VName -> String
baseString VName
name
      let params :: Param
params = [C.cparam|$ty:typ $id:name|]
          args :: Exp
args = [C.cexp|&$id:(newvn)[i]|]
          pre_body :: [BlockItem]
pre_body =
            [C.citems|$tyqual:uniform $ty:typ $id:(newvn)[programCount];
                               $id:(newvn)[programIndex] = $id:name;|]
      (Param, Exp, [BlockItem])
-> CompilerM op s (Param, Exp, [BlockItem])
forall a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Param
params, Exp
args, [BlockItem]
pre_body)

    compileOutputsVarying :: Param -> CompilerM op s (Param, Exp, [BlockItem], [BlockItem])
compileOutputsVarying (ScalarParam VName
name PrimType
bt) = do
      VName
p_name <- String -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => String -> m VName
newVName (String -> CompilerM op s VName) -> String -> CompilerM op s VName
forall a b. (a -> b) -> a -> b
$ String
"out_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ VName -> String
baseString VName
name
      VName
deref_name <- String -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => String -> m VName
newVName (String -> CompilerM op s VName) -> String -> CompilerM op s VName
forall a b. (a -> b) -> a -> b
$ String
"aos_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ VName -> String
baseString VName
name
      VName
vari_p_name <- String -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => String -> m VName
newVName (String -> CompilerM op s VName) -> String -> CompilerM op s VName
forall a b. (a -> b) -> a -> b
$ String
"convert_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ VName -> String
baseString VName
name
      let ctp :: Type
ctp = PrimType -> Type
GC.primTypeToCType PrimType
bt
          pre_body :: [BlockItem]
pre_body =
            [C.citems|$tyqual:varying $ty:ctp $id:vari_p_name = *$id:p_name;
                                $tyqual:uniform $ty:ctp $id:deref_name[programCount];
                                $id:deref_name[programIndex] = $id:vari_p_name;|]
          post_body :: [BlockItem]
post_body = [C.citems|*$id:p_name = $id:(deref_name)[programIndex];|]
          params :: Param
params = [C.cparam|$tyqual:varying $ty:ctp * $tyqual:uniform $id:p_name|]
          args :: Exp
args = [C.cexp|&$id:(deref_name)[i]|]
      (Param, Exp, [BlockItem], [BlockItem])
-> CompilerM op s (Param, Exp, [BlockItem], [BlockItem])
forall a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Param
params, Exp
args, [BlockItem]
pre_body, [BlockItem]
post_body)
    compileOutputsVarying (MemParam VName
name Space
space) = do
      Type
typ <- VName -> Space -> CompilerM op s Type
forall op s. VName -> Space -> CompilerM op s Type
GC.memToCType VName
name Space
space
      VName
newvn <- String -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => String -> m VName
newVName (String -> CompilerM op s VName) -> String -> CompilerM op s VName
forall a b. (a -> b) -> a -> b
$ String
"aos_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> VName -> String
baseString VName
name
      let params :: Param
params = [C.cparam|$ty:typ $id:name|]
          args :: Exp
args = [C.cexp|&$id:(newvn)[i]|]
          pre_body :: [BlockItem]
pre_body =
            [C.citems|$tyqual:uniform $ty:typ $id:(newvn)[programCount];
                       $id:(newvn)[programIndex] = $id:name;|]
      (Param, Exp, [BlockItem], [BlockItem])
-> CompilerM op s (Param, Exp, [BlockItem], [BlockItem])
forall a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Param
params, Exp
args, [BlockItem]
pre_body, [])

-- | Handle logging an error message in ISPC.
handleError :: ErrorMsg Exp -> String -> ISPCCompilerM ()
handleError :: ErrorMsg Exp -> String -> CompilerM Multicore ISPCState ()
handleError ErrorMsg Exp
msg String
stacktrace = do
  -- Get format sting
  (String
formatstr, [Exp]
formatargs) <- ErrorMsg Exp -> CompilerM Multicore ISPCState (String, [Exp])
forall op s. ErrorMsg Exp -> CompilerM op s (String, [Exp])
GC.errorMsgString ErrorMsg Exp
msg
  let formatstr' :: String
formatstr' = String
"Error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
formatstr String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n\nBacktrace:\n%s"
  -- Get args types and names for shim
  let arg_types :: [PrimType]
arg_types = ErrorMsg Exp -> [PrimType]
forall a. ErrorMsg a -> [PrimType]
errorMsgArgTypes ErrorMsg Exp
msg
  [VName]
arg_names <- (PrimType -> CompilerM Multicore ISPCState VName)
-> [PrimType] -> CompilerM Multicore ISPCState [VName]
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 (String -> CompilerM Multicore ISPCState VName
forall (m :: * -> *). MonadFreshNames m => String -> m VName
newVName (String -> CompilerM Multicore ISPCState VName)
-> (PrimType -> String)
-> PrimType
-> CompilerM Multicore ISPCState VName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PrimType -> String
forall a b. a -> b -> a
const String
"arg") [PrimType]
arg_types
  let params :: [Param]
params = (PrimType -> VName -> Param) -> [PrimType] -> [VName] -> [Param]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\PrimType
ty VName
name -> [C.cparam|$ty:(GC.primTypeToCType ty) $id:name|]) [PrimType]
arg_types [VName]
arg_names
  let params_uni :: [Param]
params_uni = (PrimType -> VName -> Param) -> [PrimType] -> [VName] -> [Param]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\PrimType
ty VName
name -> [C.cparam|$tyqual:uniform $ty:(GC.primTypeToCType ty) $id:name|]) [PrimType]
arg_types [VName]
arg_names
  -- Make shim
  let formatargs' :: [Exp]
formatargs' = ErrorMsg Exp -> [Exp] -> [VName] -> [Exp]
forall {a} {a}. ToIdent a => ErrorMsg a -> [Exp] -> [a] -> [Exp]
mapArgNames ErrorMsg Exp
msg [Exp]
formatargs [VName]
arg_names
  Name
shim <- DefSpecifier ISPCState
forall s. DefSpecifier s
MC.multicoreDef String
"assert_shim" ((Name -> CompilerM Multicore ISPCState Definition)
 -> CompilerM Multicore ISPCState Name)
-> (Name -> CompilerM Multicore ISPCState Definition)
-> CompilerM Multicore ISPCState Name
forall a b. (a -> b) -> a -> b
$ \Name
s -> do
    Definition -> CompilerM Multicore ISPCState Definition
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      [C.cedecl|void $id:s(struct futhark_context* ctx, $params:params) {
          set_error(ctx, msgprintf($string:formatstr', $args:formatargs', $string:stacktrace));
      }|]
  Definition -> CompilerM Multicore ISPCState ()
ispcDecl
    [C.cedecl|extern "C" $tyqual:unmasked void $id:shim($tyqual:uniform struct futhark_context* $tyqual:uniform, $params:params_uni);|]
  -- Call the shim
  [Exp]
args <- ErrorMsg Exp -> CompilerM Multicore ISPCState [Exp]
getErrorValExps ErrorMsg Exp
msg
  VName
uni <- String -> CompilerM Multicore ISPCState VName
forall (m :: * -> *). MonadFreshNames m => String -> m VName
newVName String
"uni"
  let args' :: [Exp]
args' = (Exp -> Exp) -> [Exp] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\Exp
x -> [C.cexp|extract($exp:x, $id:uni)|]) [Exp]
args
  [BlockItem] -> CompilerM Multicore ISPCState ()
forall op s. [BlockItem] -> CompilerM op s ()
GC.items
    [C.citems|
      $escstm:("foreach_active(" <> prettyString uni <> ")")
      {
        $id:shim(ctx, $args:args');
        err = FUTHARK_PROGRAM_ERROR;
      }
      $escstm:("unmasked { return err; }")|]
  where
    getErrorVal :: ErrorMsgPart a -> Maybe a
getErrorVal (ErrorString Text
_) = Maybe a
forall a. Maybe a
Nothing
    getErrorVal (ErrorVal PrimType
_ a
v) = a -> Maybe a
forall a. a -> Maybe a
Just a
v

    getErrorValExps :: ErrorMsg Exp -> CompilerM Multicore ISPCState [Exp]
getErrorValExps (ErrorMsg [ErrorMsgPart Exp]
m) = (Exp -> CompilerM Multicore ISPCState Exp)
-> [Exp] -> CompilerM Multicore ISPCState [Exp]
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 Exp -> CompilerM Multicore ISPCState Exp
compileExp ([Exp] -> CompilerM Multicore ISPCState [Exp])
-> [Exp] -> CompilerM Multicore ISPCState [Exp]
forall a b. (a -> b) -> a -> b
$ (ErrorMsgPart Exp -> Maybe Exp) -> [ErrorMsgPart Exp] -> [Exp]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ErrorMsgPart Exp -> Maybe Exp
forall {a}. ErrorMsgPart a -> Maybe a
getErrorVal [ErrorMsgPart Exp]
m

    mapArgNames' :: [ErrorMsgPart a] -> [Exp] -> [a] -> [Exp]
mapArgNames' (ErrorMsgPart a
x : [ErrorMsgPart a]
xs) (Exp
y : [Exp]
ys) (a
t : [a]
ts)
      | Maybe a -> Bool
forall a. Maybe a -> Bool
isJust (Maybe a -> Bool) -> Maybe a -> Bool
forall a b. (a -> b) -> a -> b
$ ErrorMsgPart a -> Maybe a
forall {a}. ErrorMsgPart a -> Maybe a
getErrorVal ErrorMsgPart a
x = [C.cexp|$id:t|] Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: [ErrorMsgPart a] -> [Exp] -> [a] -> [Exp]
mapArgNames' [ErrorMsgPart a]
xs [Exp]
ys [a]
ts
      | Bool
otherwise = Exp
y Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: [ErrorMsgPart a] -> [Exp] -> [a] -> [Exp]
mapArgNames' [ErrorMsgPart a]
xs [Exp]
ys (a
t a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ts)
    mapArgNames' [ErrorMsgPart a]
_ [Exp]
ys [] = [Exp]
ys
    mapArgNames' [ErrorMsgPart a]
_ [Exp]
_ [a]
_ = []

    mapArgNames :: ErrorMsg a -> [Exp] -> [a] -> [Exp]
mapArgNames (ErrorMsg [ErrorMsgPart a]
parts) = [ErrorMsgPart a] -> [Exp] -> [a] -> [Exp]
forall {a} {a}.
ToIdent a =>
[ErrorMsgPart a] -> [Exp] -> [a] -> [Exp]
mapArgNames' [ErrorMsgPart a]
parts

-- | Given the name and type of a parameter, return the C type used to
-- represent it. We use uniform pointers to varying values for lexical
-- memory blocks, as this generally results in less gathers/scatters.
getMemType :: VName -> PrimType -> ISPCCompilerM C.Type
getMemType :: VName -> PrimType -> ISPCCompilerM Type
getMemType VName
dest PrimType
elemtype = do
  Bool
cached <- Maybe VName -> Bool
forall a. Maybe a -> Bool
isJust (Maybe VName -> Bool)
-> CompilerM Multicore ISPCState (Maybe VName)
-> CompilerM Multicore ISPCState Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> CompilerM Multicore ISPCState (Maybe VName)
forall a op s. ToExp a => a -> CompilerM op s (Maybe VName)
GC.cacheMem VName
dest
  if Bool
cached
    then Type -> ISPCCompilerM Type
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cty|$tyqual:varying $ty:(primStorageType elemtype)* uniform|]
    else Type -> ISPCCompilerM Type
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cty|$ty:(primStorageType elemtype)*|]

compileExp :: Exp -> ISPCCompilerM C.Exp
compileExp :: Exp -> CompilerM Multicore ISPCState Exp
compileExp e :: Exp
e@(ValueExp (FloatValue (Float64Value Double
v))) =
  if Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
v Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
v
    then Exp -> CompilerM Multicore ISPCState Exp
forall op s. Exp -> CompilerM op s Exp
GC.compileExp Exp
e
    else Exp -> CompilerM Multicore ISPCState Exp
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|$esc:(prettyString v <> "d")|]
compileExp e :: Exp
e@(ValueExp (FloatValue (Float16Value Half
v))) =
  if Half -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Half
v Bool -> Bool -> Bool
|| Half -> Bool
forall a. RealFloat a => a -> Bool
isNaN Half
v
    then Exp -> CompilerM Multicore ISPCState Exp
forall op s. Exp -> CompilerM op s Exp
GC.compileExp Exp
e
    else Exp -> CompilerM Multicore ISPCState Exp
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|$esc:(prettyString v <> "f16")|]
compileExp (ValueExp PrimValue
val) =
  Exp -> CompilerM Multicore ISPCState Exp
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> CompilerM Multicore ISPCState Exp)
-> Exp -> CompilerM Multicore ISPCState Exp
forall a b. (a -> b) -> a -> b
$ PrimValue -> SrcLoc -> Exp
forall a. ToExp a => a -> SrcLoc -> Exp
C.toExp PrimValue
val SrcLoc
forall a. Monoid a => a
mempty
compileExp (LeafExp VName
v PrimType
_) =
  Exp -> CompilerM Multicore ISPCState Exp
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|$id:v|]
compileExp (UnOpExp Complement {} Exp
x) = do
  Exp
x' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
x
  Exp -> CompilerM Multicore ISPCState Exp
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|~$exp:x'|]
compileExp (UnOpExp (Neg PrimType
Bool) Exp
x) = do
  Exp
x' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
x
  Exp -> CompilerM Multicore ISPCState Exp
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|!$exp:x'|]
compileExp (UnOpExp Neg {} Exp
x) = do
  Exp
x' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
x
  Exp -> CompilerM Multicore ISPCState Exp
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|-$exp:x'|]
compileExp (UnOpExp (FAbs FloatType
Float32) Exp
x) = do
  Exp
x' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
x
  Exp -> CompilerM Multicore ISPCState Exp
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|(float)fabs($exp:x')|]
compileExp (UnOpExp (FAbs FloatType
Float64) Exp
x) = do
  Exp
x' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
x
  Exp -> CompilerM Multicore ISPCState Exp
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|fabs($exp:x')|]
compileExp (UnOpExp SSignum {} Exp
x) = do
  Exp
x' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
x
  Exp -> CompilerM Multicore ISPCState Exp
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|($exp:x' > 0 ? 1 : 0) - ($exp:x' < 0 ? 1 : 0)|]
compileExp (UnOpExp USignum {} Exp
x) = do
  Exp
x' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
x
  Exp -> CompilerM Multicore ISPCState Exp
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|($exp:x' > 0 ? 1 : 0) - ($exp:x' < 0 ? 1 : 0) != 0|]
compileExp (UnOpExp UnOp
op Exp
x) = do
  Exp
x' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
x
  Exp -> CompilerM Multicore ISPCState Exp
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|$id:(prettyString op)($exp:x')|]
compileExp (CmpOpExp CmpOp
cmp Exp
x Exp
y) = do
  Exp
x' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
x
  Exp
y' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
y
  Exp -> CompilerM Multicore ISPCState Exp
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> CompilerM Multicore ISPCState Exp)
-> Exp -> CompilerM Multicore ISPCState Exp
forall a b. (a -> b) -> a -> b
$ case CmpOp
cmp of
    CmpEq {} -> [C.cexp|$exp:x' == $exp:y'|]
    FCmpLt {} -> [C.cexp|$exp:x' < $exp:y'|]
    FCmpLe {} -> [C.cexp|$exp:x' <= $exp:y'|]
    CmpLlt {} -> [C.cexp|$exp:x' < $exp:y'|]
    CmpLle {} -> [C.cexp|$exp:x' <= $exp:y'|]
    CmpOp
_ -> [C.cexp|$id:(prettyString cmp)($exp:x', $exp:y')|]
compileExp (ConvOpExp ConvOp
conv Exp
x) = do
  Exp
x' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
x
  Exp -> CompilerM Multicore ISPCState Exp
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|$id:(prettyString conv)($exp:x')|]
compileExp (BinOpExp BinOp
bop Exp
x Exp
y) = do
  Exp
x' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
x
  Exp
y' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
y
  Exp -> CompilerM Multicore ISPCState Exp
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> CompilerM Multicore ISPCState Exp)
-> Exp -> CompilerM Multicore ISPCState Exp
forall a b. (a -> b) -> a -> b
$ case BinOp
bop of
    Add IntType
_ Overflow
OverflowUndef -> [C.cexp|$exp:x' + $exp:y'|]
    Sub IntType
_ Overflow
OverflowUndef -> [C.cexp|$exp:x' - $exp:y'|]
    Mul IntType
_ Overflow
OverflowUndef -> [C.cexp|$exp:x' * $exp:y'|]
    FAdd {} -> [C.cexp|$exp:x' + $exp:y'|]
    FSub {} -> [C.cexp|$exp:x' - $exp:y'|]
    FMul {} -> [C.cexp|$exp:x' * $exp:y'|]
    FDiv {} -> [C.cexp|$exp:x' / $exp:y'|]
    Xor {} -> [C.cexp|$exp:x' ^ $exp:y'|]
    And {} -> [C.cexp|$exp:x' & $exp:y'|]
    Or {} -> [C.cexp|$exp:x' | $exp:y'|]
    LogAnd {} -> [C.cexp|$exp:x' && $exp:y'|]
    LogOr {} -> [C.cexp|$exp:x' || $exp:y'|]
    BinOp
_ -> [C.cexp|$id:(prettyString bop)($exp:x', $exp:y')|]
compileExp (FunExp Text
h [Exp]
args PrimType
_) = do
  [Exp]
args' <- (Exp -> CompilerM Multicore ISPCState Exp)
-> [Exp] -> CompilerM Multicore ISPCState [Exp]
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 Exp -> CompilerM Multicore ISPCState Exp
compileExp [Exp]
args
  Exp -> CompilerM Multicore ISPCState Exp
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|$id:(funName (nameFromText h))($args:args')|]

-- | Compile a block of code with ISPC specific semantics, falling back
-- to generic C when this semantics is not needed.
-- All recursive constructors are duplicated here, since not doing so
-- would cause use to enter regular generic C codegen with no escape.
compileCode :: MCCode -> ISPCCompilerM ()
compileCode :: MCCode -> CompilerM Multicore ISPCState ()
compileCode (Comment Text
s MCCode
code) = do
  [BlockItem]
xs <- CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
GC.collect (CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem])
-> CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall a b. (a -> b) -> a -> b
$ MCCode -> CompilerM Multicore ISPCState ()
compileCode MCCode
code
  let comment :: String
comment = String
"// " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
s
  Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm
    [C.cstm|$comment:comment
              { $items:xs }
             |]
compileCode (DeclareScalar VName
name Volatility
_ PrimType
t) = do
  let ct :: Type
ct = PrimType -> Type
GC.primTypeToCType PrimType
t
  [TypeQual]
quals <- VName -> ISPCCompilerM [TypeQual]
getVariabilityQuals VName
name
  InitGroup -> CompilerM Multicore ISPCState ()
forall op s. InitGroup -> CompilerM op s ()
GC.decl [C.cdecl|$tyquals:quals $ty:ct $id:name;|]
compileCode (DeclareArray VName
name PrimType
t ArrayContents
vs) = do
  VName
name_realtype <- String -> CompilerM Multicore ISPCState VName
forall (m :: * -> *). MonadFreshNames m => String -> m VName
newVName (String -> CompilerM Multicore ISPCState VName)
-> String -> CompilerM Multicore ISPCState VName
forall a b. (a -> b) -> a -> b
$ VName -> String
baseString VName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_realtype"
  let ct :: Type
ct = PrimType -> Type
GC.primTypeToCType PrimType
t
  case ArrayContents
vs of
    ArrayValues [PrimValue]
vs' -> do
      let vs'' :: [Initializer]
vs'' = [[C.cinit|$exp:v|] | PrimValue
v <- [PrimValue]
vs']
      Definition -> CompilerM Multicore ISPCState ()
forall op s. Definition -> CompilerM op s ()
GC.earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:(length vs')] = {$inits:vs''};|]
    ArrayZeros Int
n ->
      Definition -> CompilerM Multicore ISPCState ()
forall op s. Definition -> CompilerM op s ()
GC.earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:n];|]
  -- Make an exported C shim to access a faked memory block.
  Name
shim <- DefSpecifier ISPCState
forall s. DefSpecifier s
MC.multicoreDef String
"get_static_array_shim" ((Name -> CompilerM Multicore ISPCState Definition)
 -> CompilerM Multicore ISPCState Name)
-> (Name -> CompilerM Multicore ISPCState Definition)
-> CompilerM Multicore ISPCState Name
forall a b. (a -> b) -> a -> b
$ \Name
f ->
    Definition -> CompilerM Multicore ISPCState Definition
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      [C.cedecl|struct memblock $id:f(struct futhark_context* ctx) {
                  return (struct memblock){NULL,(unsigned char*)$id:name_realtype,0};
                }|]
  Definition -> CompilerM Multicore ISPCState ()
ispcDecl
    [C.cedecl|extern "C" $tyqual:unmasked $tyqual:uniform struct memblock $tyqual:uniform
                        $id:shim($tyqual:uniform struct futhark_context* $tyqual:uniform ctx);|]
  -- Call it
  BlockItem -> CompilerM Multicore ISPCState ()
forall op s. BlockItem -> CompilerM op s ()
GC.item [C.citem|$tyqual:uniform struct memblock $id:name = $id:shim(ctx);|]
compileCode (MCCode
c1 :>>: MCCode
c2) = [MCCode] -> CompilerM Multicore ISPCState ()
go (MCCode -> [MCCode]
forall op. Code op -> [Code op]
GC.linearCode (MCCode
c1 MCCode -> MCCode -> MCCode
forall a. Code a -> Code a -> Code a
:>>: MCCode
c2))
  where
    go :: [MCCode] -> CompilerM Multicore ISPCState ()
go (DeclareScalar VName
name Volatility
_ PrimType
t : SetScalar VName
dest Exp
e : [MCCode]
code)
      | VName
name VName -> VName -> Bool
forall a. Eq a => a -> a -> Bool
== VName
dest = do
          let ct :: Type
ct = PrimType -> Type
GC.primTypeToCType PrimType
t
          Exp
e' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
e
          [TypeQual]
quals <- VName -> ISPCCompilerM [TypeQual]
getVariabilityQuals VName
name
          BlockItem -> CompilerM Multicore ISPCState ()
forall op s. BlockItem -> CompilerM op s ()
GC.item [C.citem|$tyquals:quals $ty:ct $id:name = $exp:e';|]
          [MCCode] -> CompilerM Multicore ISPCState ()
go [MCCode]
code
    go (MCCode
x : [MCCode]
xs) = MCCode -> CompilerM Multicore ISPCState ()
compileCode MCCode
x CompilerM Multicore ISPCState ()
-> CompilerM Multicore ISPCState ()
-> CompilerM Multicore ISPCState ()
forall a b.
CompilerM Multicore ISPCState a
-> CompilerM Multicore ISPCState b
-> CompilerM Multicore ISPCState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [MCCode] -> CompilerM Multicore ISPCState ()
go [MCCode]
xs
    go [] = () -> CompilerM Multicore ISPCState ()
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
compileCode (Allocate VName
name (Count (TPrimExp Exp
e)) Space
space) = do
  Exp
size <- Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
e
  Maybe VName
cached <- VName -> CompilerM Multicore ISPCState (Maybe VName)
forall a op s. ToExp a => a -> CompilerM op s (Maybe VName)
GC.cacheMem VName
name
  case Maybe VName
cached of
    Just VName
cur_size ->
      Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm
        [C.cstm|if ($exp:cur_size < $exp:size) {
                  err = lexical_realloc(ctx, &$exp:name, &$exp:cur_size, $exp:size);
                  if (err != FUTHARK_SUCCESS) {
                    $escstm:("unmasked { return err; }")
                  }
                }|]
    Maybe VName
_ ->
      VName -> Exp -> Space -> Stm -> CompilerM Multicore ISPCState ()
forall a b.
(ToExp a, ToExp b) =>
a -> b -> Space -> Stm -> CompilerM Multicore ISPCState ()
allocMem VName
name Exp
size Space
space [C.cstm|$escstm:("unmasked { return 1; }")|]
compileCode (SetMem VName
dest VName
src Space
space) =
  VName -> VName -> Space -> CompilerM Multicore ISPCState ()
forall a b.
(ToExp a, ToExp b) =>
a -> b -> Space -> CompilerM Multicore ISPCState ()
setMem VName
dest VName
src Space
space
compileCode (Write VName
dest (Count TExp Int64
idx) PrimType
elemtype Space
DefaultSpace Volatility
_ Exp
elemexp)
  | Exp -> Bool
forall {v}. PrimExp v -> Bool
isConstExp (TExp Int64 -> Exp
forall {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped TExp Int64
idx) = do
      Exp
dest' <- VName -> CompilerM Multicore ISPCState Exp
forall op s. VName -> CompilerM op s Exp
GC.rawMem VName
dest
      Exp
idxexp <- Exp -> CompilerM Multicore ISPCState Exp
compileExp (Exp -> CompilerM Multicore ISPCState Exp)
-> Exp -> CompilerM Multicore ISPCState Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp
forall v. PrimExp v -> PrimExp v
constFoldPrimExp (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ TExp Int64 -> Exp
forall {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped TExp Int64
idx
      Exp
deref <-
        Exp -> Exp -> Type -> Exp
GC.derefPointer
          Exp
dest'
          [C.cexp|($tyquals:([varying]) typename int64_t)$exp:idxexp|]
          (Type -> Exp)
-> ISPCCompilerM Type -> CompilerM Multicore ISPCState Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> PrimType -> ISPCCompilerM Type
getMemType VName
dest PrimType
elemtype
      Exp
elemexp' <- PrimType -> Exp -> Exp
toStorage PrimType
elemtype (Exp -> Exp)
-> CompilerM Multicore ISPCState Exp
-> CompilerM Multicore ISPCState Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
elemexp
      Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$exp:deref = $exp:elemexp';|]
  | Bool
otherwise = do
      Exp
dest' <- VName -> CompilerM Multicore ISPCState Exp
forall op s. VName -> CompilerM op s Exp
GC.rawMem VName
dest
      Exp
idxexp <- Exp -> CompilerM Multicore ISPCState Exp
compileExp (Exp -> CompilerM Multicore ISPCState Exp)
-> Exp -> CompilerM Multicore ISPCState Exp
forall a b. (a -> b) -> a -> b
$ TExp Int64 -> Exp
forall {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped TExp Int64
idx
      Exp
deref <-
        Exp -> Exp -> Type -> Exp
GC.derefPointer
          Exp
dest'
          [C.cexp|($tyquals:([varying]) typename int64_t)$exp:idxexp|]
          (Type -> Exp)
-> ISPCCompilerM Type -> CompilerM Multicore ISPCState Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> PrimType -> ISPCCompilerM Type
getMemType VName
dest PrimType
elemtype
      Exp
elemexp' <- PrimType -> Exp -> Exp
toStorage PrimType
elemtype (Exp -> Exp)
-> CompilerM Multicore ISPCState Exp
-> CompilerM Multicore ISPCState Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
elemexp
      Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$exp:deref = $exp:elemexp';|]
  where
    isConstExp :: PrimExp v -> Bool
isConstExp = PrimExp v -> Bool
forall {v}. PrimExp v -> Bool
isSimple (PrimExp v -> Bool)
-> (PrimExp v -> PrimExp v) -> PrimExp v -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimExp v -> PrimExp v
forall v. PrimExp v -> PrimExp v
constFoldPrimExp
    isSimple :: PrimExp v -> Bool
isSimple (ValueExp PrimValue
_) = Bool
True
    isSimple PrimExp v
_ = Bool
False
compileCode (Read VName
x VName
src (Count TExp Int64
iexp) PrimType
restype Space
DefaultSpace Volatility
_) = do
  Exp
src' <- VName -> CompilerM Multicore ISPCState Exp
forall op s. VName -> CompilerM op s Exp
GC.rawMem VName
src
  Exp
e <-
    (Exp -> Exp)
-> CompilerM Multicore ISPCState Exp
-> CompilerM Multicore ISPCState Exp
forall a b.
(a -> b)
-> CompilerM Multicore ISPCState a
-> CompilerM Multicore ISPCState b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PrimType -> Exp -> Exp
fromStorage PrimType
restype) (CompilerM Multicore ISPCState Exp
 -> CompilerM Multicore ISPCState Exp)
-> CompilerM Multicore ISPCState Exp
-> CompilerM Multicore ISPCState Exp
forall a b. (a -> b) -> a -> b
$
      Exp -> Exp -> Type -> Exp
GC.derefPointer Exp
src'
        (Exp -> Type -> Exp)
-> CompilerM Multicore ISPCState Exp
-> CompilerM Multicore ISPCState (Type -> Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> CompilerM Multicore ISPCState Exp
compileExp (TExp Int64 -> Exp
forall {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped TExp Int64
iexp)
        CompilerM Multicore ISPCState (Type -> Exp)
-> ISPCCompilerM Type -> CompilerM Multicore ISPCState Exp
forall a b.
CompilerM Multicore ISPCState (a -> b)
-> CompilerM Multicore ISPCState a
-> CompilerM Multicore ISPCState b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VName -> PrimType -> ISPCCompilerM Type
getMemType VName
src PrimType
restype
  Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:x = $exp:e;|]
compileCode (Copy PrimType
t [Count Elements (TExp Int64)]
shape (VName
dst, Space
DefaultSpace) (Count Elements (TExp Int64), [Count Elements (TExp Int64)])
dst_lmad (VName
src, Space
DefaultSpace) (Count Elements (TExp Int64), [Count Elements (TExp Int64)])
src_lmad) = do
  Exp
dst' <- VName -> CompilerM Multicore ISPCState Exp
forall op s. VName -> CompilerM op s Exp
GC.rawMem VName
dst
  Exp
src' <- VName -> CompilerM Multicore ISPCState Exp
forall op s. VName -> CompilerM op s Exp
GC.rawMem VName
src
  let doWrite :: a -> Exp -> CompilerM Multicore ISPCState ()
doWrite a
dst_i Exp
ve = do
        Exp
deref <-
          Exp -> Exp -> Type -> Exp
GC.derefPointer
            Exp
dst'
            [C.cexp|($tyquals:([varying]) typename int64_t)$exp:dst_i|]
            (Type -> Exp)
-> ISPCCompilerM Type -> CompilerM Multicore ISPCState Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> PrimType -> ISPCCompilerM Type
getMemType VName
dst PrimType
t
        Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$exp:deref = $exp:(toStorage t ve);|]
      doRead :: Exp -> CompilerM Multicore ISPCState Exp
doRead Exp
src_i =
        PrimType -> Exp -> Exp
fromStorage PrimType
t (Exp -> Exp) -> (Type -> Exp) -> Type -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Type -> Exp
GC.derefPointer Exp
src' Exp
src_i (Type -> Exp)
-> ISPCCompilerM Type -> CompilerM Multicore ISPCState Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> PrimType -> ISPCCompilerM Type
getMemType VName
src PrimType
t
  [Count Elements (TExp Int64)]
-> (Exp -> Exp -> CompilerM Multicore ISPCState ())
-> (Count Elements (TExp Int64), [Count Elements (TExp Int64)])
-> (Exp -> CompilerM Multicore ISPCState Exp)
-> (Count Elements (TExp Int64), [Count Elements (TExp Int64)])
-> CompilerM Multicore ISPCState ()
forall op s.
[Count Elements (TExp Int64)]
-> (Exp -> Exp -> CompilerM op s ())
-> (Count Elements (TExp Int64), [Count Elements (TExp Int64)])
-> (Exp -> CompilerM op s Exp)
-> (Count Elements (TExp Int64), [Count Elements (TExp Int64)])
-> CompilerM op s ()
GC.compileCopyWith [Count Elements (TExp Int64)]
shape Exp -> Exp -> CompilerM Multicore ISPCState ()
forall {a}. ToExp a => a -> Exp -> CompilerM Multicore ISPCState ()
doWrite (Count Elements (TExp Int64), [Count Elements (TExp Int64)])
dst_lmad Exp -> CompilerM Multicore ISPCState Exp
doRead (Count Elements (TExp Int64), [Count Elements (TExp Int64)])
src_lmad
compileCode (Free VName
name Space
space) = do
  Bool
cached <- Maybe VName -> Bool
forall a. Maybe a -> Bool
isJust (Maybe VName -> Bool)
-> CompilerM Multicore ISPCState (Maybe VName)
-> CompilerM Multicore ISPCState Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> CompilerM Multicore ISPCState (Maybe VName)
forall a op s. ToExp a => a -> CompilerM op s (Maybe VName)
GC.cacheMem VName
name
  Bool
-> CompilerM Multicore ISPCState ()
-> CompilerM Multicore ISPCState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
cached (CompilerM Multicore ISPCState ()
 -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState ()
-> CompilerM Multicore ISPCState ()
forall a b. (a -> b) -> a -> b
$ VName -> Space -> CompilerM Multicore ISPCState ()
forall a. ToExp a => a -> Space -> CompilerM Multicore ISPCState ()
unRefMem VName
name Space
space
compileCode (For VName
i Exp
bound MCCode
body)
  -- The special-case here is to avoid certain pathological/contrived
  -- programs that construct statically known zero-element arrays.
  -- Due to the way we do constant-fold index functions, this produces
  -- code that looks like it has uniform/varying mismatches (i.e. race
  -- conditions) to ISPC, even though that code is never actually run.
  | Exp -> Bool
forall {v}. PrimExp v -> Bool
isZero Exp
bound = () -> CompilerM Multicore ISPCState ()
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise = 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
GC.primTypeToCType (PrimType -> Type) -> PrimType -> Type
forall a b. (a -> b) -> a -> b
$ Exp -> PrimType
forall v. PrimExp v -> PrimType
primExpType Exp
bound
      Exp
bound' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
bound
      [BlockItem]
body' <- CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
GC.collect (CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem])
-> CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall a b. (a -> b) -> a -> b
$ MCCode -> CompilerM Multicore ISPCState ()
compileCode MCCode
body
      [TypeQual]
quals <- VName -> ISPCCompilerM [TypeQual]
getVariabilityQuals VName
i
      Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm
        [C.cstm|for ($tyquals:quals $ty:t $id:i' = 0; $id:i' < $exp:bound'; $id:i'++) {
            $items:body'
          }|]
  where
    isZero :: PrimExp v -> Bool
isZero (ValueExp PrimValue
v) = PrimValue -> Bool
zeroIsh PrimValue
v
    isZero PrimExp v
_ = Bool
False
compileCode (While TExp Bool
cond MCCode
body) = do
  Exp
cond' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp (Exp -> CompilerM Multicore ISPCState Exp)
-> Exp -> CompilerM Multicore ISPCState Exp
forall a b. (a -> b) -> a -> b
$ TExp Bool -> Exp
forall {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped TExp Bool
cond
  [BlockItem]
body' <- CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
GC.collect (CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem])
-> CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall a b. (a -> b) -> a -> b
$ MCCode -> CompilerM Multicore ISPCState ()
compileCode MCCode
body
  Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm
    [C.cstm|while ($exp:cond') {
            $items:body'
          }|]
compileCode (If TExp Bool
cond MCCode
tbranch MCCode
fbranch) = do
  Exp
cond' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp (Exp -> CompilerM Multicore ISPCState Exp)
-> Exp -> CompilerM Multicore ISPCState Exp
forall a b. (a -> b) -> a -> b
$ TExp Bool -> Exp
forall {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped TExp Bool
cond
  [BlockItem]
tbranch' <- CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
GC.collect (CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem])
-> CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall a b. (a -> b) -> a -> b
$ MCCode -> CompilerM Multicore ISPCState ()
compileCode MCCode
tbranch
  [BlockItem]
fbranch' <- CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
GC.collect (CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem])
-> CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall a b. (a -> b) -> a -> b
$ MCCode -> CompilerM Multicore ISPCState ()
compileCode MCCode
fbranch
  Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm (Stm -> CompilerM Multicore ISPCState ())
-> Stm -> CompilerM Multicore ISPCState ()
forall a b. (a -> b) -> a -> b
$ case ([BlockItem]
tbranch', [BlockItem]
fbranch') of
    ([BlockItem]
_, []) ->
      [C.cstm|if ($exp:cond') { $items:tbranch' }|]
    ([], [BlockItem]
_) ->
      [C.cstm|if (!($exp:cond')) { $items:fbranch' }|]
    ([BlockItem], [BlockItem])
_ ->
      [C.cstm|if ($exp:cond') { $items:tbranch' } else { $items:fbranch' }|]
compileCode (Call [VName]
dests Name
fname [Arg]
args) = do
  ([VName]
dests', [[Stm]]
unpack_dest) <- (VName -> CompilerM Multicore ISPCState (VName, [Stm]))
-> [VName] -> CompilerM Multicore ISPCState ([VName], [[Stm]])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM VName -> CompilerM Multicore ISPCState (VName, [Stm])
forall op s. VName -> CompilerM op s (VName, [Stm])
GC.compileDest [VName]
dests
  [VName] -> Name -> [Exp] -> CompilerM Multicore ISPCState ()
forall {a} {op} {s}.
ToIdent a =>
[a] -> Name -> [Exp] -> CompilerM op s ()
defCallIspc [VName]
dests' Name
fname ([Exp] -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState [Exp]
-> CompilerM Multicore ISPCState ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Arg -> CompilerM Multicore ISPCState Exp)
-> [Arg] -> CompilerM Multicore ISPCState [Exp]
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 Arg -> CompilerM Multicore ISPCState Exp
forall op s. Arg -> CompilerM op s Exp
GC.compileArg [Arg]
args
  [Stm] -> CompilerM Multicore ISPCState ()
forall op s. [Stm] -> CompilerM op s ()
GC.stms ([Stm] -> CompilerM Multicore ISPCState ())
-> [Stm] -> CompilerM Multicore ISPCState ()
forall a b. (a -> b) -> a -> b
$ [[Stm]] -> [Stm]
forall a. Monoid a => [a] -> a
mconcat [[Stm]]
unpack_dest
  where
    defCallIspc :: [a] -> Name -> [Exp] -> CompilerM op s ()
defCallIspc [a]
dests' Name
fname' [Exp]
args' = do
      let out_args :: [Exp]
out_args = [[C.cexp|&$id:d|] | a
d <- [a]
dests']
          args'' :: [Exp]
args''
            | Name -> Bool
isBuiltInFunction Name
fname' = [Exp]
args'
            | Bool
otherwise = [C.cexp|ctx|] Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: [Exp]
out_args [Exp] -> [Exp] -> [Exp]
forall a. [a] -> [a] -> [a]
++ [Exp]
args'
      case [a]
dests' of
        [a
d]
          | Name -> Bool
isBuiltInFunction Name
fname' ->
              Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:d = $id:(funName fname')($args:args'');|]
        [a]
_ ->
          BlockItem -> CompilerM op s ()
forall op s. BlockItem -> CompilerM op s ()
GC.item
            [C.citem|
            if ($id:(funName fname')($args:args'') != 0) {
              $escstm:("unmasked { return 1; }")
            }|]
compileCode (Assert Exp
e ErrorMsg Exp
msg (SrcLoc
loc, [SrcLoc]
locs)) = do
  Exp
e' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
e
  [BlockItem]
err <- CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
GC.collect (CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem])
-> CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall a b. (a -> b) -> a -> b
$ ErrorMsg Exp -> String -> CompilerM Multicore ISPCState ()
handleError ErrorMsg Exp
msg String
stacktrace
  Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|if (!$exp:e') { $items:err }|]
  where
    stacktrace :: String
stacktrace = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Int -> [Text] -> Text
prettyStacktrace Int
0 ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (SrcLoc -> Text) -> [SrcLoc] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map SrcLoc -> Text
forall a. Located a => a -> Text
locText ([SrcLoc] -> [Text]) -> [SrcLoc] -> [Text]
forall a b. (a -> b) -> a -> b
$ SrcLoc
loc SrcLoc -> [SrcLoc] -> [SrcLoc]
forall a. a -> [a] -> [a]
: [SrcLoc]
locs
compileCode MCCode
code =
  MCCode -> CompilerM Multicore ISPCState ()
forall op s. Code op -> CompilerM op s ()
GC.compileCode MCCode
code

-- | Prepare a struct with memory allocted in the scope and populate
-- its fields with values
prepareMemStruct :: [(VName, VName)] -> [VName] -> ISPCCompilerM Name
prepareMemStruct :: [(VName, VName)] -> [VName] -> CompilerM Multicore ISPCState Name
prepareMemStruct [(VName, VName)]
lexmems [VName]
fatmems = do
  let lex_defs :: [FieldGroup]
lex_defs = ((VName, VName) -> [FieldGroup])
-> [(VName, VName)] -> [FieldGroup]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (VName, VName) -> [FieldGroup]
forall {a} {a}. (ToIdent a, ToIdent a) => (a, a) -> [FieldGroup]
lexMemDef [(VName, VName)]
lexmems
  let fat_defs :: [FieldGroup]
fat_defs = (VName -> FieldGroup) -> [VName] -> [FieldGroup]
forall a b. (a -> b) -> [a] -> [b]
map VName -> FieldGroup
forall {a}. ToIdent a => a -> FieldGroup
fatMemDef [VName]
fatmems
  Name
name <- DefSpecifier ISPCState
ispcDef String
"mem_struct" ((Name -> CompilerM Multicore ISPCState Definition)
 -> CompilerM Multicore ISPCState Name)
-> (Name -> CompilerM Multicore ISPCState Definition)
-> CompilerM Multicore ISPCState Name
forall a b. (a -> b) -> a -> b
$ \Name
s -> do
    Definition -> CompilerM Multicore ISPCState Definition
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      [C.cedecl|struct $id:s {
        $sdecls:lex_defs
        $sdecls:fat_defs
      };|]
  let name' :: Name
name' = Name
name Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_"
  InitGroup -> CompilerM Multicore ISPCState ()
forall op s. InitGroup -> CompilerM op s ()
GC.decl [C.cdecl|$tyqual:uniform struct $id:name $id:name';|]
  [VName]
-> (VName -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (((VName, VName) -> [VName]) -> [(VName, VName)] -> [VName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(VName
a, VName
b) -> [VName
a, VName
b]) [(VName, VName)]
lexmems) ((VName -> CompilerM Multicore ISPCState ())
 -> CompilerM Multicore ISPCState ())
-> (VName -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState ()
forall a b. (a -> b) -> a -> b
$ \VName
m ->
    Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:name'.$id:m = $id:m;|]
  [VName]
-> (VName -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [VName]
fatmems ((VName -> CompilerM Multicore ISPCState ())
 -> CompilerM Multicore ISPCState ())
-> (VName -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState ()
forall a b. (a -> b) -> a -> b
$ \VName
m ->
    Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:name'.$id:m = &$id:m;|]
  Name -> CompilerM Multicore ISPCState Name
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
name
  where
    lexMemDef :: (a, a) -> [FieldGroup]
lexMemDef (a
name, a
size) =
      [ [C.csdecl|$tyqual:varying unsigned char * $tyqual:uniform $id:name;|],
        [C.csdecl|$tyqual:varying size_t $id:size;|]
      ]
    fatMemDef :: a -> FieldGroup
fatMemDef a
name =
      [C.csdecl|$tyqual:varying struct memblock * $tyqual:uniform $id:name;|]

-- | Get memory from the memory struct into local variables
compileGetMemStructVals :: Name -> [(VName, VName)] -> [VName] -> ISPCCompilerM ()
compileGetMemStructVals :: Name
-> [(VName, VName)] -> [VName] -> CompilerM Multicore ISPCState ()
compileGetMemStructVals Name
struct [(VName, VName)]
lexmems [VName]
fatmems = do
  [VName]
-> (VName -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [VName]
fatmems ((VName -> CompilerM Multicore ISPCState ())
 -> CompilerM Multicore ISPCState ())
-> (VName -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState ()
forall a b. (a -> b) -> a -> b
$ \VName
m ->
    InitGroup -> CompilerM Multicore ISPCState ()
forall op s. InitGroup -> CompilerM op s ()
GC.decl [C.cdecl|struct memblock $id:m = *$id:struct->$id:m;|]
  [(VName, VName)]
-> ((VName, VName) -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(VName, VName)]
lexmems (((VName, VName) -> CompilerM Multicore ISPCState ())
 -> CompilerM Multicore ISPCState ())
-> ((VName, VName) -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState ()
forall a b. (a -> b) -> a -> b
$ \(VName
m, VName
s) -> do
    InitGroup -> CompilerM Multicore ISPCState ()
forall op s. InitGroup -> CompilerM op s ()
GC.decl [C.cdecl|$tyqual:varying unsigned char * $tyqual:uniform $id:m = $id:struct->$id:m;|]
    InitGroup -> CompilerM Multicore ISPCState ()
forall op s. InitGroup -> CompilerM op s ()
GC.decl [C.cdecl|size_t $id:s = $id:struct->$id:s;|]

-- | Write back potentially changed memory addresses and sizes to the memory struct
compileWritebackMemStructVals :: Name -> [(VName, VName)] -> [VName] -> ISPCCompilerM ()
compileWritebackMemStructVals :: Name
-> [(VName, VName)] -> [VName] -> CompilerM Multicore ISPCState ()
compileWritebackMemStructVals Name
struct [(VName, VName)]
lexmems [VName]
fatmems = do
  [VName]
-> (VName -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [VName]
fatmems ((VName -> CompilerM Multicore ISPCState ())
 -> CompilerM Multicore ISPCState ())
-> (VName -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState ()
forall a b. (a -> b) -> a -> b
$ \VName
m ->
    Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|*$id:struct->$id:m = $id:m;|]
  [(VName, VName)]
-> ((VName, VName) -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(VName, VName)]
lexmems (((VName, VName) -> CompilerM Multicore ISPCState ())
 -> CompilerM Multicore ISPCState ())
-> ((VName, VName) -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState ()
forall a b. (a -> b) -> a -> b
$ \(VName
m, VName
s) -> do
    Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:struct->$id:m = $id:m;|]
    Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:struct->$id:s = $id:s;|]

-- | Read back potentially changed memory addresses and sizes to the memory struct into local variables
compileReadbackMemStructVals :: Name -> [(VName, VName)] -> [VName] -> ISPCCompilerM ()
compileReadbackMemStructVals :: Name
-> [(VName, VName)] -> [VName] -> CompilerM Multicore ISPCState ()
compileReadbackMemStructVals Name
struct [(VName, VName)]
lexmems [VName]
fatmems = do
  [VName]
-> (VName -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [VName]
fatmems ((VName -> CompilerM Multicore ISPCState ())
 -> CompilerM Multicore ISPCState ())
-> (VName -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState ()
forall a b. (a -> b) -> a -> b
$ \VName
m ->
    Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:m = *$id:struct.$id:m;|]
  [(VName, VName)]
-> ((VName, VName) -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(VName, VName)]
lexmems (((VName, VName) -> CompilerM Multicore ISPCState ())
 -> CompilerM Multicore ISPCState ())
-> ((VName, VName) -> CompilerM Multicore ISPCState ())
-> CompilerM Multicore ISPCState ()
forall a b. (a -> b) -> a -> b
$ \(VName
m, VName
s) -> do
    Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:m = $id:struct.$id:m;|]
    Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:s = $id:struct.$id:s;|]

compileGetStructVals ::
  Name ->
  [VName] ->
  [(C.Type, MC.ValueType)] ->
  ISPCCompilerM [C.BlockItem]
compileGetStructVals :: Name -> [VName] -> [(Type, ValueType)] -> ISPCCompilerM [BlockItem]
compileGetStructVals Name
struct [VName]
a [(Type, ValueType)]
b = [[BlockItem]] -> [BlockItem]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[BlockItem]] -> [BlockItem])
-> CompilerM Multicore ISPCState [[BlockItem]]
-> ISPCCompilerM [BlockItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (VName -> (Type, ValueType) -> ISPCCompilerM [BlockItem])
-> [VName]
-> [(Type, ValueType)]
-> CompilerM Multicore ISPCState [[BlockItem]]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM VName -> (Type, ValueType) -> ISPCCompilerM [BlockItem]
field [VName]
a [(Type, ValueType)]
b
  where
    struct' :: Name
struct' = Name
struct Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_"
    field :: VName -> (Type, ValueType) -> ISPCCompilerM [BlockItem]
field VName
name (Type
ty, MC.Prim PrimType
pt) = do
      let inner :: Exp
inner = [C.cexp|$id:struct'->$id:(MC.closureFreeStructField name)|]
      [BlockItem] -> ISPCCompilerM [BlockItem]
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.citems|$tyqual:uniform $ty:ty $id:name = $exp:(fromStorage pt inner);|]
    field VName
name (Type
_, ValueType
_) = do
      Name
strlit <- String -> CompilerM Multicore ISPCState Name
makeStringLiteral (String -> CompilerM Multicore ISPCState Name)
-> String -> CompilerM Multicore ISPCState Name
forall a b. (a -> b) -> a -> b
$ VName -> String
forall a. Pretty a => a -> String
prettyString VName
name
      [BlockItem] -> ISPCCompilerM [BlockItem]
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [C.citems|$tyqual:uniform struct memblock $id:name;
                     $id:name.desc = $id:strlit();
                     $id:name.mem = $id:struct'->$id:(MC.closureFreeStructField name);
                     $id:name.size = 0;
                     $id:name.references = NULL;|]

-- | Can the given code produce an error? If so, we can't use foreach
-- loops, since they don't allow for early-outs in error handling.
mayProduceError :: MCCode -> Bool
mayProduceError :: MCCode -> Bool
mayProduceError (MCCode
x :>>: MCCode
y) = MCCode -> Bool
mayProduceError MCCode
x Bool -> Bool -> Bool
|| MCCode -> Bool
mayProduceError MCCode
y
mayProduceError (If TExp Bool
_ MCCode
x MCCode
y) = MCCode -> Bool
mayProduceError MCCode
x Bool -> Bool -> Bool
|| MCCode -> Bool
mayProduceError MCCode
y
mayProduceError (For VName
_ Exp
_ MCCode
x) = MCCode -> Bool
mayProduceError MCCode
x
mayProduceError (While TExp Bool
_ MCCode
x) = MCCode -> Bool
mayProduceError MCCode
x
mayProduceError (Comment Text
_ MCCode
x) = MCCode -> Bool
mayProduceError MCCode
x
mayProduceError (Op (ForEachActive VName
_ MCCode
body)) = MCCode -> Bool
mayProduceError MCCode
body
mayProduceError (Op (ForEach VName
_ Exp
_ Exp
_ MCCode
body)) = MCCode -> Bool
mayProduceError MCCode
body
mayProduceError (Op SegOp {}) = Bool
True
mayProduceError Allocate {} = Bool
True
mayProduceError Assert {} = Bool
True
mayProduceError SetMem {} = Bool
True
mayProduceError Free {} = Bool
True
mayProduceError Call {} = Bool
True
mayProduceError MCCode
_ = Bool
False

-- Generate a segop function for top_level and potentially nested SegOp code
compileOp :: GC.OpCompiler Multicore ISPCState
compileOp :: OpCompiler Multicore ISPCState
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 ISPCState (Type, ValueType))
-> [Param] -> CompilerM Multicore ISPCState [(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 ISPCState (Type, ValueType)
forall op s. Param -> CompilerM op s (Type, ValueType)
MC.paramToCType [Param]
params
  [(Type, ValueType)]
retval_ctypes <- (Param -> CompilerM Multicore ISPCState (Type, ValueType))
-> [Param] -> CompilerM Multicore ISPCState [(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 ISPCState (Type, ValueType)
forall op s. Param -> CompilerM op s (Type, ValueType)
MC.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 ISPCState Exp
compileExp Exp
e

  let lexical :: Map VName Space
lexical = KernelHandling -> Function Multicore -> Map VName Space
lexicalMemoryUsageMC KernelHandling
OpaqueKernels (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 ISPCState
-> String
-> [VName]
-> [(Type, ValueType)]
-> [VName]
-> [(Type, ValueType)]
-> CompilerM Multicore ISPCState Name
forall s.
DefSpecifier s
-> String
-> [VName]
-> [(Type, ValueType)]
-> [VName]
-> [(Type, ValueType)]
-> CompilerM Multicore s Name
MC.prepareTaskStruct DefSpecifier ISPCState
sharedDef 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 ISPCState Name
forall a s.
ToIdent a =>
Map VName Space
-> String
-> MCCode
-> a
-> [(VName, (Type, ValueType))]
-> [(VName, (Type, ValueType))]
-> CompilerM Multicore s Name
MC.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 ISPCState ()
forall op s. Name -> CompilerM op s ()
MC.addTimingFields Name
fpar_task

  let ftask_name :: Name
ftask_name = Name
fstruct Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_task"

  [BlockItem]
to_c <- CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
GC.collect (CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem])
-> CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall a b. (a -> b) -> a -> b
$ do
    InitGroup -> CompilerM Multicore ISPCState ()
forall op s. InitGroup -> CompilerM op s ()
GC.decl [C.cdecl|struct scheduler_segop $id:ftask_name;|]
    Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.args = args;|]
    Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.top_level_fn = $id:fpar_task;|]
    Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.name = $string:(nameToString fpar_task);|]
    Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.iterations = iterations;|]
    -- Create the timing fields for the task
    Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.task_time = &ctx->program->$id:(MC.functionTiming fpar_task);|]
    Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.task_iter = &ctx->program->$id:(MC.functionIterations fpar_task);|]

    case Scheduling
sched of
      Scheduling
Dynamic -> Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.sched = DYNAMIC;|]
      Scheduling
Static -> Stm -> CompilerM Multicore ISPCState ()
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
OpaqueKernels (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 ISPCState Name
forall a s.
ToIdent a =>
Map VName Space
-> String
-> MCCode
-> a
-> [(VName, (Type, ValueType))]
-> [(VName, (Type, ValueType))]
-> CompilerM Multicore s Name
MC.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 ISPCState ()
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 ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:ftask_name.nested_fn=NULL;|]

    Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|return scheduler_prepare_task(&ctx->scheduler, &$id:ftask_name);|]

  Name
schedn <- DefSpecifier ISPCState
forall s. DefSpecifier s
MC.multicoreDef String
"schedule_shim" ((Name -> CompilerM Multicore ISPCState Definition)
 -> CompilerM Multicore ISPCState Name)
-> (Name -> CompilerM Multicore ISPCState Definition)
-> CompilerM Multicore ISPCState Name
forall a b. (a -> b) -> a -> b
$ \Name
s ->
    Definition -> CompilerM Multicore ISPCState Definition
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      [C.cedecl|int $id:s(struct futhark_context* ctx, void* args, typename int64_t iterations) {
        $items:to_c
    }|]

  Definition -> CompilerM Multicore ISPCState ()
ispcDecl
    [C.cedecl|extern "C" $tyqual:unmasked $tyqual:uniform int $id:schedn
                        (struct futhark_context $tyqual:uniform * $tyqual:uniform ctx,
                        struct $id:fstruct $tyqual:uniform * $tyqual:uniform args,
                        $tyqual:uniform int iterations);|]

  VName
aos_name <- String -> CompilerM Multicore ISPCState VName
forall (m :: * -> *). MonadFreshNames m => String -> m VName
newVName String
"aos"
  [BlockItem] -> CompilerM Multicore ISPCState ()
forall op s. [BlockItem] -> CompilerM op s ()
GC.items
    [C.citems|
    $escstm:("#if defined(ISPC)")
    $tyqual:uniform struct $id:fstruct $id:aos_name[programCount];
    $id:aos_name[programIndex] = $id:(fstruct <> "_");
    $escstm:("foreach_active (i)")
    {
      if (err == 0) {
        err = $id:schedn(ctx, &$id:aos_name[i], extract($exp:e', i));
      }
    }
    if (err != 0) {
      $escstm:("unmasked { return err; }")
    }
    $escstm:("#else")
    err = $id:schedn(ctx, &$id:(fstruct <> "_"), $exp:e');
    if (err != 0) {
      goto cleanup;
    }
    $escstm:("#endif")|]
compileOp (ISPCKernel MCCode
body [Param]
free) = do
  [(Type, ValueType)]
free_ctypes <- (Param -> CompilerM Multicore ISPCState (Type, ValueType))
-> [Param] -> CompilerM Multicore ISPCState [(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 ISPCState (Type, ValueType)
forall op s. Param -> CompilerM op s (Type, ValueType)
MC.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
OpaqueKernels (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
  -- Generate ISPC kernel
  Name
fstruct <- DefSpecifier ISPCState
-> String
-> [VName]
-> [(Type, ValueType)]
-> [VName]
-> [(Type, ValueType)]
-> CompilerM Multicore ISPCState Name
forall s.
DefSpecifier s
-> String
-> [VName]
-> [(Type, ValueType)]
-> [VName]
-> [(Type, ValueType)]
-> CompilerM Multicore s Name
MC.prepareTaskStruct DefSpecifier ISPCState
sharedDef String
"param_struct" [VName]
free_args [(Type, ValueType)]
free_ctypes [] []
  let fstruct' :: Name
fstruct' = Name
fstruct Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_"

  Name
ispcShim <- DefSpecifier ISPCState
ispcDef String
"loop_ispc" ((Name -> CompilerM Multicore ISPCState Definition)
 -> CompilerM Multicore ISPCState Name)
-> (Name -> CompilerM Multicore ISPCState Definition)
-> CompilerM Multicore ISPCState Name
forall a b. (a -> b) -> a -> b
$ \Name
s -> do
    [BlockItem]
mainBody <- ISPCCompilerM [BlockItem] -> ISPCCompilerM [BlockItem]
forall op s a. CompilerM op s a -> CompilerM op s a
GC.inNewFunction (ISPCCompilerM [BlockItem] -> ISPCCompilerM [BlockItem])
-> ISPCCompilerM [BlockItem] -> ISPCCompilerM [BlockItem]
forall a b. (a -> b) -> a -> b
$
      MCCode -> ISPCCompilerM [BlockItem] -> ISPCCompilerM [BlockItem]
forall a. MCCode -> ISPCCompilerM a -> ISPCCompilerM a
analyzeVariability MCCode
body (ISPCCompilerM [BlockItem] -> ISPCCompilerM [BlockItem])
-> ISPCCompilerM [BlockItem] -> ISPCCompilerM [BlockItem]
forall a b. (a -> b) -> a -> b
$
        Map VName Space
-> ([BlockItem]
    -> [Stm] -> [(VName, VName)] -> ISPCCompilerM [BlockItem])
-> ISPCCompilerM [BlockItem]
forall op s a.
Map VName Space
-> ([BlockItem] -> [Stm] -> [(VName, VName)] -> CompilerM op s a)
-> CompilerM op s a
cachingMemory Map VName Space
lexical (([BlockItem]
  -> [Stm] -> [(VName, VName)] -> ISPCCompilerM [BlockItem])
 -> ISPCCompilerM [BlockItem])
-> ([BlockItem]
    -> [Stm] -> [(VName, VName)] -> ISPCCompilerM [BlockItem])
-> ISPCCompilerM [BlockItem]
forall a b. (a -> b) -> a -> b
$ \[BlockItem]
decl_cached [Stm]
free_cached [(VName, VName)]
lexmems ->
          CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
GC.collect (CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem])
-> CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall a b. (a -> b) -> a -> b
$ do
            InitGroup -> CompilerM Multicore ISPCState ()
forall op s. InitGroup -> CompilerM op s ()
GC.decl [C.cdecl|$tyqual:uniform struct futhark_context * $tyqual:uniform ctx = $id:fstruct'->ctx;|]
            [BlockItem] -> CompilerM Multicore ISPCState ()
forall op s. [BlockItem] -> CompilerM op s ()
GC.items ([BlockItem] -> CompilerM Multicore ISPCState ())
-> ISPCCompilerM [BlockItem] -> CompilerM Multicore ISPCState ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> [VName] -> [(Type, ValueType)] -> ISPCCompilerM [BlockItem]
compileGetStructVals Name
fstruct [VName]
free_args [(Type, ValueType)]
free_ctypes
            [BlockItem]
body' <- CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
GC.collect (CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem])
-> CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall a b. (a -> b) -> a -> b
$ MCCode -> CompilerM Multicore ISPCState ()
compileCode MCCode
body
            (BlockItem -> CompilerM Multicore ISPCState ())
-> [BlockItem] -> CompilerM Multicore ISPCState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BlockItem -> CompilerM Multicore ISPCState ()
forall op s. BlockItem -> CompilerM op s ()
GC.item [BlockItem]
decl_cached
            (BlockItem -> CompilerM Multicore ISPCState ())
-> [BlockItem] -> CompilerM Multicore ISPCState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BlockItem -> CompilerM Multicore ISPCState ()
forall op s. BlockItem -> CompilerM op s ()
GC.item ([BlockItem] -> CompilerM Multicore ISPCState ())
-> ISPCCompilerM [BlockItem] -> CompilerM Multicore ISPCState ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ISPCCompilerM [BlockItem]
forall op s. CompilerM op s [BlockItem]
GC.declAllocatedMem

            -- Make inner kernel for error handling, if needed
            if MCCode -> Bool
mayProduceError MCCode
body
              then do
                [VName]
fatmems <- (CompilerState ISPCState -> [VName])
-> CompilerM Multicore ISPCState [VName]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (((VName, Space) -> VName) -> [(VName, Space)] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map (VName, Space) -> VName
forall a b. (a, b) -> a
fst ([(VName, Space)] -> [VName])
-> (CompilerState ISPCState -> [(VName, Space)])
-> CompilerState ISPCState
-> [VName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerState ISPCState -> [(VName, Space)]
forall s. CompilerState s -> [(VName, Space)]
GC.compDeclaredMem)
                Name
mstruct <- [(VName, VName)] -> [VName] -> CompilerM Multicore ISPCState Name
prepareMemStruct [(VName, VName)]
lexmems [VName]
fatmems
                let mstruct' :: Name
mstruct' = Name
mstruct Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"_"
                Name
innerShim <- DefSpecifier ISPCState
ispcDef String
"inner_ispc" ((Name -> CompilerM Multicore ISPCState Definition)
 -> CompilerM Multicore ISPCState Name)
-> (Name -> CompilerM Multicore ISPCState Definition)
-> CompilerM Multicore ISPCState Name
forall a b. (a -> b) -> a -> b
$ \Name
t -> do
                  [BlockItem]
innerBody <- CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
GC.collect (CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem])
-> CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall a b. (a -> b) -> a -> b
$ do
                    InitGroup -> CompilerM Multicore ISPCState ()
forall op s. InitGroup -> CompilerM op s ()
GC.decl [C.cdecl|$tyqual:uniform struct futhark_context * $tyqual:uniform ctx = $id:fstruct'->ctx;|]
                    [BlockItem] -> CompilerM Multicore ISPCState ()
forall op s. [BlockItem] -> CompilerM op s ()
GC.items ([BlockItem] -> CompilerM Multicore ISPCState ())
-> ISPCCompilerM [BlockItem] -> CompilerM Multicore ISPCState ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> [VName] -> [(Type, ValueType)] -> ISPCCompilerM [BlockItem]
compileGetStructVals Name
fstruct [VName]
free_args [(Type, ValueType)]
free_ctypes
                    Name
-> [(VName, VName)] -> [VName] -> CompilerM Multicore ISPCState ()
compileGetMemStructVals Name
mstruct' [(VName, VName)]
lexmems [VName]
fatmems
                    InitGroup -> CompilerM Multicore ISPCState ()
forall op s. InitGroup -> CompilerM op s ()
GC.decl [C.cdecl|$tyqual:uniform int err = 0;|]
                    (BlockItem -> CompilerM Multicore ISPCState ())
-> [BlockItem] -> CompilerM Multicore ISPCState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BlockItem -> CompilerM Multicore ISPCState ()
forall op s. BlockItem -> CompilerM op s ()
GC.item [BlockItem]
body'
                    Name
-> [(VName, VName)] -> [VName] -> CompilerM Multicore ISPCState ()
compileWritebackMemStructVals Name
mstruct' [(VName, VName)]
lexmems [VName]
fatmems
                    Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|return err;|]
                  Definition -> CompilerM Multicore ISPCState Definition
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    [C.cedecl|
                static $tyqual:unmasked inline $tyqual:uniform int $id:t(
                  $tyqual:uniform typename int64_t start,
                  $tyqual:uniform typename int64_t end,
                  struct $id:fstruct $tyqual:uniform * $tyqual:uniform $id:fstruct',
                  struct $id:mstruct $tyqual:uniform * $tyqual:uniform $id:mstruct') {
                  $items:innerBody
                }|]
                -- Call the kernel and read back potentially changed memory
                InitGroup -> CompilerM Multicore ISPCState ()
forall op s. InitGroup -> CompilerM op s ()
GC.decl [C.cdecl|$tyqual:uniform int err = $id:innerShim(start, end, $id:fstruct', &$id:mstruct');|]
                Name
-> [(VName, VName)] -> [VName] -> CompilerM Multicore ISPCState ()
compileReadbackMemStructVals Name
mstruct' [(VName, VName)]
lexmems [VName]
fatmems
              else do
                InitGroup -> CompilerM Multicore ISPCState ()
forall op s. InitGroup -> CompilerM op s ()
GC.decl [C.cdecl|$tyqual:uniform int err = 0;|]
                (BlockItem -> CompilerM Multicore ISPCState ())
-> [BlockItem] -> CompilerM Multicore ISPCState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BlockItem -> CompilerM Multicore ISPCState ()
forall op s. BlockItem -> CompilerM op s ()
GC.item [BlockItem]
body'

            [BlockItem]
free_mem <- ISPCCompilerM [BlockItem]
freeAllocatedMem
            Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|cleanup: {$stms:free_cached $items:free_mem}|]
            Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|return err;|]
    Definition -> CompilerM Multicore ISPCState ()
forall op s. Definition -> CompilerM op s ()
GC.earlyDecl
      [C.cedecl|int $id:s(typename int64_t start,
                                  typename int64_t end,
                                  struct $id:fstruct * $id:fstruct');|]
    Definition -> CompilerM Multicore ISPCState Definition
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      [C.cedecl|
        $tyqual:export $tyqual:uniform int $id:s($tyqual:uniform typename int64_t start,
                                                 $tyqual:uniform typename int64_t end,
                                                 struct $id:fstruct $tyqual:uniform * $tyqual:uniform $id:fstruct' ) {
          $items:mainBody
        }|]

  -- Generate C code to call into ISPC kernel
  [BlockItem] -> CompilerM Multicore ISPCState ()
forall op s. [BlockItem] -> CompilerM op s ()
GC.items
    [C.citems|
    err = $id:ispcShim(start, end, & $id:fstruct');
    if (err != 0) {
      goto cleanup;
    }|]
compileOp (ForEach VName
i Exp
from Exp
bound MCCode
body) = do
  Exp
from' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
from
  Exp
bound' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
bound
  [BlockItem]
body' <- CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
GC.collect (CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem])
-> CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall a b. (a -> b) -> a -> b
$ MCCode -> CompilerM Multicore ISPCState ()
compileCode MCCode
body
  if MCCode -> Bool
mayProduceError MCCode
body
    then
      [Stm] -> CompilerM Multicore ISPCState ()
forall op s. [Stm] -> CompilerM op s ()
GC.stms
        [C.cstms|
      for ($tyqual:uniform typename int64_t i = 0; i < (($exp:bound' - $exp:from') / programCount); i++) {
        typename int64_t $id:i = $exp:from' + programIndex + i * programCount;
        $items:body'
      }
      if (programIndex < (($exp:bound' - $exp:from') % programCount)) {
        typename int64_t $id:i = $exp:from' + programIndex + ((($exp:bound' - $exp:from') / programCount) * programCount);
        $items:body'
      }|]
    else
      [Stm] -> CompilerM Multicore ISPCState ()
forall op s. [Stm] -> CompilerM op s ()
GC.stms
        [C.cstms|
      $escstm:(T.unpack ("foreach (" <> prettyText i <> " = " <> expText from' <> " ... " <> expText bound' <> ")")) {
        $items:body'
      }|]
compileOp (ForEachActive VName
name MCCode
body) = do
  [BlockItem]
body' <- CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
GC.collect (CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem])
-> CompilerM Multicore ISPCState () -> ISPCCompilerM [BlockItem]
forall a b. (a -> b) -> a -> b
$ MCCode -> CompilerM Multicore ISPCState ()
compileCode MCCode
body
  [Stm] -> CompilerM Multicore ISPCState ()
forall op s. [Stm] -> CompilerM op s ()
GC.stms
    [C.cstms|
    for ($tyqual:uniform unsigned int $id:name = 0; $id:name < programCount; $id:name++) {
      if (programIndex == $id:name) {
        $items:body'
      }
    }|]
compileOp (ExtractLane VName
dest (ValueExp PrimValue
v) Exp
_) =
  -- extract() on constants is not allowed (type is uniform, not
  -- varying), so just turn them into an assignment.
  Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:dest = $exp:v;|]
compileOp (ExtractLane VName
dest Exp
tar Exp
lane) = do
  Exp
tar' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
tar
  Exp
lane' <- Exp -> CompilerM Multicore ISPCState Exp
compileExp Exp
lane
  Stm -> CompilerM Multicore ISPCState ()
forall op s. Stm -> CompilerM op s ()
GC.stm [C.cstm|$id:dest = extract($exp:tar', $exp:lane');|]
compileOp (Atomic AtomicOp
aop) =
  AtomicOp
-> (Type -> VName -> ISPCCompilerM Type)
-> CompilerM Multicore ISPCState ()
forall op s.
AtomicOp
-> (Type -> VName -> CompilerM op s Type) -> CompilerM op s ()
MC.atomicOps AtomicOp
aop ((Type -> VName -> ISPCCompilerM Type)
 -> CompilerM Multicore ISPCState ())
-> (Type -> VName -> ISPCCompilerM Type)
-> CompilerM Multicore ISPCState ()
forall a b. (a -> b) -> a -> b
$ \Type
ty VName
arr -> do
    Bool
cached <- Maybe VName -> Bool
forall a. Maybe a -> Bool
isJust (Maybe VName -> Bool)
-> CompilerM Multicore ISPCState (Maybe VName)
-> CompilerM Multicore ISPCState Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> CompilerM Multicore ISPCState (Maybe VName)
forall a op s. ToExp a => a -> CompilerM op s (Maybe VName)
GC.cacheMem VName
arr
    if Bool
cached
      then Type -> ISPCCompilerM Type
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cty|$tyqual:varying $ty:ty* $tyqual:uniform|]
      else Type -> ISPCCompilerM Type
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cty|$ty:ty*|]
compileOp Multicore
op = OpCompiler Multicore ISPCState
forall s. OpCompiler Multicore s
MC.compileOp Multicore
op

-- | Like @GenericC.cachingMemory@, but adapted for ISPC codegen.
cachingMemory ::
  M.Map VName Space ->
  ([C.BlockItem] -> [C.Stm] -> [(VName, VName)] -> GC.CompilerM op s a) ->
  GC.CompilerM op s a
cachingMemory :: forall op s a.
Map VName Space
-> ([BlockItem] -> [Stm] -> [(VName, VName)] -> CompilerM op s a)
-> CompilerM op s a
cachingMemory Map VName Space
lexical [BlockItem] -> [Stm] -> [(VName, VName)] -> CompilerM op s a
f = do
  let cached :: [VName]
cached = Map VName Space -> [VName]
forall k a. Map k a -> [k]
M.keys (Map VName Space -> [VName]) -> Map VName Space -> [VName]
forall a b. (a -> b) -> a -> b
$ (Space -> Bool) -> Map VName Space -> Map VName Space
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Space -> Space -> Bool
forall a. Eq a => a -> a -> Bool
== Space
DefaultSpace) Map VName Space
lexical

  [(VName, VName)]
cached' <- [VName]
-> (VName -> CompilerM op s (VName, VName))
-> CompilerM op s [(VName, VName)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [VName]
cached ((VName -> CompilerM op s (VName, VName))
 -> CompilerM op s [(VName, VName)])
-> (VName -> CompilerM op s (VName, VName))
-> CompilerM op s [(VName, VName)]
forall a b. (a -> b) -> a -> b
$ \VName
mem -> do
    VName
size <- String -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => String -> m VName
newVName (String -> CompilerM op s VName) -> String -> CompilerM op s VName
forall a b. (a -> b) -> a -> b
$ VName -> String
forall a. Pretty a => a -> String
prettyString VName
mem String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_cached_size"
    (VName, VName) -> CompilerM op s (VName, VName)
forall a. a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VName
mem, VName
size)

  let lexMem :: CompilerEnv op s -> CompilerEnv op s
lexMem CompilerEnv op s
env =
        CompilerEnv op s
env
          { GC.envCachedMem =
              M.fromList (map (first (`C.toExp` noLoc)) cached')
                <> GC.envCachedMem env
          }

      declCached :: (a, a) -> [BlockItem]
declCached (a
mem, a
size) =
        [ [C.citem|size_t $id:size = 0;|],
          [C.citem|$tyqual:varying unsigned char * $tyqual:uniform $id:mem = NULL;|]
        ]

      freeCached :: (a, b) -> Stm
freeCached (a
mem, b
_) =
        [C.cstm|free($id:mem);|]

  (CompilerEnv op s -> CompilerEnv op s)
-> CompilerM op s a -> CompilerM op s a
forall a.
(CompilerEnv op s -> CompilerEnv op s)
-> CompilerM op s a -> CompilerM op s a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local CompilerEnv op s -> CompilerEnv op s
forall {op} {s}. CompilerEnv op s -> CompilerEnv op s
lexMem (CompilerM op s a -> CompilerM op s a)
-> CompilerM op s a -> CompilerM op s a
forall a b. (a -> b) -> a -> b
$ [BlockItem] -> [Stm] -> [(VName, VName)] -> CompilerM op s a
f (((VName, VName) -> [BlockItem]) -> [(VName, VName)] -> [BlockItem]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (VName, VName) -> [BlockItem]
forall {a} {a}. (ToIdent a, ToIdent a) => (a, a) -> [BlockItem]
declCached [(VName, VName)]
cached') (((VName, VName) -> Stm) -> [(VName, VName)] -> [Stm]
forall a b. (a -> b) -> [a] -> [b]
map (VName, VName) -> Stm
forall {a} {b}. ToIdent a => (a, b) -> Stm
freeCached [(VName, VName)]
cached') [(VName, VName)]
cached'

-- Variability analysis
type Dependencies = M.Map VName Names

data Variability = Uniform | Varying
  deriving (Variability -> Variability -> Bool
(Variability -> Variability -> Bool)
-> (Variability -> Variability -> Bool) -> Eq Variability
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Variability -> Variability -> Bool
== :: Variability -> Variability -> Bool
$c/= :: Variability -> Variability -> Bool
/= :: Variability -> Variability -> Bool
Eq, Eq Variability
Eq Variability =>
(Variability -> Variability -> Ordering)
-> (Variability -> Variability -> Bool)
-> (Variability -> Variability -> Bool)
-> (Variability -> Variability -> Bool)
-> (Variability -> Variability -> Bool)
-> (Variability -> Variability -> Variability)
-> (Variability -> Variability -> Variability)
-> Ord Variability
Variability -> Variability -> Bool
Variability -> Variability -> Ordering
Variability -> Variability -> Variability
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Variability -> Variability -> Ordering
compare :: Variability -> Variability -> Ordering
$c< :: Variability -> Variability -> Bool
< :: Variability -> Variability -> Bool
$c<= :: Variability -> Variability -> Bool
<= :: Variability -> Variability -> Bool
$c> :: Variability -> Variability -> Bool
> :: Variability -> Variability -> Bool
$c>= :: Variability -> Variability -> Bool
>= :: Variability -> Variability -> Bool
$cmax :: Variability -> Variability -> Variability
max :: Variability -> Variability -> Variability
$cmin :: Variability -> Variability -> Variability
min :: Variability -> Variability -> Variability
Ord, Int -> Variability -> String -> String
[Variability] -> String -> String
Variability -> String
(Int -> Variability -> String -> String)
-> (Variability -> String)
-> ([Variability] -> String -> String)
-> Show Variability
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Variability -> String -> String
showsPrec :: Int -> Variability -> String -> String
$cshow :: Variability -> String
show :: Variability -> String
$cshowList :: [Variability] -> String -> String
showList :: [Variability] -> String -> String
Show)

newtype VariabilityM a
  = VariabilityM (ReaderT Names (State Dependencies) a)
  deriving
    ( (forall a b. (a -> b) -> VariabilityM a -> VariabilityM b)
-> (forall a b. a -> VariabilityM b -> VariabilityM a)
-> Functor VariabilityM
forall a b. a -> VariabilityM b -> VariabilityM a
forall a b. (a -> b) -> VariabilityM a -> VariabilityM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> VariabilityM a -> VariabilityM b
fmap :: forall a b. (a -> b) -> VariabilityM a -> VariabilityM b
$c<$ :: forall a b. a -> VariabilityM b -> VariabilityM a
<$ :: forall a b. a -> VariabilityM b -> VariabilityM a
Functor,
      Functor VariabilityM
Functor VariabilityM =>
(forall a. a -> VariabilityM a)
-> (forall a b.
    VariabilityM (a -> b) -> VariabilityM a -> VariabilityM b)
-> (forall a b c.
    (a -> b -> c)
    -> VariabilityM a -> VariabilityM b -> VariabilityM c)
-> (forall a b. VariabilityM a -> VariabilityM b -> VariabilityM b)
-> (forall a b. VariabilityM a -> VariabilityM b -> VariabilityM a)
-> Applicative VariabilityM
forall a. a -> VariabilityM a
forall a b. VariabilityM a -> VariabilityM b -> VariabilityM a
forall a b. VariabilityM a -> VariabilityM b -> VariabilityM b
forall a b.
VariabilityM (a -> b) -> VariabilityM a -> VariabilityM b
forall a b c.
(a -> b -> c) -> VariabilityM a -> VariabilityM b -> VariabilityM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> VariabilityM a
pure :: forall a. a -> VariabilityM a
$c<*> :: forall a b.
VariabilityM (a -> b) -> VariabilityM a -> VariabilityM b
<*> :: forall a b.
VariabilityM (a -> b) -> VariabilityM a -> VariabilityM b
$cliftA2 :: forall a b c.
(a -> b -> c) -> VariabilityM a -> VariabilityM b -> VariabilityM c
liftA2 :: forall a b c.
(a -> b -> c) -> VariabilityM a -> VariabilityM b -> VariabilityM c
$c*> :: forall a b. VariabilityM a -> VariabilityM b -> VariabilityM b
*> :: forall a b. VariabilityM a -> VariabilityM b -> VariabilityM b
$c<* :: forall a b. VariabilityM a -> VariabilityM b -> VariabilityM a
<* :: forall a b. VariabilityM a -> VariabilityM b -> VariabilityM a
Applicative,
      Applicative VariabilityM
Applicative VariabilityM =>
(forall a b.
 VariabilityM a -> (a -> VariabilityM b) -> VariabilityM b)
-> (forall a b. VariabilityM a -> VariabilityM b -> VariabilityM b)
-> (forall a. a -> VariabilityM a)
-> Monad VariabilityM
forall a. a -> VariabilityM a
forall a b. VariabilityM a -> VariabilityM b -> VariabilityM b
forall a b.
VariabilityM a -> (a -> VariabilityM b) -> VariabilityM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b.
VariabilityM a -> (a -> VariabilityM b) -> VariabilityM b
>>= :: forall a b.
VariabilityM a -> (a -> VariabilityM b) -> VariabilityM b
$c>> :: forall a b. VariabilityM a -> VariabilityM b -> VariabilityM b
>> :: forall a b. VariabilityM a -> VariabilityM b -> VariabilityM b
$creturn :: forall a. a -> VariabilityM a
return :: forall a. a -> VariabilityM a
Monad,
      MonadState Dependencies,
      MonadReader Names
    )

execVariabilityM :: VariabilityM a -> Dependencies
execVariabilityM :: forall a. VariabilityM a -> Dependencies
execVariabilityM (VariabilityM ReaderT Names (State Dependencies) a
m) =
  State Dependencies a -> Dependencies -> Dependencies
forall s a. State s a -> s -> s
execState (ReaderT Names (State Dependencies) a
-> Names -> State Dependencies a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Names (State Dependencies) a
m Names
forall a. Monoid a => a
mempty) Dependencies
forall a. Monoid a => a
mempty

-- | Extend the set of dependencies with a new one
addDeps :: VName -> Names -> VariabilityM ()
addDeps :: VName -> Names -> VariabilityM ()
addDeps VName
v Names
ns = do
  Dependencies
deps <- VariabilityM Dependencies
forall s (m :: * -> *). MonadState s m => m s
get
  Names
env <- VariabilityM Names
forall r (m :: * -> *). MonadReader r m => m r
ask
  case VName -> Dependencies -> Maybe Names
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VName
v Dependencies
deps of
    Maybe Names
Nothing -> Dependencies -> VariabilityM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Dependencies -> VariabilityM ())
-> Dependencies -> VariabilityM ()
forall a b. (a -> b) -> a -> b
$ VName -> Names -> Dependencies -> Dependencies
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VName
v (Names
ns Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> Names
env) Dependencies
deps
    Just Names
ns' -> Dependencies -> VariabilityM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Dependencies -> VariabilityM ())
-> Dependencies -> VariabilityM ()
forall a b. (a -> b) -> a -> b
$ VName -> Names -> Dependencies -> Dependencies
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VName
v (Names
ns Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> Names
ns') Dependencies
deps

-- | Find all the dependencies in a body of code
findDeps :: MCCode -> VariabilityM ()
findDeps :: MCCode -> VariabilityM ()
findDeps (MCCode
x :>>: MCCode
y) = do
  MCCode -> VariabilityM ()
findDeps MCCode
x
  MCCode -> VariabilityM ()
findDeps MCCode
y
findDeps (If TExp Bool
cond MCCode
x MCCode
y) =
  (Names -> Names) -> VariabilityM () -> VariabilityM ()
forall a. (Names -> Names) -> VariabilityM a -> VariabilityM a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> TExp Bool -> Names
forall a. FreeIn a => a -> Names
freeIn TExp Bool
cond) (VariabilityM () -> VariabilityM ())
-> VariabilityM () -> VariabilityM ()
forall a b. (a -> b) -> a -> b
$ do
    MCCode -> VariabilityM ()
findDeps MCCode
x
    MCCode -> VariabilityM ()
findDeps MCCode
y
findDeps (For VName
idx Exp
bound MCCode
x) = do
  VName -> Names -> VariabilityM ()
addDeps VName
idx Names
free
  (Names -> Names) -> VariabilityM () -> VariabilityM ()
forall a. (Names -> Names) -> VariabilityM a -> VariabilityM a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> Names
free) (VariabilityM () -> VariabilityM ())
-> VariabilityM () -> VariabilityM ()
forall a b. (a -> b) -> a -> b
$ MCCode -> VariabilityM ()
findDeps MCCode
x
  where
    free :: Names
free = Exp -> Names
forall a. FreeIn a => a -> Names
freeIn Exp
bound
findDeps (While TExp Bool
cond MCCode
x) = do
  (Names -> Names) -> VariabilityM () -> VariabilityM ()
forall a. (Names -> Names) -> VariabilityM a -> VariabilityM a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> TExp Bool -> Names
forall a. FreeIn a => a -> Names
freeIn TExp Bool
cond) (VariabilityM () -> VariabilityM ())
-> VariabilityM () -> VariabilityM ()
forall a b. (a -> b) -> a -> b
$ MCCode -> VariabilityM ()
findDeps MCCode
x
findDeps (Comment Text
_ MCCode
x) =
  MCCode -> VariabilityM ()
findDeps MCCode
x
findDeps (Op (SegOp String
_ [Param]
free ParallelTask
_ Maybe ParallelTask
_ [Param]
retvals SchedulerInfo
_)) =
  (Param -> VariabilityM ()) -> [Param] -> VariabilityM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
    ( \Param
x ->
        VName -> Names -> VariabilityM ()
addDeps (Param -> VName
paramName Param
x) (Names -> VariabilityM ()) -> Names -> VariabilityM ()
forall a b. (a -> b) -> a -> b
$
          [VName] -> Names
namesFromList ([VName] -> Names) -> [VName] -> Names
forall a b. (a -> b) -> a -> b
$
            (Param -> VName) -> [Param] -> [VName]
forall a b. (a -> b) -> [a] -> [b]
map Param -> VName
paramName [Param]
free
    )
    [Param]
retvals
findDeps (Op (ForEach VName
_ Exp
_ Exp
_ MCCode
body)) =
  MCCode -> VariabilityM ()
findDeps MCCode
body
findDeps (Op (ForEachActive VName
_ MCCode
body)) =
  MCCode -> VariabilityM ()
findDeps MCCode
body
findDeps (SetScalar VName
name Exp
e) =
  VName -> Names -> VariabilityM ()
addDeps VName
name (Names -> VariabilityM ()) -> Names -> VariabilityM ()
forall a b. (a -> b) -> a -> b
$ Exp -> Names
forall a. FreeIn a => a -> Names
freeIn Exp
e
findDeps (Call [VName]
tars Name
_ [Arg]
args) =
  (VName -> VariabilityM ()) -> [VName] -> VariabilityM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\VName
x -> VName -> Names -> VariabilityM ()
addDeps VName
x (Names -> VariabilityM ()) -> Names -> VariabilityM ()
forall a b. (a -> b) -> a -> b
$ [Arg] -> Names
forall a. FreeIn a => a -> Names
freeIn [Arg]
args) [VName]
tars
findDeps (Read VName
x VName
arr (Count TExp Int64
iexp) PrimType
_ Space
DefaultSpace Volatility
_) = do
  VName -> Names -> VariabilityM ()
addDeps VName
x (Names -> VariabilityM ()) -> Names -> VariabilityM ()
forall a b. (a -> b) -> a -> b
$ Exp -> Names
forall a. FreeIn a => a -> Names
freeIn (TExp Int64 -> Exp
forall {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped TExp Int64
iexp)
  VName -> Names -> VariabilityM ()
addDeps VName
x (Names -> VariabilityM ()) -> Names -> VariabilityM ()
forall a b. (a -> b) -> a -> b
$ VName -> Names
oneName VName
arr
findDeps (Op (GetLoopBounds VName
x VName
y)) = do
  VName -> Names -> VariabilityM ()
addDeps VName
x Names
forall a. Monoid a => a
mempty
  VName -> Names -> VariabilityM ()
addDeps VName
y Names
forall a. Monoid a => a
mempty
findDeps (Op (ExtractLane VName
x Exp
_ Exp
_)) = do
  VName -> Names -> VariabilityM ()
addDeps VName
x Names
forall a. Monoid a => a
mempty
findDeps (Op (Atomic (AtomicCmpXchg PrimType
_ VName
old VName
arr Count Elements (TExp Int32)
ind VName
res Exp
val))) = do
  VName -> Names -> VariabilityM ()
addDeps VName
res (Names -> VariabilityM ()) -> Names -> VariabilityM ()
forall a b. (a -> b) -> a -> b
$ VName -> Names
forall a. FreeIn a => a -> Names
freeIn VName
arr Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> Count Elements (TExp Int32) -> Names
forall a. FreeIn a => a -> Names
freeIn Count Elements (TExp Int32)
ind Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> Exp -> Names
forall a. FreeIn a => a -> Names
freeIn Exp
val
  VName -> Names -> VariabilityM ()
addDeps VName
old (Names -> VariabilityM ()) -> Names -> VariabilityM ()
forall a b. (a -> b) -> a -> b
$ VName -> Names
forall a. FreeIn a => a -> Names
freeIn VName
arr Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> Count Elements (TExp Int32) -> Names
forall a. FreeIn a => a -> Names
freeIn Count Elements (TExp Int32)
ind Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> Exp -> Names
forall a. FreeIn a => a -> Names
freeIn Exp
val
findDeps MCCode
_ = () -> VariabilityM ()
forall a. a -> VariabilityM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Take a list of dependencies and iterate them to a fixed point.
depsFixedPoint :: Dependencies -> Dependencies
depsFixedPoint :: Dependencies -> Dependencies
depsFixedPoint Dependencies
deps =
  if Dependencies
deps Dependencies -> Dependencies -> Bool
forall a. Eq a => a -> a -> Bool
== Dependencies
deps'
    then Dependencies
deps
    else Dependencies -> Dependencies
depsFixedPoint Dependencies
deps'
  where
    grow :: Names -> Names
grow Names
names =
      Names
names Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> (VName -> Names) -> IntMap VName -> Names
forall m a. Monoid m => (a -> m) -> IntMap a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\VName
n -> Names -> VName -> Dependencies -> Names
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Names
forall a. Monoid a => a
mempty VName
n Dependencies
deps) (Names -> IntMap VName
namesIntMap Names
names)
    deps' :: Dependencies
deps' = (Names -> Names) -> Dependencies -> Dependencies
forall a b k. (a -> b) -> Map k a -> Map k b
M.map Names -> Names
grow Dependencies
deps

-- | Find roots of variance. These are memory blocks declared in
-- the current scope as well as loop indices of foreach loops.
findVarying :: MCCode -> [VName]
findVarying :: MCCode -> [VName]
findVarying (MCCode
x :>>: MCCode
y) = MCCode -> [VName]
findVarying MCCode
x [VName] -> [VName] -> [VName]
forall a. [a] -> [a] -> [a]
++ MCCode -> [VName]
findVarying MCCode
y
findVarying (If TExp Bool
_ MCCode
x MCCode
y) = MCCode -> [VName]
findVarying MCCode
x [VName] -> [VName] -> [VName]
forall a. [a] -> [a] -> [a]
++ MCCode -> [VName]
findVarying MCCode
y
findVarying (For VName
_ Exp
_ MCCode
x) = MCCode -> [VName]
findVarying MCCode
x
findVarying (While TExp Bool
_ MCCode
x) = MCCode -> [VName]
findVarying MCCode
x
findVarying (Comment Text
_ MCCode
x) = MCCode -> [VName]
findVarying MCCode
x
findVarying (Op (ForEachActive VName
_ MCCode
body)) = MCCode -> [VName]
findVarying MCCode
body
findVarying (Op (ForEach VName
idx Exp
_ Exp
_ MCCode
body)) = VName
idx VName -> [VName] -> [VName]
forall a. a -> [a] -> [a]
: MCCode -> [VName]
findVarying MCCode
body
findVarying (DeclareMem VName
mem Space
_) = [VName
mem]
findVarying MCCode
_ = []

-- | Analyze variability in a body of code and run an action with
-- info about that variability in the compiler state.
analyzeVariability :: MCCode -> ISPCCompilerM a -> ISPCCompilerM a
analyzeVariability :: forall a. MCCode -> ISPCCompilerM a -> ISPCCompilerM a
analyzeVariability MCCode
code ISPCCompilerM a
m = do
  let roots :: [VName]
roots = MCCode -> [VName]
findVarying MCCode
code
  let deps :: Dependencies
deps = Dependencies -> Dependencies
depsFixedPoint (Dependencies -> Dependencies) -> Dependencies -> Dependencies
forall a b. (a -> b) -> a -> b
$ VariabilityM () -> Dependencies
forall a. VariabilityM a -> Dependencies
execVariabilityM (VariabilityM () -> Dependencies)
-> VariabilityM () -> Dependencies
forall a b. (a -> b) -> a -> b
$ MCCode -> VariabilityM ()
findDeps MCCode
code
  let safelist :: Dependencies
safelist = (Names -> Bool) -> Dependencies -> Dependencies
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (\Names
b -> (VName -> Bool) -> [VName] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (VName -> Names -> Bool
`notNameIn` Names
b) [VName]
roots) Dependencies
deps
  let safe :: Names
safe = [VName] -> Names
namesFromList ([VName] -> Names) -> [VName] -> Names
forall a b. (a -> b) -> a -> b
$ Dependencies -> [VName]
forall k a. Map k a -> [k]
M.keys Dependencies
safelist
  ISPCState
pre_state <- CompilerM Multicore ISPCState ISPCState
forall op s. CompilerM op s s
GC.getUserState
  (ISPCState -> ISPCState) -> CompilerM Multicore ISPCState ()
forall s op. (s -> s) -> CompilerM op s ()
GC.modifyUserState (\ISPCState
s -> ISPCState
s {sUniform = safe})
  a
a <- ISPCCompilerM a
m
  (ISPCState -> ISPCState) -> CompilerM Multicore ISPCState ()
forall s op. (s -> s) -> CompilerM op s ()
GC.modifyUserState (\ISPCState
s -> ISPCState
s {sUniform = sUniform pre_state})
  a -> ISPCCompilerM a
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

-- | Get the variability of a variable
getVariability :: VName -> ISPCCompilerM Variability
getVariability :: VName -> ISPCCompilerM Variability
getVariability VName
name = do
  Names
uniforms <- ISPCState -> Names
sUniform (ISPCState -> Names)
-> CompilerM Multicore ISPCState ISPCState
-> CompilerM Multicore ISPCState Names
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompilerM Multicore ISPCState ISPCState
forall op s. CompilerM op s s
GC.getUserState
  Variability -> ISPCCompilerM Variability
forall a. a -> CompilerM Multicore ISPCState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Variability -> ISPCCompilerM Variability)
-> Variability -> ISPCCompilerM Variability
forall a b. (a -> b) -> a -> b
$
    if VName
name VName -> Names -> Bool
`nameIn` Names
uniforms
      then Variability
Uniform
      else Variability
Varying

-- | Get the variability qualifiers of a variable
getVariabilityQuals :: VName -> ISPCCompilerM [C.TypeQual]
getVariabilityQuals :: VName -> ISPCCompilerM [TypeQual]
getVariabilityQuals VName
name = Variability -> [TypeQual]
variQuals (Variability -> [TypeQual])
-> ISPCCompilerM Variability -> ISPCCompilerM [TypeQual]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> ISPCCompilerM Variability
getVariability VName
name
  where
    variQuals :: Variability -> [TypeQual]
variQuals Variability
Uniform = [C.ctyquals|$tyqual:uniform|]
    variQuals Variability
Varying = []