{-# LANGUAGE QuasiQuotes #-}

-- | Code generation for public API types.
module Futhark.CodeGen.Backends.GenericC.Types
  ( generateAPITypes,
    valueTypeToCType,
    opaqueToCType,
  )
where

import Control.Monad
import Control.Monad.Reader (asks)
import Control.Monad.State (gets, modify)
import Data.Char (isDigit)
import Data.Map.Strict qualified as M
import Data.Maybe
import Data.Text qualified as T
import Futhark.CodeGen.Backends.GenericC.Monad
import Futhark.CodeGen.Backends.GenericC.Pretty
import Futhark.CodeGen.ImpCode
import Futhark.Manifest qualified as Manifest
import Futhark.Util (chunks, mapAccumLM, zEncodeText)
import Language.C.Quote.OpenCL qualified as C
import Language.C.Syntax qualified as C

opaqueToCType :: Name -> CompilerM op s C.Type
opaqueToCType :: forall op s. Name -> CompilerM op s Type
opaqueToCType Name
desc = do
  Text
name <- forall op s. Text -> CompilerM op s Text
publicName forall a b. (a -> b) -> a -> b
$ Name -> Text
opaqueName Name
desc
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cty|struct $id:name|]

valueTypeToCType :: Publicness -> ValueType -> CompilerM op s C.Type
valueTypeToCType :: forall op s. Publicness -> ValueType -> CompilerM op s Type
valueTypeToCType Publicness
_ (ValueType Signedness
signed (Rank Int
0) PrimType
pt) =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Signedness -> PrimType -> Type
primAPIType Signedness
signed PrimType
pt
valueTypeToCType Publicness
pub (ValueType Signedness
signed (Rank Int
rank) PrimType
pt) = do
  Text
name <- forall op s. Text -> CompilerM op s Text
publicName forall a b. (a -> b) -> a -> b
$ PrimType -> Signedness -> Int -> Text
arrayName PrimType
pt Signedness
signed Int
rank
  let add :: Map (Signedness, PrimType, Int) Publicness
-> Map (Signedness, PrimType, Int) Publicness
add = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. Ord a => a -> a -> a
max (Signedness
signed, PrimType
pt, Int
rank) Publicness
pub
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \CompilerState s
s -> CompilerState s
s {compArrayTypes :: Map (Signedness, PrimType, Int) Publicness
compArrayTypes = Map (Signedness, PrimType, Int) Publicness
-> Map (Signedness, PrimType, Int) Publicness
add forall a b. (a -> b) -> a -> b
$ forall s.
CompilerState s -> Map (Signedness, PrimType, Int) Publicness
compArrayTypes CompilerState s
s}
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cty|struct $id:name|]

arrayLibraryFunctions ::
  Publicness ->
  Space ->
  PrimType ->
  Signedness ->
  Int ->
  CompilerM op s Manifest.ArrayOps
arrayLibraryFunctions :: forall op s.
Publicness
-> Space
-> PrimType
-> Signedness
-> Int
-> CompilerM op s ArrayOps
arrayLibraryFunctions Publicness
pub Space
space PrimType
pt Signedness
signed Int
rank = do
  let pt' :: Type
pt' = Signedness -> PrimType -> Type
primAPIType Signedness
signed PrimType
pt
      name :: Text
name = PrimType -> Signedness -> Int -> Text
arrayName PrimType
pt Signedness
signed Int
rank
      arr_name :: Text
arr_name = Text
"futhark_" forall a. Semigroup a => a -> a -> a
<> Text
name
      array_type :: Type
array_type = [C.cty|struct $id:arr_name|]

  Text
new_array <- forall op s. Text -> CompilerM op s Text
publicName forall a b. (a -> b) -> a -> b
$ Text
"new_" forall a. Semigroup a => a -> a -> a
<> Text
name
  Text
new_raw_array <- forall op s. Text -> CompilerM op s Text
publicName forall a b. (a -> b) -> a -> b
$ Text
"new_raw_" forall a. Semigroup a => a -> a -> a
<> Text
name
  Text
free_array <- forall op s. Text -> CompilerM op s Text
publicName forall a b. (a -> b) -> a -> b
$ Text
"free_" forall a. Semigroup a => a -> a -> a
<> Text
name
  Text
values_array <- forall op s. Text -> CompilerM op s Text
publicName forall a b. (a -> b) -> a -> b
$ Text
"values_" forall a. Semigroup a => a -> a -> a
<> Text
name
  Text
values_raw_array <- forall op s. Text -> CompilerM op s Text
publicName forall a b. (a -> b) -> a -> b
$ Text
"values_raw_" forall a. Semigroup a => a -> a -> a
<> Text
name
  Text
shape_array <- forall op s. Text -> CompilerM op s Text
publicName forall a b. (a -> b) -> a -> b
$ Text
"shape_" forall a. Semigroup a => a -> a -> a
<> Text
name

  let shape_names :: [Text]
shape_names = [Text
"dim" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
prettyText Int
i | Int
i <- [Int
0 .. Int
rank forall a. Num a => a -> a -> a
- Int
1]]
      shape_params :: [Param]
shape_params = [[C.cparam|typename int64_t $id:k|] | Text
k <- [Text]
shape_names]
      arr_size :: Exp
arr_size = [Exp] -> Exp
cproduct [[C.cexp|$id:k|] | Text
k <- [Text]
shape_names]
      arr_size_array :: Exp
arr_size_array = [Exp] -> Exp
cproduct [[C.cexp|arr->shape[$int:i]|] | Int
i <- [Int
0 .. Int
rank forall a. Num a => a -> a -> a
- Int
1]]
  Copy op s
copy <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a -> b) -> a -> b
$ forall op s. Operations op s -> Copy op s
opsCopy forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall op s. CompilerEnv op s -> Operations op s
envOperations

  Type
memty <- forall op s. Space -> CompilerM op s Type
rawMemCType Space
space

  let prepare_new :: CompilerM op s ()
prepare_new = do
        forall a op s. ToExp a => a -> Space -> CompilerM op s ()
resetMem [C.cexp|arr->mem|] Space
space
        forall a b op s.
(ToExp a, ToExp b) =>
a -> b -> Space -> Stm -> CompilerM op s ()
allocMem
          [C.cexp|arr->mem|]
          [C.cexp|$exp:arr_size * $int:(primByteSize pt::Int)|]
          Space
space
          [C.cstm|return NULL;|]
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
rank forall a. Num a => a -> a -> a
- Int
1] forall a b. (a -> b) -> a -> b
$ \Int
i ->
          let dim_s :: [Char]
dim_s = [Char]
"dim" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
i
           in forall op s. Stm -> CompilerM op s ()
stm [C.cstm|arr->shape[$int:i] = $id:dim_s;|]

  [BlockItem]
new_body <- forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect forall a b. (a -> b) -> a -> b
$ do
    forall {op} {s}. CompilerM op s ()
prepare_new
    Copy op s
copy
      CopyBarrier
CopyNoBarrier
      [C.cexp|arr->mem.mem|]
      [C.cexp|0|]
      Space
space
      [C.cexp|(const unsigned char*)data|]
      [C.cexp|0|]
      Space
DefaultSpace
      [C.cexp|((size_t)$exp:arr_size) * $int:(primByteSize pt::Int)|]

  [BlockItem]
new_raw_body <- forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect forall a b. (a -> b) -> a -> b
$ do
    forall {op} {s}. CompilerM op s ()
prepare_new
    Copy op s
copy
      CopyBarrier
CopyNoBarrier
      [C.cexp|arr->mem.mem|]
      [C.cexp|0|]
      Space
space
      [C.cexp|data|]
      [C.cexp|offset|]
      Space
space
      [C.cexp|((size_t)$exp:arr_size) * $int:(primByteSize pt::Int)|]

  [BlockItem]
free_body <- forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect forall a b. (a -> b) -> a -> b
$ forall a op s. ToExp a => a -> Space -> CompilerM op s ()
unRefMem [C.cexp|arr->mem|] Space
space

  [BlockItem]
values_body <-
    forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect forall a b. (a -> b) -> a -> b
$
      Copy op s
copy
        CopyBarrier
CopyNoBarrier
        [C.cexp|(unsigned char*)data|]
        [C.cexp|0|]
        Space
DefaultSpace
        [C.cexp|arr->mem.mem|]
        [C.cexp|0|]
        Space
space
        [C.cexp|((size_t)$exp:arr_size_array) * $int:(primByteSize pt::Int)|]

  Type
ctx_ty <- forall op s. CompilerM op s Type
contextType
  Operations op s
ops <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall op s. CompilerEnv op s -> Operations op s
envOperations

  let proto :: Definition -> CompilerM op s ()
proto = case Publicness
pub of
        Publicness
Public -> forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl (Name -> HeaderSection
ArrayDecl (Text -> Name
nameFromText Text
name))
        Publicness
Private -> forall op s. Definition -> CompilerM op s ()
libDecl

  forall op s. Definition -> CompilerM op s ()
proto
    [C.cedecl|struct $id:arr_name;|]
  forall op s. Definition -> CompilerM op s ()
proto
    [C.cedecl|$ty:array_type* $id:new_array($ty:ctx_ty *ctx, const $ty:pt' *data, $params:shape_params);|]
  forall op s. Definition -> CompilerM op s ()
proto
    [C.cedecl|$ty:array_type* $id:new_raw_array($ty:ctx_ty *ctx, $ty:memty data, typename int64_t offset, $params:shape_params);|]
  forall op s. Definition -> CompilerM op s ()
proto
    [C.cedecl|int $id:free_array($ty:ctx_ty *ctx, $ty:array_type *arr);|]
  forall op s. Definition -> CompilerM op s ()
proto
    [C.cedecl|int $id:values_array($ty:ctx_ty *ctx, $ty:array_type *arr, $ty:pt' *data);|]
  forall op s. Definition -> CompilerM op s ()
proto
    [C.cedecl|$ty:memty $id:values_raw_array($ty:ctx_ty *ctx, $ty:array_type *arr);|]
  forall op s. Definition -> CompilerM op s ()
proto
    [C.cedecl|const typename int64_t* $id:shape_array($ty:ctx_ty *ctx, $ty:array_type *arr);|]

  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
    forall op s. Definition -> CompilerM op s ()
libDecl
    [C.cunit|
          $ty:array_type* $id:new_array($ty:ctx_ty *ctx, const $ty:pt' *data, $params:shape_params) {
            int err = 0;
            $ty:array_type* bad = NULL;
            $ty:array_type *arr = ($ty:array_type*) malloc(sizeof($ty:array_type));
            if (arr == NULL) {
              return bad;
            }
            $items:(criticalSection ops new_body)
            if (err != 0) {
              free(arr);
              return bad;
            }
            return arr;
          }

          $ty:array_type* $id:new_raw_array($ty:ctx_ty *ctx, $ty:memty data, typename int64_t offset, $params:shape_params) {
            int err = 0;
            $ty:array_type* bad = NULL;
            $ty:array_type *arr = ($ty:array_type*) malloc(sizeof($ty:array_type));
            if (arr == NULL) {
              return bad;
            }
            $items:(criticalSection ops new_raw_body)
            return arr;
          }

          int $id:free_array($ty:ctx_ty *ctx, $ty:array_type *arr) {
            $items:(criticalSection ops free_body)
            free(arr);
            return 0;
          }

          int $id:values_array($ty:ctx_ty *ctx, $ty:array_type *arr, $ty:pt' *data) {
            int err = 0;
            $items:(criticalSection ops values_body)
            return err;
          }

          $ty:memty $id:values_raw_array($ty:ctx_ty *ctx, $ty:array_type *arr) {
            (void)ctx;
            return arr->mem.mem;
          }

          const typename int64_t* $id:shape_array($ty:ctx_ty *ctx, $ty:array_type *arr) {
            (void)ctx;
            return arr->shape;
          }
          |]

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Manifest.ArrayOps
      { arrayFree :: Text
Manifest.arrayFree = Text
free_array,
        arrayShape :: Text
Manifest.arrayShape = Text
shape_array,
        arrayValues :: Text
Manifest.arrayValues = Text
values_array,
        arrayNew :: Text
Manifest.arrayNew = Text
new_array
      }

lookupOpaqueType :: Name -> OpaqueTypes -> OpaqueType
lookupOpaqueType :: Name -> OpaqueTypes -> OpaqueType
lookupOpaqueType Name
v (OpaqueTypes [(Name, OpaqueType)]
types) =
  case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
v [(Name, OpaqueType)]
types of
    Just OpaqueType
t -> OpaqueType
t
    Maybe OpaqueType
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown opaque type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Name
v

opaquePayload :: OpaqueTypes -> OpaqueType -> [ValueType]
opaquePayload :: OpaqueTypes -> OpaqueType -> [ValueType]
opaquePayload OpaqueTypes
_ (OpaqueType [ValueType]
ts) = [ValueType]
ts
opaquePayload OpaqueTypes
types (OpaqueRecord [(Name, EntryPointType)]
fs) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. (a, EntryPointType) -> [ValueType]
f [(Name, EntryPointType)]
fs
  where
    f :: (a, EntryPointType) -> [ValueType]
f (a
_, TypeOpaque Name
s) = OpaqueTypes -> OpaqueType -> [ValueType]
opaquePayload OpaqueTypes
types forall a b. (a -> b) -> a -> b
$ Name -> OpaqueTypes -> OpaqueType
lookupOpaqueType Name
s OpaqueTypes
types
    f (a
_, TypeTransparent ValueType
v) = [ValueType
v]

entryPointTypeToCType :: Publicness -> EntryPointType -> CompilerM op s C.Type
entryPointTypeToCType :: forall op s. Publicness -> EntryPointType -> CompilerM op s Type
entryPointTypeToCType Publicness
_ (TypeOpaque Name
desc) = forall op s. Name -> CompilerM op s Type
opaqueToCType Name
desc
entryPointTypeToCType Publicness
pub (TypeTransparent ValueType
vt) = forall op s. Publicness -> ValueType -> CompilerM op s Type
valueTypeToCType Publicness
pub ValueType
vt

entryTypeName :: EntryPointType -> Manifest.TypeName
entryTypeName :: EntryPointType -> Text
entryTypeName (TypeOpaque Name
desc) = Name -> Text
nameToText Name
desc
entryTypeName (TypeTransparent ValueType
vt) = forall a. Pretty a => a -> Text
prettyText ValueType
vt

-- | Figure out which of the members of an opaque type corresponds to
-- which fields.
recordFieldPayloads :: OpaqueTypes -> [EntryPointType] -> [a] -> [[a]]
recordFieldPayloads :: forall a. OpaqueTypes -> [EntryPointType] -> [a] -> [[a]]
recordFieldPayloads OpaqueTypes
types = forall a. [Int] -> [a] -> [[a]]
chunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map EntryPointType -> Int
typeLength
  where
    typeLength :: EntryPointType -> Int
typeLength (TypeTransparent ValueType
_) = Int
1
    typeLength (TypeOpaque Name
desc) =
      forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ OpaqueTypes -> OpaqueType -> [ValueType]
opaquePayload OpaqueTypes
types forall a b. (a -> b) -> a -> b
$ Name -> OpaqueTypes -> OpaqueType
lookupOpaqueType Name
desc OpaqueTypes
types

opaqueProjectFunctions ::
  OpaqueTypes ->
  Name ->
  [(Name, EntryPointType)] ->
  [ValueType] ->
  CompilerM op s [Manifest.RecordField]
opaqueProjectFunctions :: forall op s.
OpaqueTypes
-> Name
-> [(Name, EntryPointType)]
-> [ValueType]
-> CompilerM op s [RecordField]
opaqueProjectFunctions OpaqueTypes
types Name
desc [(Name, EntryPointType)]
fs [ValueType]
vds = do
  Type
opaque_type <- forall op s. Name -> CompilerM op s Type
opaqueToCType Name
desc
  Type
ctx_ty <- forall op s. CompilerM op s Type
contextType
  Operations op s
ops <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall op s. CompilerEnv op s -> Operations op s
envOperations
  let mkProject :: EntryPointType
-> [(Int, ValueType)] -> CompilerM op s (Type, [BlockItem])
mkProject (TypeTransparent (ValueType Signedness
sign (Rank Int
0) PrimType
pt)) [(Int
i, ValueType
_)] = do
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( Signedness -> PrimType -> Type
primAPIType Signedness
sign PrimType
pt,
            [C.citems|v = obj->$id:(tupleField i);|]
          )
      mkProject (TypeTransparent ValueType
vt) [(Int
i, ValueType
_)] = do
        Type
ct <- forall op s. Publicness -> ValueType -> CompilerM op s Type
valueTypeToCType Publicness
Public ValueType
vt
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( [C.cty|$ty:ct *|],
            forall op s. Operations op s -> [BlockItem] -> [BlockItem]
criticalSection
              Operations op s
ops
              [C.citems|v = malloc(sizeof($ty:ct));
                        memcpy(v, obj->$id:(tupleField i), sizeof($ty:ct));
                        (void)(*(v->mem.references))++;|]
          )
      mkProject (TypeTransparent ValueType
_) [(Int, ValueType)]
rep =
        forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"mkProject: invalid representation of transparent type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [(Int, ValueType)]
rep
      mkProject (TypeOpaque Name
f_desc) [(Int, ValueType)]
components = do
        Type
ct <- forall op s. Name -> CompilerM op s Type
opaqueToCType Name
f_desc
        let setField :: Int -> (Int, ValueType) -> [BlockItem]
setField Int
j (Int
i, ValueType Signedness
_ (Rank Int
r) PrimType
_) =
              if Int
r forall a. Eq a => a -> a -> Bool
== Int
0
                then [C.citems|v->$id:(tupleField j) = obj->$id:(tupleField i);|]
                else
                  [C.citems|v->$id:(tupleField j) = malloc(sizeof(*v->$id:(tupleField j)));
                            *v->$id:(tupleField j) = *obj->$id:(tupleField i);
                            (void)(*(v->$id:(tupleField j)->mem.references))++;|]
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( [C.cty|$ty:ct *|],
            forall op s. Operations op s -> [BlockItem] -> [BlockItem]
criticalSection
              Operations op s
ops
              [C.citems|v = malloc(sizeof($ty:ct));
                        $items:(concat (zipWith setField [0..] components))|]
          )
  let onField :: ((Name, EntryPointType), [(Int, ValueType)])
-> CompilerM op s RecordField
onField ((Name
f, EntryPointType
et), [(Int, ValueType)]
elems) = do
        let f' :: Text
f' =
              if Text -> Bool
isValidCName forall a b. (a -> b) -> a -> b
$ Name -> Text
opaqueName Name
desc forall a. Semigroup a => a -> a -> a
<> Text
"_" forall a. Semigroup a => a -> a -> a
<> Name -> Text
nameToText Name
f
                then Name -> Text
nameToText Name
f
                else Text -> Text
zEncodeText (Name -> Text
nameToText Name
f)
        Text
project <- forall op s. Text -> CompilerM op s Text
publicName forall a b. (a -> b) -> a -> b
$ Text
"project_" forall a. Semigroup a => a -> a -> a
<> Name -> Text
opaqueName Name
desc forall a. Semigroup a => a -> a -> a
<> Text
"_" forall a. Semigroup a => a -> a -> a
<> Text
f'
        (Type
et_ty, [BlockItem]
project_items) <- forall {op} {s}.
EntryPointType
-> [(Int, ValueType)] -> CompilerM op s (Type, [BlockItem])
mkProject EntryPointType
et [(Int, ValueType)]
elems
        forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl
          (Name -> HeaderSection
OpaqueDecl Name
desc)
          [C.cedecl|int $id:project($ty:ctx_ty *ctx, $ty:et_ty *out, const $ty:opaque_type *obj);|]
        forall op s. Definition -> CompilerM op s ()
libDecl
          [C.cedecl|int $id:project($ty:ctx_ty *ctx, $ty:et_ty *out, const $ty:opaque_type *obj) {
                      (void)ctx;
                      $ty:et_ty v;
                      $items:project_items
                      *out = v;
                      return 0;
                    }|]
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> RecordField
Manifest.RecordField (Name -> Text
nameToText Name
f) (EntryPointType -> Text
entryTypeName EntryPointType
et) Text
project

  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {op} {s}.
((Name, EntryPointType), [(Int, ValueType)])
-> CompilerM op s RecordField
onField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [(Name, EntryPointType)]
fs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. OpaqueTypes -> [EntryPointType] -> [a] -> [[a]]
recordFieldPayloads OpaqueTypes
types (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, EntryPointType)]
fs) forall a b. (a -> b) -> a -> b
$
    forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [ValueType]
vds

opaqueNewFunctions ::
  OpaqueTypes ->
  Name ->
  [(Name, EntryPointType)] ->
  [ValueType] ->
  CompilerM op s Manifest.CFuncName
opaqueNewFunctions :: forall op s.
OpaqueTypes
-> Name
-> [(Name, EntryPointType)]
-> [ValueType]
-> CompilerM op s Text
opaqueNewFunctions OpaqueTypes
types Name
desc [(Name, EntryPointType)]
fs [ValueType]
vds = do
  Type
opaque_type <- forall op s. Name -> CompilerM op s Type
opaqueToCType Name
desc
  Type
ctx_ty <- forall op s. CompilerM op s Type
contextType
  Operations op s
ops <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall op s. CompilerEnv op s -> Operations op s
envOperations
  Text
new <- forall op s. Text -> CompilerM op s Text
publicName forall a b. (a -> b) -> a -> b
$ Text
"new_" forall a. Semigroup a => a -> a -> a
<> Name -> Text
opaqueName Name
desc

  ([Param]
params, [BlockItem]
new_stms) <-
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM forall {op} {s}.
Int
-> ((Name, EntryPointType), [ValueType])
-> CompilerM op s (Int, (Param, BlockItem))
onField Int
0
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [(Name, EntryPointType)]
fs
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. OpaqueTypes -> [EntryPointType] -> [a] -> [[a]]
recordFieldPayloads OpaqueTypes
types (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, EntryPointType)]
fs)
      forall a b. (a -> b) -> a -> b
$ [ValueType]
vds

  forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl
    (Name -> HeaderSection
OpaqueDecl Name
desc)
    [C.cedecl|int $id:new($ty:ctx_ty *ctx, $ty:opaque_type** out, $params:params);|]
  forall op s. Definition -> CompilerM op s ()
libDecl
    [C.cedecl|int $id:new($ty:ctx_ty *ctx, $ty:opaque_type** out, $params:params) {
                $ty:opaque_type* v = malloc(sizeof($ty:opaque_type));
                $items:(criticalSection ops new_stms)
                *out = v;
                return 0;
              }|]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
new
  where
    onField :: Int
-> ((Name, EntryPointType), [ValueType])
-> CompilerM op s (Int, (Param, BlockItem))
onField Int
offset ((Name
f, EntryPointType
et), [ValueType]
f_vts) = do
      let param_name :: Id
param_name =
            if (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isDigit (Name -> Text
nameToText Name
f)
              then forall a. ToIdent a => a -> SrcLoc -> Id
C.toIdent (Name
"v" forall a. Semigroup a => a -> a -> a
<> Name
f) forall a. Monoid a => a
mempty
              else forall a. ToIdent a => a -> SrcLoc -> Id
C.toIdent (Name
"f_" forall a. Semigroup a => a -> a -> a
<> Name
f) forall a. Monoid a => a
mempty
      case EntryPointType
et of
        TypeTransparent (ValueType Signedness
sign (Rank Int
0) PrimType
pt) -> do
          let ct :: Type
ct = Signedness -> PrimType -> Type
primAPIType Signedness
sign PrimType
pt
          forall (f :: * -> *) a. Applicative f => a -> f a
pure
            ( Int
offset forall a. Num a => a -> a -> a
+ Int
1,
              ( [C.cparam|const $ty:ct $id:param_name|],
                [C.citem|v->$id:(tupleField offset) = $id:param_name;|]
              )
            )
        TypeTransparent ValueType
vt -> do
          Type
ct <- forall op s. Publicness -> ValueType -> CompilerM op s Type
valueTypeToCType Publicness
Public ValueType
vt
          forall (f :: * -> *) a. Applicative f => a -> f a
pure
            ( Int
offset forall a. Num a => a -> a -> a
+ Int
1,
              ( [C.cparam|const $ty:ct* $id:param_name|],
                [C.citem|{v->$id:(tupleField offset) = malloc(sizeof($ty:ct));
                          *v->$id:(tupleField offset) = *$id:param_name;
                          (void)(*(v->$id:(tupleField offset)->mem.references))++;}|]
              )
            )
        TypeOpaque Name
f_desc -> do
          Type
ct <- forall op s. Name -> CompilerM op s Type
opaqueToCType Name
f_desc
          let param_fields :: [Exp]
param_fields = do
                Int
i <- [Int
0 ..]
                forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|$id:param_name->$id:(tupleField i)|]
          forall (f :: * -> *) a. Applicative f => a -> f a
pure
            ( Int
offset forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [ValueType]
f_vts,
              ( [C.cparam|const $ty:ct* $id:param_name|],
                [C.citem|{$stms:(zipWith3 setFieldField [offset ..] param_fields f_vts)}|]
              )
            )

    setFieldField :: Int -> a -> ValueType -> Stm
setFieldField Int
i a
e (ValueType Signedness
_ (Rank Int
r) PrimType
_)
      | Int
r forall a. Eq a => a -> a -> Bool
== Int
0 =
          [C.cstm|v->$id:(tupleField i) = $exp:e;|]
      | Bool
otherwise =
          [C.cstm|{v->$id:(tupleField i) = malloc(sizeof(*$exp:e));
                   *v->$id:(tupleField i) = *$exp:e;
                   (void)(*(v->$id:(tupleField i)->mem.references))++;}|]

processOpaqueRecord ::
  OpaqueTypes ->
  Name ->
  OpaqueType ->
  [ValueType] ->
  CompilerM op s (Maybe Manifest.RecordOps)
processOpaqueRecord :: forall op s.
OpaqueTypes
-> Name
-> OpaqueType
-> [ValueType]
-> CompilerM op s (Maybe RecordOps)
processOpaqueRecord OpaqueTypes
_ Name
_ (OpaqueType [ValueType]
_) [ValueType]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
processOpaqueRecord OpaqueTypes
types Name
desc (OpaqueRecord [(Name, EntryPointType)]
fs) [ValueType]
vds =
  forall a. a -> Maybe a
Just
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( [RecordField] -> Text -> RecordOps
Manifest.RecordOps
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall op s.
OpaqueTypes
-> Name
-> [(Name, EntryPointType)]
-> [ValueType]
-> CompilerM op s [RecordField]
opaqueProjectFunctions OpaqueTypes
types Name
desc [(Name, EntryPointType)]
fs [ValueType]
vds
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall op s.
OpaqueTypes
-> Name
-> [(Name, EntryPointType)]
-> [ValueType]
-> CompilerM op s Text
opaqueNewFunctions OpaqueTypes
types Name
desc [(Name, EntryPointType)]
fs [ValueType]
vds
        )

opaqueLibraryFunctions ::
  OpaqueTypes ->
  Name ->
  OpaqueType ->
  CompilerM op s (Manifest.OpaqueOps, Maybe Manifest.RecordOps)
opaqueLibraryFunctions :: forall op s.
OpaqueTypes
-> Name
-> OpaqueType
-> CompilerM op s (OpaqueOps, Maybe RecordOps)
opaqueLibraryFunctions OpaqueTypes
types Name
desc OpaqueType
ot = do
  Text
name <- forall op s. Text -> CompilerM op s Text
publicName forall a b. (a -> b) -> a -> b
$ Name -> Text
opaqueName Name
desc
  Text
free_opaque <- forall op s. Text -> CompilerM op s Text
publicName forall a b. (a -> b) -> a -> b
$ Text
"free_" forall a. Semigroup a => a -> a -> a
<> Name -> Text
opaqueName Name
desc
  Text
store_opaque <- forall op s. Text -> CompilerM op s Text
publicName forall a b. (a -> b) -> a -> b
$ Text
"store_" forall a. Semigroup a => a -> a -> a
<> Name -> Text
opaqueName Name
desc
  Text
restore_opaque <- forall op s. Text -> CompilerM op s Text
publicName forall a b. (a -> b) -> a -> b
$ Text
"restore_" forall a. Semigroup a => a -> a -> a
<> Name -> Text
opaqueName Name
desc

  let opaque_type :: Type
opaque_type = [C.cty|struct $id:name|]

      freeComponent :: Int -> ValueType -> CompilerM op s ()
freeComponent Int
i (ValueType Signedness
signed (Rank Int
rank) PrimType
pt) = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
rank forall a. Eq a => a -> a -> Bool
== Int
0) forall a b. (a -> b) -> a -> b
$ do
        let field :: [Char]
field = Int -> [Char]
tupleField Int
i
        Text
free_array <- forall op s. Text -> CompilerM op s Text
publicName forall a b. (a -> b) -> a -> b
$ Text
"free_" forall a. Semigroup a => a -> a -> a
<> PrimType -> Signedness -> Int -> Text
arrayName PrimType
pt Signedness
signed Int
rank
        -- Protect against NULL here, because we also want to use this
        -- to free partially loaded opaques.
        forall op s. Stm -> CompilerM op s ()
stm
          [C.cstm|if (obj->$id:field != NULL && (tmp = $id:free_array(ctx, obj->$id:field)) != 0) {
                ret = tmp;
             }|]

      storeComponent :: Int -> ValueType -> (Exp, [Stm])
storeComponent Int
i (ValueType Signedness
sign (Rank Int
0) PrimType
pt) =
        let field :: [Char]
field = Int -> [Char]
tupleField Int
i
         in ( PrimType -> Int -> Exp -> Exp
storageSize PrimType
pt Int
0 [C.cexp|NULL|],
              Signedness -> PrimType -> Int -> Exp -> Exp -> [Stm]
storeValueHeader Signedness
sign PrimType
pt Int
0 [C.cexp|NULL|] [C.cexp|out|]
                forall a. [a] -> [a] -> [a]
++ [C.cstms|memcpy(out, &obj->$id:field, sizeof(obj->$id:field));
                            out += sizeof(obj->$id:field);|]
            )
      storeComponent Int
i (ValueType Signedness
sign (Rank Int
rank) PrimType
pt) =
        let arr_name :: Text
arr_name = PrimType -> Signedness -> Int -> Text
arrayName PrimType
pt Signedness
sign Int
rank
            field :: [Char]
field = Int -> [Char]
tupleField Int
i
            shape_array :: Text
shape_array = Text
"futhark_shape_" forall a. Semigroup a => a -> a -> a
<> Text
arr_name
            values_array :: Text
values_array = Text
"futhark_values_" forall a. Semigroup a => a -> a -> a
<> Text
arr_name
            shape' :: Exp
shape' = [C.cexp|$id:shape_array(ctx, obj->$id:field)|]
            num_elems :: Exp
num_elems = [Exp] -> Exp
cproduct [[C.cexp|$exp:shape'[$int:j]|] | Int
j <- [Int
0 .. Int
rank forall a. Num a => a -> a -> a
- Int
1]]
         in ( PrimType -> Int -> Exp -> Exp
storageSize PrimType
pt Int
rank Exp
shape',
              Signedness -> PrimType -> Int -> Exp -> Exp -> [Stm]
storeValueHeader Signedness
sign PrimType
pt Int
rank Exp
shape' [C.cexp|out|]
                forall a. [a] -> [a] -> [a]
++ [C.cstms|ret |= $id:values_array(ctx, obj->$id:field, (void*)out);
                            out += $exp:num_elems * sizeof($ty:(primStorageType pt));|]
            )

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

  let vds :: [ValueType]
vds = OpaqueTypes -> OpaqueType -> [ValueType]
opaquePayload OpaqueTypes
types OpaqueType
ot
  [BlockItem]
free_body <- forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ forall {op} {s}. Int -> ValueType -> CompilerM op s ()
freeComponent [Int
0 ..] [ValueType]
vds

  [BlockItem]
store_body <- forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect forall a b. (a -> b) -> a -> b
$ do
    let ([Exp]
sizes, [[Stm]]
stores) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> ValueType -> (Exp, [Stm])
storeComponent [Int
0 ..] [ValueType]
vds
        size_vars :: [[Char]]
size_vars = forall a b. (a -> b) -> [a] -> [b]
map (([Char]
"size_" ++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) [Int
0 .. forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp]
sizes forall a. Num a => a -> a -> a
- Int
1]
        size_sum :: Exp
size_sum = [Exp] -> Exp
csum [[C.cexp|$id:size|] | [Char]
size <- [[Char]]
size_vars]
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [[Char]]
size_vars [Exp]
sizes) forall a b. (a -> b) -> a -> b
$ \([Char]
v, Exp
e) ->
      forall op s. BlockItem -> CompilerM op s ()
item [C.citem|typename int64_t $id:v = $exp:e;|]
    forall op s. Stm -> CompilerM op s ()
stm [C.cstm|*n = $exp:size_sum;|]
    forall op s. Stm -> CompilerM op s ()
stm [C.cstm|if (p != NULL && *p == NULL) { *p = malloc(*n); }|]
    forall op s. Stm -> CompilerM op s ()
stm [C.cstm|if (p != NULL) { unsigned char *out = *p; $stms:(concat stores) }|]

  let restoreComponent :: Int -> ValueType -> CompilerM op s [Stm]
restoreComponent Int
i (ValueType Signedness
sign (Rank Int
0) PrimType
pt) = do
        let field :: [Char]
field = Int -> [Char]
tupleField Int
i
            dataptr :: [Char]
dataptr = [Char]
"data_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
i
        forall op s. [Stm] -> CompilerM op s ()
stms forall a b. (a -> b) -> a -> b
$ Signedness -> PrimType -> Int -> Exp -> Exp -> [Stm]
loadValueHeader Signedness
sign PrimType
pt Int
0 [C.cexp|NULL|] [C.cexp|src|]
        forall op s. BlockItem -> CompilerM op s ()
item [C.citem|const void* $id:dataptr = src;|]
        forall op s. Stm -> CompilerM op s ()
stm [C.cstm|src += sizeof(obj->$id:field);|]
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cstms|memcpy(&obj->$id:field, $id:dataptr, sizeof(obj->$id:field));|]
      restoreComponent Int
i (ValueType Signedness
sign (Rank Int
rank) PrimType
pt) = do
        let field :: [Char]
field = Int -> [Char]
tupleField Int
i
            arr_name :: Text
arr_name = PrimType -> Signedness -> Int -> Text
arrayName PrimType
pt Signedness
sign Int
rank
            new_array :: Text
new_array = Text
"futhark_new_" forall a. Semigroup a => a -> a -> a
<> Text
arr_name
            dataptr :: Text
dataptr = Text
"data_" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
prettyText Int
i
            shapearr :: Text
shapearr = Text
"shape_" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
prettyText Int
i
            dims :: [Exp]
dims = [[C.cexp|$id:shapearr[$int:j]|] | Int
j <- [Int
0 .. Int
rank forall a. Num a => a -> a -> a
- Int
1]]
            num_elems :: Exp
num_elems = [Exp] -> Exp
cproduct [Exp]
dims
        forall op s. BlockItem -> CompilerM op s ()
item [C.citem|typename int64_t $id:shapearr[$int:rank] = {0};|]
        forall op s. [Stm] -> CompilerM op s ()
stms forall a b. (a -> b) -> a -> b
$ Signedness -> PrimType -> Int -> Exp -> Exp -> [Stm]
loadValueHeader Signedness
sign PrimType
pt Int
rank [C.cexp|$id:shapearr|] [C.cexp|src|]
        forall op s. BlockItem -> CompilerM op s ()
item [C.citem|const void* $id:dataptr = src;|]
        forall op s. Stm -> CompilerM op s ()
stm [C.cstm|obj->$id:field = NULL;|]
        forall op s. Stm -> CompilerM op s ()
stm [C.cstm|src += $exp:num_elems * sizeof($ty:(primStorageType pt));|]
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
          [C.cstms|
             obj->$id:field = $id:new_array(ctx, $id:dataptr, $args:dims);
             if (obj->$id:field == NULL) { err = 1; }|]

  [BlockItem]
load_body <- forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect forall a b. (a -> b) -> a -> b
$ do
    [Stm]
loads <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM forall {op} {s}. Int -> ValueType -> CompilerM op s [Stm]
restoreComponent [Int
0 ..] (OpaqueTypes -> OpaqueType -> [ValueType]
opaquePayload OpaqueTypes
types OpaqueType
ot)
    forall op s. Stm -> CompilerM op s ()
stm
      [C.cstm|if (err == 0) {
                $stms:loads
              }|]

  forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl
    (Name -> HeaderSection
OpaqueTypeDecl Name
desc)
    [C.cedecl|struct $id:name;|]
  forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl
    (Name -> HeaderSection
OpaqueDecl Name
desc)
    [C.cedecl|int $id:free_opaque($ty:ctx_ty *ctx, $ty:opaque_type *obj);|]
  forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl
    (Name -> HeaderSection
OpaqueDecl Name
desc)
    [C.cedecl|int $id:store_opaque($ty:ctx_ty *ctx, const $ty:opaque_type *obj, void **p, size_t *n);|]
  forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl
    (Name -> HeaderSection
OpaqueDecl Name
desc)
    [C.cedecl|$ty:opaque_type* $id:restore_opaque($ty:ctx_ty *ctx, const void *p);|]

  Maybe RecordOps
record <- forall op s.
OpaqueTypes
-> Name
-> OpaqueType
-> [ValueType]
-> CompilerM op s (Maybe RecordOps)
processOpaqueRecord OpaqueTypes
types Name
desc OpaqueType
ot [ValueType]
vds

  -- We do not need to enclose most bodies in a critical section,
  -- because when we operate on the components of the opaque, we are
  -- calling public API functions that do their own locking.  The
  -- exception is projection, where we fiddle with reference counts.
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
    forall op s. Definition -> CompilerM op s ()
libDecl
    [C.cunit|
          int $id:free_opaque($ty:ctx_ty *ctx, $ty:opaque_type *obj) {
            (void)ctx;
            int ret = 0, tmp;
            $items:free_body
            free(obj);
            return ret;
          }

          int $id:store_opaque($ty:ctx_ty *ctx,
                               const $ty:opaque_type *obj, void **p, size_t *n) {
            (void)ctx;
            int ret = 0;
            $items:store_body
            return ret;
          }

          $ty:opaque_type* $id:restore_opaque($ty:ctx_ty *ctx,
                                              const void *p) {
            int err = 0;
            const unsigned char *src = p;
            $ty:opaque_type* obj = malloc(sizeof($ty:opaque_type));
            $items:load_body
            if (err != 0) {
              int ret = 0, tmp;
              $items:free_body
              free(obj);
              obj = NULL;
            }
            return obj;
          }
    |]

  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( Manifest.OpaqueOps
        { opaqueFree :: Text
Manifest.opaqueFree = Text
free_opaque,
          opaqueStore :: Text
Manifest.opaqueStore = Text
store_opaque,
          opaqueRestore :: Text
Manifest.opaqueRestore = Text
restore_opaque
        },
      Maybe RecordOps
record
    )

generateArray ::
  Space ->
  ((Signedness, PrimType, Int), Publicness) ->
  CompilerM op s (Maybe (T.Text, Manifest.Type))
generateArray :: forall op s.
Space
-> ((Signedness, PrimType, Int), Publicness)
-> CompilerM op s (Maybe (Text, Type))
generateArray Space
space ((Signedness
signed, PrimType
pt, Int
rank), Publicness
pub) = do
  Text
name <- forall op s. Text -> CompilerM op s Text
publicName forall a b. (a -> b) -> a -> b
$ PrimType -> Signedness -> Int -> Text
arrayName PrimType
pt Signedness
signed Int
rank
  let memty :: Type
memty = Space -> Type
fatMemType Space
space
  forall op s. Definition -> CompilerM op s ()
libDecl [C.cedecl|struct $id:name { $ty:memty mem; typename int64_t shape[$int:rank]; };|]
  ArrayOps
ops <- forall op s.
Publicness
-> Space
-> PrimType
-> Signedness
-> Int
-> CompilerM op s ArrayOps
arrayLibraryFunctions Publicness
pub Space
space PrimType
pt Signedness
signed Int
rank
  let pt_name :: Text
pt_name = Bool -> PrimType -> Text
prettySigned (Signedness
signed forall a. Eq a => a -> a -> Bool
== Signedness
Unsigned) PrimType
pt
      pretty_name :: Text
pretty_name = forall a. Monoid a => [a] -> a
mconcat (forall a. Int -> a -> [a]
replicate Int
rank Text
"[]") forall a. Semigroup a => a -> a -> a
<> Text
pt_name
      arr_type :: Type
arr_type = [C.cty|struct $id:name*|]
  case Publicness
pub of
    Publicness
Public ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall a. a -> Maybe a
Just
          ( Text
pretty_name,
            Text -> Text -> Int -> ArrayOps -> Type
Manifest.TypeArray (Type -> Text
typeText Type
arr_type) Text
pt_name Int
rank ArrayOps
ops
          )
    Publicness
Private ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

generateOpaque ::
  OpaqueTypes ->
  (Name, OpaqueType) ->
  CompilerM op s (T.Text, Manifest.Type)
generateOpaque :: forall op s.
OpaqueTypes -> (Name, OpaqueType) -> CompilerM op s (Text, Type)
generateOpaque OpaqueTypes
types (Name
desc, OpaqueType
ot) = do
  Text
name <- forall op s. Text -> CompilerM op s Text
publicName forall a b. (a -> b) -> a -> b
$ Name -> Text
opaqueName Name
desc
  [FieldGroup]
members <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM forall {op} {s}. ValueType -> Int -> CompilerM op s FieldGroup
field (OpaqueTypes -> OpaqueType -> [ValueType]
opaquePayload OpaqueTypes
types OpaqueType
ot) [(Int
0 :: Int) ..]
  forall op s. Definition -> CompilerM op s ()
libDecl [C.cedecl|struct $id:name { $sdecls:members };|]
  (OpaqueOps
ops, Maybe RecordOps
record) <- forall op s.
OpaqueTypes
-> Name
-> OpaqueType
-> CompilerM op s (OpaqueOps, Maybe RecordOps)
opaqueLibraryFunctions OpaqueTypes
types Name
desc OpaqueType
ot
  let opaque_type :: Type
opaque_type = [C.cty|struct $id:name*|]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Text
nameToText Name
desc, Text -> OpaqueOps -> Maybe RecordOps -> Type
Manifest.TypeOpaque (Type -> Text
typeText Type
opaque_type) OpaqueOps
ops Maybe RecordOps
record)
  where
    field :: ValueType -> Int -> CompilerM op s FieldGroup
field vt :: ValueType
vt@(ValueType Signedness
_ (Rank Int
r) PrimType
_) Int
i = do
      Type
ct <- forall op s. Publicness -> ValueType -> CompilerM op s Type
valueTypeToCType Publicness
Private ValueType
vt
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        if Int
r forall a. Eq a => a -> a -> Bool
== Int
0
          then [C.csdecl|$ty:ct $id:(tupleField i);|]
          else [C.csdecl|$ty:ct *$id:(tupleField i);|]

generateAPITypes :: Space -> OpaqueTypes -> CompilerM op s (M.Map T.Text Manifest.Type)
generateAPITypes :: forall op s. Space -> OpaqueTypes -> CompilerM op s (Map Text Type)
generateAPITypes Space
arr_space types :: OpaqueTypes
types@(OpaqueTypes [(Name, OpaqueType)]
opaques) = do
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall {op} {s}. OpaqueType -> CompilerM op s ()
findNecessaryArrays forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Name, OpaqueType)]
opaques
  [Maybe (Text, Type)]
array_ts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall op s.
Space
-> ((Signedness, PrimType, Int), Publicness)
-> CompilerM op s (Maybe (Text, Type))
generateArray Space
arr_space) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toList forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall s.
CompilerState s -> Map (Signedness, PrimType, Int) Publicness
compArrayTypes
  [(Text, Type)]
opaque_ts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall op s.
OpaqueTypes -> (Name, OpaqueType) -> CompilerM op s (Text, Type)
generateOpaque OpaqueTypes
types) [(Name, OpaqueType)]
opaques
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe (Text, Type)]
array_ts forall a. Semigroup a => a -> a -> a
<> [(Text, Type)]
opaque_ts
  where
    -- Ensure that array types will be generated before the opaque
    -- records that allow projection of them.  This is because the
    -- projection functions somewhat uglily directly poke around in
    -- the innards to increment reference counts.
    findNecessaryArrays :: OpaqueType -> CompilerM op s ()
findNecessaryArrays (OpaqueType [ValueType]
_) =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    findNecessaryArrays (OpaqueRecord [(Name, EntryPointType)]
fs) =
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall op s. Publicness -> EntryPointType -> CompilerM op s Type
entryPointTypeToCType Publicness
Public forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Name, EntryPointType)]
fs