{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TupleSections #-}
module Futhark.CodeGen.Backends.GenericC.Types
( generateAPITypes,
valueTypeToCType,
opaqueToCType,
)
where
import Control.Monad.Reader
import Control.Monad.State
import Data.Char (isDigit)
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Data.Text as T
import Futhark.CodeGen.Backends.GenericC.Monad
import Futhark.CodeGen.ImpCode
import qualified Futhark.Manifest as Manifest
import Futhark.Util (chunks, mapAccumLM)
import Futhark.Util.Pretty (prettyText)
import qualified Language.C.Quote.OpenCL as C
import qualified Language.C.Syntax as C
opaqueToCType :: String -> CompilerM op s C.Type
opaqueToCType :: forall op s. String -> CompilerM op s Type
opaqueToCType String
desc = do
String
name <- String -> CompilerM op s String
forall op s. String -> CompilerM op s String
publicName (String -> CompilerM op s String)
-> String -> CompilerM op s String
forall a b. (a -> b) -> a -> b
$ String -> String
opaqueName String
desc
Type -> CompilerM op s Type
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) =
Type -> CompilerM op s Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> CompilerM op s Type) -> Type -> CompilerM op s Type
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
String
name <- String -> CompilerM op s String
forall op s. String -> CompilerM op s String
publicName (String -> CompilerM op s String)
-> String -> CompilerM op s String
forall a b. (a -> b) -> a -> b
$ PrimType -> Signedness -> Int -> String
arrayName PrimType
pt Signedness
signed Int
rank
let add :: Map (Signedness, PrimType, Int) Publicness
-> Map (Signedness, PrimType, Int) Publicness
add = (Publicness -> Publicness -> Publicness)
-> (Signedness, PrimType, Int)
-> Publicness
-> Map (Signedness, PrimType, Int) Publicness
-> Map (Signedness, PrimType, Int) Publicness
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Publicness -> Publicness -> Publicness
forall a. Ord a => a -> a -> a
max (Signedness
signed, PrimType
pt, Int
rank) Publicness
pub
(CompilerState s -> CompilerState s) -> CompilerM op s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompilerState s -> CompilerState s) -> CompilerM op s ())
-> (CompilerState s -> CompilerState s) -> CompilerM op s ()
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 (Map (Signedness, PrimType, Int) Publicness
-> Map (Signedness, PrimType, Int) Publicness)
-> Map (Signedness, PrimType, Int) Publicness
-> Map (Signedness, PrimType, Int) Publicness
forall a b. (a -> b) -> a -> b
$ CompilerState s -> Map (Signedness, PrimType, Int) Publicness
forall s.
CompilerState s -> Map (Signedness, PrimType, Int) Publicness
compArrayTypes CompilerState s
s}
Type -> CompilerM op s Type
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 :: String
name = PrimType -> Signedness -> Int -> String
arrayName PrimType
pt Signedness
signed Int
rank
arr_name :: String
arr_name = String
"futhark_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
array_type :: Type
array_type = [C.cty|struct $id:arr_name|]
String
new_array <- String -> CompilerM op s String
forall op s. String -> CompilerM op s String
publicName (String -> CompilerM op s String)
-> String -> CompilerM op s String
forall a b. (a -> b) -> a -> b
$ String
"new_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
String
new_raw_array <- String -> CompilerM op s String
forall op s. String -> CompilerM op s String
publicName (String -> CompilerM op s String)
-> String -> CompilerM op s String
forall a b. (a -> b) -> a -> b
$ String
"new_raw_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
String
free_array <- String -> CompilerM op s String
forall op s. String -> CompilerM op s String
publicName (String -> CompilerM op s String)
-> String -> CompilerM op s String
forall a b. (a -> b) -> a -> b
$ String
"free_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
String
values_array <- String -> CompilerM op s String
forall op s. String -> CompilerM op s String
publicName (String -> CompilerM op s String)
-> String -> CompilerM op s String
forall a b. (a -> b) -> a -> b
$ String
"values_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
String
values_raw_array <- String -> CompilerM op s String
forall op s. String -> CompilerM op s String
publicName (String -> CompilerM op s String)
-> String -> CompilerM op s String
forall a b. (a -> b) -> a -> b
$ String
"values_raw_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
String
shape_array <- String -> CompilerM op s String
forall op s. String -> CompilerM op s String
publicName (String -> CompilerM op s String)
-> String -> CompilerM op s String
forall a b. (a -> b) -> a -> b
$ String
"shape_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
let shape_names :: [String]
shape_names = [String
"dim" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i | Int
i <- [Int
0 .. Int
rank Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
shape_params :: [Param]
shape_params = [[C.cparam|typename int64_t $id:k|] | String
k <- [String]
shape_names]
arr_size :: Exp
arr_size = [Exp] -> Exp
cproduct [[C.cexp|$id:k|] | String
k <- [String]
shape_names]
arr_size_array :: Exp
arr_size_array = [Exp] -> Exp
cproduct [[C.cexp|arr->shape[$int:i]|] | Int
i <- [Int
0 .. Int
rank Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
Copy op s
copy <- (CompilerEnv op s -> Copy op s) -> CompilerM op s (Copy op s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((CompilerEnv op s -> Copy op s) -> CompilerM op s (Copy op s))
-> (CompilerEnv op s -> Copy op s) -> CompilerM op s (Copy op s)
forall a b. (a -> b) -> a -> b
$ Operations op s -> Copy op s
forall op s. Operations op s -> Copy op s
opsCopy (Operations op s -> Copy op s)
-> (CompilerEnv op s -> Operations op s)
-> CompilerEnv op s
-> Copy op s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerEnv op s -> Operations op s
forall op s. CompilerEnv op s -> Operations op s
envOperations
Type
memty <- Space -> CompilerM op s Type
forall op s. Space -> CompilerM op s Type
rawMemCType Space
space
let prepare_new :: CompilerM op s ()
prepare_new = do
Exp -> Space -> CompilerM op s ()
forall a op s. ToExp a => a -> Space -> CompilerM op s ()
resetMem [C.cexp|arr->mem|] Space
space
Exp -> Exp -> Space -> Stm -> CompilerM op s ()
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;|]
[Int] -> (Int -> CompilerM op s ()) -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
rank Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> CompilerM op s ()) -> CompilerM op s ())
-> (Int -> CompilerM op s ()) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \Int
i ->
let dim_s :: String
dim_s = String
"dim" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
in Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
stm [C.cstm|arr->shape[$int:i] = $id:dim_s;|]
[BlockItem]
new_body <- CompilerM op s () -> CompilerM op s [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect (CompilerM op s () -> CompilerM op s [BlockItem])
-> CompilerM op s () -> CompilerM op s [BlockItem]
forall a b. (a -> b) -> a -> b
$ do
CompilerM op s ()
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|0|]
Space
DefaultSpace
[C.cexp|((size_t)$exp:arr_size) * $int:(primByteSize pt::Int)|]
[BlockItem]
new_raw_body <- CompilerM op s () -> CompilerM op s [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect (CompilerM op s () -> CompilerM op s [BlockItem])
-> CompilerM op s () -> CompilerM op s [BlockItem]
forall a b. (a -> b) -> a -> b
$ do
CompilerM op s ()
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 <- CompilerM op s () -> CompilerM op s [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect (CompilerM op s () -> CompilerM op s [BlockItem])
-> CompilerM op s () -> CompilerM op s [BlockItem]
forall a b. (a -> b) -> a -> b
$ Exp -> Space -> CompilerM op s ()
forall a op s. ToExp a => a -> Space -> CompilerM op s ()
unRefMem [C.cexp|arr->mem|] Space
space
[BlockItem]
values_body <-
CompilerM op s () -> CompilerM op s [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect (CompilerM op s () -> CompilerM op s [BlockItem])
-> CompilerM op s () -> CompilerM op s [BlockItem]
forall a b. (a -> b) -> a -> b
$
Copy op s
copy
CopyBarrier
CopyNoBarrier
[C.cexp|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 <- CompilerM op s Type
forall op s. CompilerM op s Type
contextType
Operations op s
ops <- (CompilerEnv op s -> Operations op s)
-> CompilerM op s (Operations op s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompilerEnv op s -> Operations op s
forall op s. CompilerEnv op s -> Operations op s
envOperations
let proto :: Definition -> CompilerM op s ()
proto = case Publicness
pub of
Publicness
Public -> HeaderSection -> Definition -> CompilerM op s ()
forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl (String -> HeaderSection
ArrayDecl String
name)
Publicness
Private -> Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
libDecl
Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
proto
[C.cedecl|struct $id:arr_name;|]
Definition -> CompilerM op s ()
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);|]
Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
proto
[C.cedecl|$ty:array_type* $id:new_raw_array($ty:ctx_ty *ctx, const $ty:memty data, typename int64_t offset, $params:shape_params);|]
Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
proto
[C.cedecl|int $id:free_array($ty:ctx_ty *ctx, $ty:array_type *arr);|]
Definition -> CompilerM op s ()
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);|]
Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
proto
[C.cedecl|$ty:memty $id:values_raw_array($ty:ctx_ty *ctx, $ty:array_type *arr);|]
Definition -> CompilerM op s ()
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);|]
(Definition -> CompilerM op s ())
-> [Definition] -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
libDecl
[C.cunit|
$ty:array_type* $id:new_array($ty:ctx_ty *ctx, const $ty:pt' *data, $params:shape_params) {
$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)
return arr;
}
$ty:array_type* $id:new_raw_array($ty:ctx_ty *ctx, const $ty:memty data, typename int64_t offset,
$params:shape_params) {
$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) {
$items:(criticalSection ops values_body)
return 0;
}
$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;
}
|]
ArrayOps -> CompilerM op s ArrayOps
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ArrayOps -> CompilerM op s ArrayOps)
-> ArrayOps -> CompilerM op s ArrayOps
forall a b. (a -> b) -> a -> b
$
ArrayOps :: CFuncName -> CFuncName -> CFuncName -> CFuncName -> ArrayOps
Manifest.ArrayOps
{ arrayFree :: CFuncName
Manifest.arrayFree = String -> CFuncName
T.pack String
free_array,
arrayShape :: CFuncName
Manifest.arrayShape = String -> CFuncName
T.pack String
shape_array,
arrayValues :: CFuncName
Manifest.arrayValues = String -> CFuncName
T.pack String
values_array,
arrayNew :: CFuncName
Manifest.arrayNew = String -> CFuncName
T.pack String
new_array
}
lookupOpaqueType :: String -> OpaqueTypes -> OpaqueType
lookupOpaqueType :: String -> OpaqueTypes -> OpaqueType
lookupOpaqueType String
v (OpaqueTypes [(String, OpaqueType)]
types) =
case String -> [(String, OpaqueType)] -> Maybe OpaqueType
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
v [(String, OpaqueType)]
types of
Just OpaqueType
t -> OpaqueType
t
Maybe OpaqueType
Nothing -> String -> OpaqueType
forall a. HasCallStack => String -> a
error (String -> OpaqueType) -> String -> OpaqueType
forall a b. (a -> b) -> a -> b
$ String
"Unknown opaque type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
v
opaquePayload :: OpaqueTypes -> OpaqueType -> [ValueType]
opaquePayload :: OpaqueTypes -> OpaqueType -> [ValueType]
opaquePayload OpaqueTypes
_ (OpaqueType [ValueType]
ts) = [ValueType]
ts
opaquePayload OpaqueTypes
types (OpaqueRecord [(Name, EntryPointType)]
fs) = ((Name, EntryPointType) -> [ValueType])
-> [(Name, EntryPointType)] -> [ValueType]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name, EntryPointType) -> [ValueType]
forall {a}. (a, EntryPointType) -> [ValueType]
f [(Name, EntryPointType)]
fs
where
f :: (a, EntryPointType) -> [ValueType]
f (a
_, TypeOpaque String
s) = OpaqueTypes -> OpaqueType -> [ValueType]
opaquePayload OpaqueTypes
types (OpaqueType -> [ValueType]) -> OpaqueType -> [ValueType]
forall a b. (a -> b) -> a -> b
$ String -> OpaqueTypes -> OpaqueType
lookupOpaqueType String
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 String
desc) = String -> CompilerM op s Type
forall op s. String -> CompilerM op s Type
opaqueToCType String
desc
entryPointTypeToCType Publicness
pub (TypeTransparent ValueType
vt) = Publicness -> ValueType -> CompilerM op s Type
forall op s. Publicness -> ValueType -> CompilerM op s Type
valueTypeToCType Publicness
pub ValueType
vt
entryTypeName :: EntryPointType -> Manifest.TypeName
entryTypeName :: EntryPointType -> CFuncName
entryTypeName (TypeOpaque String
desc) = String -> CFuncName
T.pack String
desc
entryTypeName (TypeTransparent ValueType
vt) = ValueType -> CFuncName
forall a. Pretty a => a -> CFuncName
prettyText ValueType
vt
recordFieldPayloads :: OpaqueTypes -> [EntryPointType] -> [a] -> [[a]]
recordFieldPayloads :: forall a. OpaqueTypes -> [EntryPointType] -> [a] -> [[a]]
recordFieldPayloads OpaqueTypes
types = [Int] -> [a] -> [[a]]
forall a. [Int] -> [a] -> [[a]]
chunks ([Int] -> [a] -> [[a]])
-> ([EntryPointType] -> [Int]) -> [EntryPointType] -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EntryPointType -> Int) -> [EntryPointType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map EntryPointType -> Int
typeLength
where
typeLength :: EntryPointType -> Int
typeLength (TypeTransparent ValueType
_) = Int
1
typeLength (TypeOpaque String
desc) =
[ValueType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([ValueType] -> Int) -> [ValueType] -> Int
forall a b. (a -> b) -> a -> b
$ OpaqueTypes -> OpaqueType -> [ValueType]
opaquePayload OpaqueTypes
types (OpaqueType -> [ValueType]) -> OpaqueType -> [ValueType]
forall a b. (a -> b) -> a -> b
$ String -> OpaqueTypes -> OpaqueType
lookupOpaqueType String
desc OpaqueTypes
types
opaqueProjectFunctions ::
OpaqueTypes ->
String ->
[(Name, EntryPointType)] ->
[ValueType] ->
CompilerM op s [Manifest.RecordField]
opaqueProjectFunctions :: forall op s.
OpaqueTypes
-> String
-> [(Name, EntryPointType)]
-> [ValueType]
-> CompilerM op s [RecordField]
opaqueProjectFunctions OpaqueTypes
types String
desc [(Name, EntryPointType)]
fs [ValueType]
vds = do
Type
opaque_type <- String -> CompilerM op s Type
forall op s. String -> CompilerM op s Type
opaqueToCType String
desc
Type
ctx_ty <- CompilerM op s Type
forall op s. CompilerM op s Type
contextType
Operations op s
ops <- (CompilerEnv op s -> Operations op s)
-> CompilerM op s (Operations op s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompilerEnv op s -> Operations op s
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
(Type, [BlockItem]) -> CompilerM op s (Type, [BlockItem])
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 <- Publicness -> ValueType -> CompilerM op s Type
forall op s. Publicness -> ValueType -> CompilerM op s Type
valueTypeToCType Publicness
Public ValueType
vt
(Type, [BlockItem]) -> CompilerM op s (Type, [BlockItem])
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( [C.cty|$ty:ct *|],
Operations op s -> [BlockItem] -> [BlockItem]
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 =
String -> CompilerM op s (Type, [BlockItem])
forall a. HasCallStack => String -> a
error (String -> CompilerM op s (Type, [BlockItem]))
-> String -> CompilerM op s (Type, [BlockItem])
forall a b. (a -> b) -> a -> b
$ String
"mkProject: invalid representation of transparent type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(Int, ValueType)] -> String
forall a. Show a => a -> String
show [(Int, ValueType)]
rep
mkProject (TypeOpaque String
f_desc) [(Int, ValueType)]
components = do
Type
ct <- String -> CompilerM op s Type
forall op s. String -> CompilerM op s Type
opaqueToCType String
f_desc
let setField :: Int -> (Int, ValueType) -> [BlockItem]
setField Int
j (Int
i, ValueType Signedness
_ (Rank Int
r) PrimType
_) =
if Int
r Int -> Int -> Bool
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))++;|]
(Type, [BlockItem]) -> CompilerM op s (Type, [BlockItem])
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( [C.cty|$ty:ct *|],
Operations op s -> [BlockItem] -> [BlockItem]
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
String
project <- String -> CompilerM op s String
forall op s. String -> CompilerM op s String
publicName (String -> CompilerM op s String)
-> String -> CompilerM op s String
forall a b. (a -> b) -> a -> b
$ String
"project_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
opaqueName String
desc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameToString Name
f
(Type
et_ty, [BlockItem]
project_items) <- EntryPointType
-> [(Int, ValueType)] -> CompilerM op s (Type, [BlockItem])
forall {op} {s}.
EntryPointType
-> [(Int, ValueType)] -> CompilerM op s (Type, [BlockItem])
mkProject EntryPointType
et [(Int, ValueType)]
elems
HeaderSection -> Definition -> CompilerM op s ()
forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl
(String -> HeaderSection
OpaqueDecl String
desc)
[C.cedecl|int $id:project($ty:ctx_ty *ctx, $ty:et_ty *out, const $ty:opaque_type *obj);|]
Definition -> CompilerM op s ()
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;
}|]
RecordField -> CompilerM op s RecordField
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RecordField -> CompilerM op s RecordField)
-> RecordField -> CompilerM op s RecordField
forall a b. (a -> b) -> a -> b
$ CFuncName -> CFuncName -> CFuncName -> RecordField
Manifest.RecordField (Name -> CFuncName
nameToText Name
f) (EntryPointType -> CFuncName
entryTypeName EntryPointType
et) (String -> CFuncName
T.pack String
project)
(((Name, EntryPointType), [(Int, ValueType)])
-> CompilerM op s RecordField)
-> [((Name, EntryPointType), [(Int, ValueType)])]
-> CompilerM op s [RecordField]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Name, EntryPointType), [(Int, ValueType)])
-> CompilerM op s RecordField
forall {op} {s}.
((Name, EntryPointType), [(Int, ValueType)])
-> CompilerM op s RecordField
onField ([((Name, EntryPointType), [(Int, ValueType)])]
-> CompilerM op s [RecordField])
-> ([(Int, ValueType)]
-> [((Name, EntryPointType), [(Int, ValueType)])])
-> [(Int, ValueType)]
-> CompilerM op s [RecordField]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Name, EntryPointType)]
-> [[(Int, ValueType)]]
-> [((Name, EntryPointType), [(Int, ValueType)])]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Name, EntryPointType)]
fs ([[(Int, ValueType)]]
-> [((Name, EntryPointType), [(Int, ValueType)])])
-> ([(Int, ValueType)] -> [[(Int, ValueType)]])
-> [(Int, ValueType)]
-> [((Name, EntryPointType), [(Int, ValueType)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OpaqueTypes
-> [EntryPointType] -> [(Int, ValueType)] -> [[(Int, ValueType)]]
forall a. OpaqueTypes -> [EntryPointType] -> [a] -> [[a]]
recordFieldPayloads OpaqueTypes
types (((Name, EntryPointType) -> EntryPointType)
-> [(Name, EntryPointType)] -> [EntryPointType]
forall a b. (a -> b) -> [a] -> [b]
map (Name, EntryPointType) -> EntryPointType
forall a b. (a, b) -> b
snd [(Name, EntryPointType)]
fs) ([(Int, ValueType)] -> CompilerM op s [RecordField])
-> [(Int, ValueType)] -> CompilerM op s [RecordField]
forall a b. (a -> b) -> a -> b
$
[Int] -> [ValueType] -> [(Int, ValueType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [ValueType]
vds
opaqueNewFunctions ::
OpaqueTypes ->
String ->
[(Name, EntryPointType)] ->
[ValueType] ->
CompilerM op s Manifest.CFuncName
opaqueNewFunctions :: forall op s.
OpaqueTypes
-> String
-> [(Name, EntryPointType)]
-> [ValueType]
-> CompilerM op s CFuncName
opaqueNewFunctions OpaqueTypes
types String
desc [(Name, EntryPointType)]
fs [ValueType]
vds = do
Type
opaque_type <- String -> CompilerM op s Type
forall op s. String -> CompilerM op s Type
opaqueToCType String
desc
Type
ctx_ty <- CompilerM op s Type
forall op s. CompilerM op s Type
contextType
Operations op s
ops <- (CompilerEnv op s -> Operations op s)
-> CompilerM op s (Operations op s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompilerEnv op s -> Operations op s
forall op s. CompilerEnv op s -> Operations op s
envOperations
String
new <- String -> CompilerM op s String
forall op s. String -> CompilerM op s String
publicName (String -> CompilerM op s String)
-> String -> CompilerM op s String
forall a b. (a -> b) -> a -> b
$ String
"new_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
opaqueName String
desc
([Param]
params, [BlockItem]
new_stms) <-
((Int, [(Param, BlockItem)]) -> ([Param], [BlockItem]))
-> CompilerM op s (Int, [(Param, BlockItem)])
-> CompilerM op s ([Param], [BlockItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(Param, BlockItem)] -> ([Param], [BlockItem])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Param, BlockItem)] -> ([Param], [BlockItem]))
-> ((Int, [(Param, BlockItem)]) -> [(Param, BlockItem)])
-> (Int, [(Param, BlockItem)])
-> ([Param], [BlockItem])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, [(Param, BlockItem)]) -> [(Param, BlockItem)]
forall a b. (a, b) -> b
snd)
(CompilerM op s (Int, [(Param, BlockItem)])
-> CompilerM op s ([Param], [BlockItem]))
-> ([ValueType] -> CompilerM op s (Int, [(Param, BlockItem)]))
-> [ValueType]
-> CompilerM op s ([Param], [BlockItem])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
-> ((Name, EntryPointType), [ValueType])
-> CompilerM op s (Int, (Param, BlockItem)))
-> Int
-> [((Name, EntryPointType), [ValueType])]
-> CompilerM op s (Int, [(Param, BlockItem)])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM Int
-> ((Name, EntryPointType), [ValueType])
-> CompilerM op s (Int, (Param, BlockItem))
forall {op} {s}.
Int
-> ((Name, EntryPointType), [ValueType])
-> CompilerM op s (Int, (Param, BlockItem))
onField Int
0
([((Name, EntryPointType), [ValueType])]
-> CompilerM op s (Int, [(Param, BlockItem)]))
-> ([ValueType] -> [((Name, EntryPointType), [ValueType])])
-> [ValueType]
-> CompilerM op s (Int, [(Param, BlockItem)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Name, EntryPointType)]
-> [[ValueType]] -> [((Name, EntryPointType), [ValueType])]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Name, EntryPointType)]
fs
([[ValueType]] -> [((Name, EntryPointType), [ValueType])])
-> ([ValueType] -> [[ValueType]])
-> [ValueType]
-> [((Name, EntryPointType), [ValueType])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OpaqueTypes -> [EntryPointType] -> [ValueType] -> [[ValueType]]
forall a. OpaqueTypes -> [EntryPointType] -> [a] -> [[a]]
recordFieldPayloads OpaqueTypes
types (((Name, EntryPointType) -> EntryPointType)
-> [(Name, EntryPointType)] -> [EntryPointType]
forall a b. (a -> b) -> [a] -> [b]
map (Name, EntryPointType) -> EntryPointType
forall a b. (a, b) -> b
snd [(Name, EntryPointType)]
fs)
([ValueType] -> CompilerM op s ([Param], [BlockItem]))
-> [ValueType] -> CompilerM op s ([Param], [BlockItem])
forall a b. (a -> b) -> a -> b
$ [ValueType]
vds
HeaderSection -> Definition -> CompilerM op s ()
forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl
(String -> HeaderSection
OpaqueDecl String
desc)
[C.cedecl|int $id:new($ty:ctx_ty *ctx, $ty:opaque_type** out, $params:params);|]
Definition -> CompilerM op s ()
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;
}|]
CFuncName -> CompilerM op s CFuncName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CFuncName -> CompilerM op s CFuncName)
-> CFuncName -> CompilerM op s CFuncName
forall a b. (a -> b) -> a -> b
$ String -> CFuncName
T.pack String
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) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit (Name -> String
nameToString Name
f)
then Name -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
C.toIdent (Name
"v" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
f) SrcLoc
forall a. Monoid a => a
mempty
else Name -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
C.toIdent Name
f SrcLoc
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
(Int, (Param, BlockItem))
-> CompilerM op s (Int, (Param, BlockItem))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Int
offset Int -> Int -> Int
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 <- Publicness -> ValueType -> CompilerM op s Type
forall op s. Publicness -> ValueType -> CompilerM op s Type
valueTypeToCType Publicness
Public ValueType
vt
(Int, (Param, BlockItem))
-> CompilerM op s (Int, (Param, BlockItem))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Int
offset Int -> Int -> Int
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 String
f_desc -> do
Type
ct <- String -> CompilerM op s Type
forall op s. String -> CompilerM op s Type
opaqueToCType String
f_desc
let param_fields :: [Exp]
param_fields = do
Int
i <- [Int
0 ..]
Exp -> [Exp]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|$id:param_name->$id:(tupleField i)|]
(Int, (Param, BlockItem))
-> CompilerM op s (Int, (Param, BlockItem))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [ValueType] -> Int
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 Int -> Int -> Bool
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 ->
String ->
OpaqueType ->
[ValueType] ->
CompilerM op s (Maybe Manifest.RecordOps)
processOpaqueRecord :: forall op s.
OpaqueTypes
-> String
-> OpaqueType
-> [ValueType]
-> CompilerM op s (Maybe RecordOps)
processOpaqueRecord OpaqueTypes
_ String
_ (OpaqueType [ValueType]
_) [ValueType]
_ = Maybe RecordOps -> CompilerM op s (Maybe RecordOps)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe RecordOps
forall a. Maybe a
Nothing
processOpaqueRecord OpaqueTypes
types String
desc (OpaqueRecord [(Name, EntryPointType)]
fs) [ValueType]
vds =
RecordOps -> Maybe RecordOps
forall a. a -> Maybe a
Just
(RecordOps -> Maybe RecordOps)
-> CompilerM op s RecordOps -> CompilerM op s (Maybe RecordOps)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( [RecordField] -> CFuncName -> RecordOps
Manifest.RecordOps
([RecordField] -> CFuncName -> RecordOps)
-> CompilerM op s [RecordField]
-> CompilerM op s (CFuncName -> RecordOps)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OpaqueTypes
-> String
-> [(Name, EntryPointType)]
-> [ValueType]
-> CompilerM op s [RecordField]
forall op s.
OpaqueTypes
-> String
-> [(Name, EntryPointType)]
-> [ValueType]
-> CompilerM op s [RecordField]
opaqueProjectFunctions OpaqueTypes
types String
desc [(Name, EntryPointType)]
fs [ValueType]
vds
CompilerM op s (CFuncName -> RecordOps)
-> CompilerM op s CFuncName -> CompilerM op s RecordOps
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> OpaqueTypes
-> String
-> [(Name, EntryPointType)]
-> [ValueType]
-> CompilerM op s CFuncName
forall op s.
OpaqueTypes
-> String
-> [(Name, EntryPointType)]
-> [ValueType]
-> CompilerM op s CFuncName
opaqueNewFunctions OpaqueTypes
types String
desc [(Name, EntryPointType)]
fs [ValueType]
vds
)
opaqueLibraryFunctions ::
OpaqueTypes ->
String ->
OpaqueType ->
CompilerM op s (Manifest.OpaqueOps, Maybe Manifest.RecordOps)
opaqueLibraryFunctions :: forall op s.
OpaqueTypes
-> String
-> OpaqueType
-> CompilerM op s (OpaqueOps, Maybe RecordOps)
opaqueLibraryFunctions OpaqueTypes
types String
desc OpaqueType
ot = do
String
name <- String -> CompilerM op s String
forall op s. String -> CompilerM op s String
publicName (String -> CompilerM op s String)
-> String -> CompilerM op s String
forall a b. (a -> b) -> a -> b
$ String -> String
opaqueName String
desc
String
free_opaque <- String -> CompilerM op s String
forall op s. String -> CompilerM op s String
publicName (String -> CompilerM op s String)
-> String -> CompilerM op s String
forall a b. (a -> b) -> a -> b
$ String
"free_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
opaqueName String
desc
String
store_opaque <- String -> CompilerM op s String
forall op s. String -> CompilerM op s String
publicName (String -> CompilerM op s String)
-> String -> CompilerM op s String
forall a b. (a -> b) -> a -> b
$ String
"store_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
opaqueName String
desc
String
restore_opaque <- String -> CompilerM op s String
forall op s. String -> CompilerM op s String
publicName (String -> CompilerM op s String)
-> String -> CompilerM op s String
forall a b. (a -> b) -> a -> b
$ String
"restore_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
opaqueName String
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) = Bool -> CompilerM op s () -> CompilerM op s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
rank Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (CompilerM op s () -> CompilerM op s ())
-> CompilerM op s () -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ do
let field :: String
field = Int -> String
tupleField Int
i
String
free_array <- String -> CompilerM op s String
forall op s. String -> CompilerM op s String
publicName (String -> CompilerM op s String)
-> String -> CompilerM op s String
forall a b. (a -> b) -> a -> b
$ String
"free_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PrimType -> Signedness -> Int -> String
arrayName PrimType
pt Signedness
signed Int
rank
Stm -> CompilerM op s ()
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 :: String
field = Int -> String
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|]
[Stm] -> [Stm] -> [Stm]
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 :: String
arr_name = PrimType -> Signedness -> Int -> String
arrayName PrimType
pt Signedness
sign Int
rank
field :: String
field = Int -> String
tupleField Int
i
shape_array :: String
shape_array = String
"futhark_shape_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
arr_name
values_array :: String
values_array = String
"futhark_values_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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 Int -> Int -> Int
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|]
[Stm] -> [Stm] -> [Stm]
forall a. [a] -> [a] -> [a]
++ [C.cstms|ret |= $id:values_array(ctx, obj->$id:field, (void*)out);
out += $exp:num_elems * $int:(primByteSize pt::Int);|]
)
Type
ctx_ty <- CompilerM op s Type
forall op s. CompilerM op s Type
contextType
let vds :: [ValueType]
vds = OpaqueTypes -> OpaqueType -> [ValueType]
opaquePayload OpaqueTypes
types OpaqueType
ot
[BlockItem]
free_body <- CompilerM op s () -> CompilerM op s [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect (CompilerM op s () -> CompilerM op s [BlockItem])
-> CompilerM op s () -> CompilerM op s [BlockItem]
forall a b. (a -> b) -> a -> b
$ (Int -> ValueType -> CompilerM op s ())
-> [Int] -> [ValueType] -> CompilerM op s ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Int -> ValueType -> CompilerM op s ()
forall {op} {s}. Int -> ValueType -> CompilerM op s ()
freeComponent [Int
0 ..] [ValueType]
vds
[BlockItem]
store_body <- CompilerM op s () -> CompilerM op s [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect (CompilerM op s () -> CompilerM op s [BlockItem])
-> CompilerM op s () -> CompilerM op s [BlockItem]
forall a b. (a -> b) -> a -> b
$ do
let ([Exp]
sizes, [[Stm]]
stores) = [(Exp, [Stm])] -> ([Exp], [[Stm]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Exp, [Stm])] -> ([Exp], [[Stm]]))
-> [(Exp, [Stm])] -> ([Exp], [[Stm]])
forall a b. (a -> b) -> a -> b
$ (Int -> ValueType -> (Exp, [Stm]))
-> [Int] -> [ValueType] -> [(Exp, [Stm])]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> ValueType -> (Exp, [Stm])
storeComponent [Int
0 ..] [ValueType]
vds
size_vars :: [String]
size_vars = (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"size_" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
0 .. [Exp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp]
sizes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
size_sum :: Exp
size_sum = [Exp] -> Exp
csum [[C.cexp|$id:size|] | String
size <- [String]
size_vars]
[(String, Exp)]
-> ((String, Exp) -> CompilerM op s ()) -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([String] -> [Exp] -> [(String, Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
size_vars [Exp]
sizes) (((String, Exp) -> CompilerM op s ()) -> CompilerM op s ())
-> ((String, Exp) -> CompilerM op s ()) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \(String
v, Exp
e) ->
BlockItem -> CompilerM op s ()
forall op s. BlockItem -> CompilerM op s ()
item [C.citem|typename int64_t $id:v = $exp:e;|]
Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
stm [C.cstm|*n = $exp:size_sum;|]
Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
stm [C.cstm|if (p != NULL && *p == NULL) { *p = malloc(*n); }|]
Stm -> CompilerM op s ()
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 :: String
field = Int -> String
tupleField Int
i
dataptr :: String
dataptr = String
"data_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
[Stm] -> CompilerM op s ()
forall op s. [Stm] -> CompilerM op s ()
stms ([Stm] -> CompilerM op s ()) -> [Stm] -> CompilerM op s ()
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|]
BlockItem -> CompilerM op s ()
forall op s. BlockItem -> CompilerM op s ()
item [C.citem|const void* $id:dataptr = src;|]
Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
stm [C.cstm|src += sizeof(obj->$id:field);|]
[Stm] -> CompilerM op s [Stm]
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 :: String
field = Int -> String
tupleField Int
i
arr_name :: String
arr_name = PrimType -> Signedness -> Int -> String
arrayName PrimType
pt Signedness
sign Int
rank
new_array :: String
new_array = String
"futhark_new_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
arr_name
dataptr :: String
dataptr = String
"data_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
shapearr :: String
shapearr = String
"shape_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
dims :: [Exp]
dims = [[C.cexp|$id:shapearr[$int:j]|] | Int
j <- [Int
0 .. Int
rank Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
num_elems :: Exp
num_elems = [Exp] -> Exp
cproduct [Exp]
dims
BlockItem -> CompilerM op s ()
forall op s. BlockItem -> CompilerM op s ()
item [C.citem|typename int64_t $id:shapearr[$int:rank] = {0};|]
[Stm] -> CompilerM op s ()
forall op s. [Stm] -> CompilerM op s ()
stms ([Stm] -> CompilerM op s ()) -> [Stm] -> CompilerM op s ()
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|]
BlockItem -> CompilerM op s ()
forall op s. BlockItem -> CompilerM op s ()
item [C.citem|const void* $id:dataptr = src;|]
Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
stm [C.cstm|obj->$id:field = NULL;|]
Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
stm [C.cstm|src += $exp:num_elems * $int:(primByteSize pt::Int);|]
[Stm] -> CompilerM op s [Stm]
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 <- CompilerM op s () -> CompilerM op s [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect (CompilerM op s () -> CompilerM op s [BlockItem])
-> CompilerM op s () -> CompilerM op s [BlockItem]
forall a b. (a -> b) -> a -> b
$ do
[Stm]
loads <- [[Stm]] -> [Stm]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Stm]] -> [Stm])
-> CompilerM op s [[Stm]] -> CompilerM op s [Stm]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> ValueType -> CompilerM op s [Stm])
-> [Int] -> [ValueType] -> CompilerM op s [[Stm]]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Int -> ValueType -> CompilerM op s [Stm]
forall {op} {s}. Int -> ValueType -> CompilerM op s [Stm]
restoreComponent [Int
0 ..] (OpaqueTypes -> OpaqueType -> [ValueType]
opaquePayload OpaqueTypes
types OpaqueType
ot)
Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
stm
[C.cstm|if (err == 0) {
$stms:loads
}|]
HeaderSection -> Definition -> CompilerM op s ()
forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl
(String -> HeaderSection
OpaqueTypeDecl String
desc)
[C.cedecl|struct $id:name;|]
HeaderSection -> Definition -> CompilerM op s ()
forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl
(String -> HeaderSection
OpaqueDecl String
desc)
[C.cedecl|int $id:free_opaque($ty:ctx_ty *ctx, $ty:opaque_type *obj);|]
HeaderSection -> Definition -> CompilerM op s ()
forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl
(String -> HeaderSection
OpaqueDecl String
desc)
[C.cedecl|int $id:store_opaque($ty:ctx_ty *ctx, const $ty:opaque_type *obj, void **p, size_t *n);|]
HeaderSection -> Definition -> CompilerM op s ()
forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl
(String -> HeaderSection
OpaqueDecl String
desc)
[C.cedecl|$ty:opaque_type* $id:restore_opaque($ty:ctx_ty *ctx, const void *p);|]
Maybe RecordOps
record <- OpaqueTypes
-> String
-> OpaqueType
-> [ValueType]
-> CompilerM op s (Maybe RecordOps)
forall op s.
OpaqueTypes
-> String
-> OpaqueType
-> [ValueType]
-> CompilerM op s (Maybe RecordOps)
processOpaqueRecord OpaqueTypes
types String
desc OpaqueType
ot [ValueType]
vds
(Definition -> CompilerM op s ())
-> [Definition] -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
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;
}
|]
(OpaqueOps, Maybe RecordOps)
-> CompilerM op s (OpaqueOps, Maybe RecordOps)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( OpaqueOps :: CFuncName -> CFuncName -> CFuncName -> OpaqueOps
Manifest.OpaqueOps
{ opaqueFree :: CFuncName
Manifest.opaqueFree = String -> CFuncName
T.pack String
free_opaque,
opaqueStore :: CFuncName
Manifest.opaqueStore = String -> CFuncName
T.pack String
store_opaque,
opaqueRestore :: CFuncName
Manifest.opaqueRestore = String -> CFuncName
T.pack String
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 (CFuncName, Type))
generateArray Space
space ((Signedness
signed, PrimType
pt, Int
rank), Publicness
pub) = do
String
name <- String -> CompilerM op s String
forall op s. String -> CompilerM op s String
publicName (String -> CompilerM op s String)
-> String -> CompilerM op s String
forall a b. (a -> b) -> a -> b
$ PrimType -> Signedness -> Int -> String
arrayName PrimType
pt Signedness
signed Int
rank
let memty :: Type
memty = Space -> Type
fatMemType Space
space
Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
libDecl [C.cedecl|struct $id:name { $ty:memty mem; typename int64_t shape[$int:rank]; };|]
ArrayOps
ops <- Publicness
-> Space
-> PrimType
-> Signedness
-> Int
-> CompilerM op s ArrayOps
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 :: CFuncName
pt_name = String -> CFuncName
T.pack (String -> CFuncName) -> String -> CFuncName
forall a b. (a -> b) -> a -> b
$ Bool -> PrimType -> String
prettySigned (Signedness
signed Signedness -> Signedness -> Bool
forall a. Eq a => a -> a -> Bool
== Signedness
Unsigned) PrimType
pt
pretty_name :: CFuncName
pretty_name = [CFuncName] -> CFuncName
forall a. Monoid a => [a] -> a
mconcat (Int -> CFuncName -> [CFuncName]
forall a. Int -> a -> [a]
replicate Int
rank CFuncName
"[]") CFuncName -> CFuncName -> CFuncName
forall a. Semigroup a => a -> a -> a
<> CFuncName
pt_name
arr_type :: Type
arr_type = [C.cty|struct $id:name*|]
case Publicness
pub of
Publicness
Public ->
Maybe (CFuncName, Type) -> CompilerM op s (Maybe (CFuncName, Type))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (CFuncName, Type)
-> CompilerM op s (Maybe (CFuncName, Type)))
-> Maybe (CFuncName, Type)
-> CompilerM op s (Maybe (CFuncName, Type))
forall a b. (a -> b) -> a -> b
$
(CFuncName, Type) -> Maybe (CFuncName, Type)
forall a. a -> Maybe a
Just
( CFuncName
pretty_name,
CFuncName -> CFuncName -> Int -> ArrayOps -> Type
Manifest.TypeArray (Type -> CFuncName
forall a. Pretty a => a -> CFuncName
prettyText Type
arr_type) CFuncName
pt_name Int
rank ArrayOps
ops
)
Publicness
Private ->
Maybe (CFuncName, Type) -> CompilerM op s (Maybe (CFuncName, Type))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (CFuncName, Type)
forall a. Maybe a
Nothing
generateOpaque ::
OpaqueTypes ->
(String, OpaqueType) ->
CompilerM op s (T.Text, Manifest.Type)
generateOpaque :: forall op s.
OpaqueTypes
-> (String, OpaqueType) -> CompilerM op s (CFuncName, Type)
generateOpaque OpaqueTypes
types (String
desc, OpaqueType
ot) = do
String
name <- String -> CompilerM op s String
forall op s. String -> CompilerM op s String
publicName (String -> CompilerM op s String)
-> String -> CompilerM op s String
forall a b. (a -> b) -> a -> b
$ String -> String
opaqueName String
desc
[FieldGroup]
members <- (ValueType -> Int -> CompilerM op s FieldGroup)
-> [ValueType] -> [Int] -> CompilerM op s [FieldGroup]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM ValueType -> Int -> CompilerM op s FieldGroup
forall {op} {s}. ValueType -> Int -> CompilerM op s FieldGroup
field (OpaqueTypes -> OpaqueType -> [ValueType]
opaquePayload OpaqueTypes
types OpaqueType
ot) [(Int
0 :: Int) ..]
Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
libDecl [C.cedecl|struct $id:name { $sdecls:members };|]
(OpaqueOps
ops, Maybe RecordOps
record) <- OpaqueTypes
-> String
-> OpaqueType
-> CompilerM op s (OpaqueOps, Maybe RecordOps)
forall op s.
OpaqueTypes
-> String
-> OpaqueType
-> CompilerM op s (OpaqueOps, Maybe RecordOps)
opaqueLibraryFunctions OpaqueTypes
types String
desc OpaqueType
ot
let opaque_type :: Type
opaque_type = [C.cty|struct $id:name*|]
(CFuncName, Type) -> CompilerM op s (CFuncName, Type)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> CFuncName
T.pack String
desc, CFuncName -> OpaqueOps -> Maybe RecordOps -> Type
Manifest.TypeOpaque (Type -> CFuncName
forall a. Pretty a => a -> CFuncName
prettyText 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 <- Publicness -> ValueType -> CompilerM op s Type
forall op s. Publicness -> ValueType -> CompilerM op s Type
valueTypeToCType Publicness
Private ValueType
vt
FieldGroup -> CompilerM op s FieldGroup
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldGroup -> CompilerM op s FieldGroup)
-> FieldGroup -> CompilerM op s FieldGroup
forall a b. (a -> b) -> a -> b
$
if Int
r Int -> Int -> Bool
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 CFuncName Type)
generateAPITypes Space
arr_space types :: OpaqueTypes
types@(OpaqueTypes [(String, OpaqueType)]
opaques) = do
((String, OpaqueType) -> CompilerM op s ())
-> [(String, OpaqueType)] -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (OpaqueType -> CompilerM op s ()
forall {op} {s}. OpaqueType -> CompilerM op s ()
findNecessaryArrays (OpaqueType -> CompilerM op s ())
-> ((String, OpaqueType) -> OpaqueType)
-> (String, OpaqueType)
-> CompilerM op s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, OpaqueType) -> OpaqueType
forall a b. (a, b) -> b
snd) [(String, OpaqueType)]
opaques
[Maybe (CFuncName, Type)]
array_ts <- (((Signedness, PrimType, Int), Publicness)
-> CompilerM op s (Maybe (CFuncName, Type)))
-> [((Signedness, PrimType, Int), Publicness)]
-> CompilerM op s [Maybe (CFuncName, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Space
-> ((Signedness, PrimType, Int), Publicness)
-> CompilerM op s (Maybe (CFuncName, Type))
forall op s.
Space
-> ((Signedness, PrimType, Int), Publicness)
-> CompilerM op s (Maybe (CFuncName, Type))
generateArray Space
arr_space) ([((Signedness, PrimType, Int), Publicness)]
-> CompilerM op s [Maybe (CFuncName, Type)])
-> (Map (Signedness, PrimType, Int) Publicness
-> [((Signedness, PrimType, Int), Publicness)])
-> Map (Signedness, PrimType, Int) Publicness
-> CompilerM op s [Maybe (CFuncName, Type)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (Signedness, PrimType, Int) Publicness
-> [((Signedness, PrimType, Int), Publicness)]
forall k a. Map k a -> [(k, a)]
M.toList (Map (Signedness, PrimType, Int) Publicness
-> CompilerM op s [Maybe (CFuncName, Type)])
-> CompilerM op s (Map (Signedness, PrimType, Int) Publicness)
-> CompilerM op s [Maybe (CFuncName, Type)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (CompilerState s -> Map (Signedness, PrimType, Int) Publicness)
-> CompilerM op s (Map (Signedness, PrimType, Int) Publicness)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState s -> Map (Signedness, PrimType, Int) Publicness
forall s.
CompilerState s -> Map (Signedness, PrimType, Int) Publicness
compArrayTypes
[(CFuncName, Type)]
opaque_ts <- ((String, OpaqueType) -> CompilerM op s (CFuncName, Type))
-> [(String, OpaqueType)] -> CompilerM op s [(CFuncName, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (OpaqueTypes
-> (String, OpaqueType) -> CompilerM op s (CFuncName, Type)
forall op s.
OpaqueTypes
-> (String, OpaqueType) -> CompilerM op s (CFuncName, Type)
generateOpaque OpaqueTypes
types) [(String, OpaqueType)]
opaques
Map CFuncName Type -> CompilerM op s (Map CFuncName Type)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map CFuncName Type -> CompilerM op s (Map CFuncName Type))
-> Map CFuncName Type -> CompilerM op s (Map CFuncName Type)
forall a b. (a -> b) -> a -> b
$ [(CFuncName, Type)] -> Map CFuncName Type
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(CFuncName, Type)] -> Map CFuncName Type)
-> [(CFuncName, Type)] -> Map CFuncName Type
forall a b. (a -> b) -> a -> b
$ [Maybe (CFuncName, Type)] -> [(CFuncName, Type)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (CFuncName, Type)]
array_ts [(CFuncName, Type)] -> [(CFuncName, Type)] -> [(CFuncName, Type)]
forall a. Semigroup a => a -> a -> a
<> [(CFuncName, Type)]
opaque_ts
where
findNecessaryArrays :: OpaqueType -> CompilerM op s ()
findNecessaryArrays (OpaqueType [ValueType]
_) =
() -> CompilerM op s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
findNecessaryArrays (OpaqueRecord [(Name, EntryPointType)]
fs) =
((Name, EntryPointType) -> CompilerM op s Type)
-> [(Name, EntryPointType)] -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Publicness -> EntryPointType -> CompilerM op s Type
forall op s. Publicness -> EntryPointType -> CompilerM op s Type
entryPointTypeToCType Publicness
Public (EntryPointType -> CompilerM op s Type)
-> ((Name, EntryPointType) -> EntryPointType)
-> (Name, EntryPointType)
-> CompilerM op s Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, EntryPointType) -> EntryPointType
forall a b. (a, b) -> b
snd) [(Name, EntryPointType)]
fs