{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TupleSections #-}
module Futhark.CodeGen.Backends.GenericC
( compileProg,
compileProg',
compileFun,
defaultOperations,
CParts (..),
asLibrary,
asExecutable,
asServer,
module Futhark.CodeGen.Backends.GenericC.Monad,
module Futhark.CodeGen.Backends.GenericC.Code,
)
where
import Control.Monad.Reader
import Control.Monad.State
import qualified Data.DList as DL
import Data.Loc
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Data.Text as T
import Futhark.CodeGen.Backends.GenericC.CLI (cliDefs)
import Futhark.CodeGen.Backends.GenericC.Code
import Futhark.CodeGen.Backends.GenericC.EntryPoints
import Futhark.CodeGen.Backends.GenericC.Monad
import Futhark.CodeGen.Backends.GenericC.Options
import Futhark.CodeGen.Backends.GenericC.Server (serverDefs)
import Futhark.CodeGen.Backends.GenericC.Types
import Futhark.CodeGen.ImpCode
import Futhark.CodeGen.RTS.C (cacheH, contextH, contextPrototypesH, errorsH, halfH, lockH, timingH, utilH)
import Futhark.IR.Prop (isBuiltInFunction)
import qualified Futhark.Manifest as Manifest
import Futhark.MonadFreshNames
import Futhark.Util.Pretty (prettyText)
import qualified Language.C.Quote.OpenCL as C
import qualified Language.C.Syntax as C
import NeatInterpolation (untrimming)
defCall :: CallCompiler op s
defCall :: forall op s. CallCompiler op s
defCall [VName]
dests Name
fname [Exp]
args = do
let out_args :: [Exp]
out_args = [[C.cexp|&$id:d|] | VName
d <- [VName]
dests]
args' :: [Exp]
args'
| Name -> Bool
isBuiltInFunction Name
fname = [Exp]
args
| Bool
otherwise = [C.cexp|ctx|] Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: [Exp]
out_args [Exp] -> [Exp] -> [Exp]
forall a. [a] -> [a] -> [a]
++ [Exp]
args
case [VName]
dests of
[VName
dest]
| Name -> Bool
isBuiltInFunction Name
fname ->
Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
stm [C.cstm|$id:dest = $id:(funName fname)($args:args');|]
[VName]
_ ->
BlockItem -> CompilerM op s ()
forall op s. BlockItem -> CompilerM op s ()
item [C.citem|if ($id:(funName fname)($args:args') != 0) { err = 1; goto cleanup; }|]
defError :: ErrorCompiler op s
defError :: forall op s. ErrorCompiler op s
defError ErrorMsg Exp
msg String
stacktrace = do
(String
formatstr, [Exp]
formatargs) <- ErrorMsg Exp -> CompilerM op s (String, [Exp])
forall op s. ErrorMsg Exp -> CompilerM op s (String, [Exp])
errorMsgString ErrorMsg Exp
msg
let formatstr' :: String
formatstr' = String
"Error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
formatstr String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n\nBacktrace:\n%s"
[BlockItem] -> CompilerM op s ()
forall op s. [BlockItem] -> CompilerM op s ()
items
[C.citems|set_error(ctx, msgprintf($string:formatstr', $args:formatargs, $string:stacktrace));
err = FUTHARK_PROGRAM_ERROR;
goto cleanup;|]
defaultOperations :: Operations op s
defaultOperations :: forall op s. Operations op s
defaultOperations =
Operations :: forall op s.
WriteScalar op s
-> ReadScalar op s
-> Allocate op s
-> Deallocate op s
-> Copy op s
-> StaticArray op s
-> MemoryType op s
-> OpCompiler op s
-> ErrorCompiler op s
-> CallCompiler op s
-> Bool
-> ([BlockItem], [BlockItem])
-> Operations op s
Operations
{ opsWriteScalar :: WriteScalar op s
opsWriteScalar = WriteScalar op s
forall {p} {p} {p} {p} {p} {a}. p -> p -> p -> p -> p -> a
defWriteScalar,
opsReadScalar :: ReadScalar op s
opsReadScalar = ReadScalar op s
forall {p} {p} {p} {p} {a}. p -> p -> p -> p -> a
defReadScalar,
opsAllocate :: Allocate op s
opsAllocate = Allocate op s
forall {p} {p} {p} {a}. p -> p -> p -> a
defAllocate,
opsDeallocate :: Deallocate op s
opsDeallocate = Deallocate op s
forall {p} {p} {a}. p -> p -> a
defDeallocate,
opsCopy :: Copy op s
opsCopy = Copy op s
forall {p} {op} {s}.
p
-> Exp
-> Exp
-> Space
-> Exp
-> Exp
-> Space
-> Exp
-> CompilerM op s ()
defCopy,
opsStaticArray :: StaticArray op s
opsStaticArray = StaticArray op s
forall {p} {p} {p} {p} {a}. p -> p -> p -> p -> a
defStaticArray,
opsMemoryType :: MemoryType op s
opsMemoryType = MemoryType op s
forall {p} {a}. p -> a
defMemoryType,
opsCompiler :: OpCompiler op s
opsCompiler = OpCompiler op s
forall {p} {a}. p -> a
defCompiler,
opsFatMemory :: Bool
opsFatMemory = Bool
True,
opsError :: ErrorCompiler op s
opsError = ErrorCompiler op s
forall op s. ErrorCompiler op s
defError,
opsCall :: CallCompiler op s
opsCall = CallCompiler op s
forall op s. CallCompiler op s
defCall,
opsCritical :: ([BlockItem], [BlockItem])
opsCritical = ([BlockItem], [BlockItem])
forall a. Monoid a => a
mempty
}
where
defWriteScalar :: p -> p -> p -> p -> p -> a
defWriteScalar p
_ p
_ p
_ p
_ p
_ =
String -> a
forall a. HasCallStack => String -> a
error String
"Cannot write to non-default memory space because I am dumb"
defReadScalar :: p -> p -> p -> p -> a
defReadScalar p
_ p
_ p
_ p
_ =
String -> a
forall a. HasCallStack => String -> a
error String
"Cannot read from non-default memory space"
defAllocate :: p -> p -> p -> a
defAllocate p
_ p
_ p
_ =
String -> a
forall a. HasCallStack => String -> a
error String
"Cannot allocate in non-default memory space"
defDeallocate :: p -> p -> a
defDeallocate p
_ p
_ =
String -> a
forall a. HasCallStack => String -> a
error String
"Cannot deallocate in non-default memory space"
defCopy :: p
-> Exp
-> Exp
-> Space
-> Exp
-> Exp
-> Space
-> Exp
-> CompilerM op s ()
defCopy p
_ Exp
destmem Exp
destoffset Space
DefaultSpace Exp
srcmem Exp
srcoffset Space
DefaultSpace Exp
size =
Exp -> Exp -> Exp -> Exp -> Exp -> CompilerM op s ()
forall op s. Exp -> Exp -> Exp -> Exp -> Exp -> CompilerM op s ()
copyMemoryDefaultSpace Exp
destmem Exp
destoffset Exp
srcmem Exp
srcoffset Exp
size
defCopy p
_ Exp
_ Exp
_ Space
_ Exp
_ Exp
_ Space
_ Exp
_ =
String -> CompilerM op s ()
forall a. HasCallStack => String -> a
error String
"Cannot copy to or from non-default memory space"
defStaticArray :: p -> p -> p -> p -> a
defStaticArray p
_ p
_ p
_ p
_ =
String -> a
forall a. HasCallStack => String -> a
error String
"Cannot create static array in non-default memory space"
defMemoryType :: p -> a
defMemoryType p
_ =
String -> a
forall a. HasCallStack => String -> a
error String
"Has no type for non-default memory space"
defCompiler :: p -> a
defCompiler p
_ =
String -> a
forall a. HasCallStack => String -> a
error String
"The default compiler cannot compile extended operations"
compileFunBody :: [C.Exp] -> [Param] -> Code op -> CompilerM op s ()
compileFunBody :: forall op s. [Exp] -> [Param] -> Code op -> CompilerM op s ()
compileFunBody [Exp]
output_ptrs [Param]
outputs Code op
code = do
(Param -> CompilerM op s ()) -> [Param] -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Param -> CompilerM op s ()
forall {op} {s}. Param -> CompilerM op s ()
declareOutput [Param]
outputs
Code op -> CompilerM op s ()
forall op s. Code op -> CompilerM op s ()
compileCode Code op
code
(Exp -> Param -> CompilerM op s ())
-> [Exp] -> [Param] -> CompilerM op s ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Exp -> Param -> CompilerM op s ()
forall {a} {op} {s}. ToExp a => a -> Param -> CompilerM op s ()
setRetVal' [Exp]
output_ptrs [Param]
outputs
where
declareOutput :: Param -> CompilerM op s ()
declareOutput (MemParam VName
name Space
space) =
VName -> Space -> CompilerM op s ()
forall op s. VName -> Space -> CompilerM op s ()
declMem VName
name Space
space
declareOutput (ScalarParam VName
name PrimType
pt) = do
let ctp :: Type
ctp = PrimType -> Type
primTypeToCType PrimType
pt
InitGroup -> CompilerM op s ()
forall op s. InitGroup -> CompilerM op s ()
decl [C.cdecl|$ty:ctp $id:name;|]
setRetVal' :: a -> Param -> CompilerM op s ()
setRetVal' a
p (MemParam VName
name Space
space) = do
Exp -> Space -> CompilerM op s ()
forall a op s. ToExp a => a -> Space -> CompilerM op s ()
resetMem [C.cexp|*$exp:p|] Space
space
Exp -> VName -> Space -> CompilerM op s ()
forall a b op s.
(ToExp a, ToExp b) =>
a -> b -> Space -> CompilerM op s ()
setMem [C.cexp|*$exp:p|] VName
name Space
space
setRetVal' a
p (ScalarParam VName
name PrimType
_) =
Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
stm [C.cstm|*$exp:p = $id:name;|]
compileFun :: [C.BlockItem] -> [C.Param] -> (Name, Function op) -> CompilerM op s (C.Definition, C.Func)
compileFun :: forall op s.
[BlockItem]
-> [Param]
-> (Name, Function op)
-> CompilerM op s (Definition, Func)
compileFun [BlockItem]
get_constants [Param]
extra (Name
fname, func :: Function op
func@(Function Maybe EntryPoint
_ [Param]
outputs [Param]
inputs Code op
body)) = CompilerM op s (Definition, Func)
-> CompilerM op s (Definition, Func)
forall op s a. CompilerM op s a -> CompilerM op s a
inNewFunction (CompilerM op s (Definition, Func)
-> CompilerM op s (Definition, Func))
-> CompilerM op s (Definition, Func)
-> CompilerM op s (Definition, Func)
forall a b. (a -> b) -> a -> b
$ do
([Param]
outparams, [Exp]
out_ptrs) <- [(Param, Exp)] -> ([Param], [Exp])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Param, Exp)] -> ([Param], [Exp]))
-> CompilerM op s [(Param, Exp)] -> CompilerM op s ([Param], [Exp])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Param -> CompilerM op s (Param, Exp))
-> [Param] -> CompilerM op s [(Param, Exp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Param -> CompilerM op s (Param, Exp)
forall {op} {s}. Param -> CompilerM op s (Param, Exp)
compileOutput [Param]
outputs
[Param]
inparams <- (Param -> CompilerM op s Param)
-> [Param] -> CompilerM op s [Param]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Param -> CompilerM op s Param
forall {op} {s}. Param -> CompilerM op s Param
compileInput [Param]
inputs
Map VName Space
-> ([BlockItem] -> [Stm] -> CompilerM op s (Definition, Func))
-> CompilerM op s (Definition, Func)
forall op s a.
Map VName Space
-> ([BlockItem] -> [Stm] -> CompilerM op s a) -> CompilerM op s a
cachingMemory (Function op -> Map VName Space
forall a. Function a -> Map VName Space
lexicalMemoryUsage Function op
func) (([BlockItem] -> [Stm] -> CompilerM op s (Definition, Func))
-> CompilerM op s (Definition, Func))
-> ([BlockItem] -> [Stm] -> CompilerM op s (Definition, Func))
-> CompilerM op s (Definition, Func)
forall a b. (a -> b) -> a -> b
$ \[BlockItem]
decl_cached [Stm]
free_cached -> do
[BlockItem]
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] -> [Param] -> Code op -> CompilerM op s ()
forall op s. [Exp] -> [Param] -> Code op -> CompilerM op s ()
compileFunBody [Exp]
out_ptrs [Param]
outputs Code op
body
[BlockItem]
decl_mem <- CompilerM op s [BlockItem]
forall op s. CompilerM op s [BlockItem]
declAllocatedMem
[BlockItem]
free_mem <- CompilerM op s [BlockItem]
forall op s. CompilerM op s [BlockItem]
freeAllocatedMem
(Definition, Func) -> CompilerM op s (Definition, Func)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( [C.cedecl|static int $id:(funName fname)($params:extra, $params:outparams, $params:inparams);|],
[C.cfun|static int $id:(funName fname)($params:extra, $params:outparams, $params:inparams) {
$stms:ignores
int err = 0;
$items:decl_cached
$items:decl_mem
$items:get_constants
$items:body'
cleanup:
{
$stms:free_cached
$items:free_mem
}
return err;
}|]
)
where
ignores :: [Stm]
ignores = [[C.cstm|(void)$id:p;|] | C.Param (Just Id
p) DeclSpec
_ Decl
_ SrcLoc
_ <- [Param]
extra]
compileInput :: Param -> CompilerM op s Param
compileInput (ScalarParam VName
name PrimType
bt) = do
let ctp :: Type
ctp = PrimType -> Type
primTypeToCType PrimType
bt
Param -> CompilerM op s Param
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cparam|$ty:ctp $id:name|]
compileInput (MemParam VName
name Space
space) = do
Type
ty <- VName -> Space -> CompilerM op s Type
forall op s. VName -> Space -> CompilerM op s Type
memToCType VName
name Space
space
Param -> CompilerM op s Param
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cparam|$ty:ty $id:name|]
compileOutput :: Param -> CompilerM op s (Param, Exp)
compileOutput (ScalarParam VName
name PrimType
bt) = do
let ctp :: Type
ctp = PrimType -> Type
primTypeToCType PrimType
bt
VName
p_name <- String -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => String -> m VName
newVName (String -> CompilerM op s VName) -> String -> CompilerM op s VName
forall a b. (a -> b) -> a -> b
$ String
"out_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ VName -> String
baseString VName
name
(Param, Exp) -> CompilerM op s (Param, Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([C.cparam|$ty:ctp *$id:p_name|], [C.cexp|$id:p_name|])
compileOutput (MemParam VName
name Space
space) = do
Type
ty <- VName -> Space -> CompilerM op s Type
forall op s. VName -> Space -> CompilerM op s Type
memToCType VName
name Space
space
VName
p_name <- String -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => String -> m VName
newVName (String -> CompilerM op s VName) -> String -> CompilerM op s VName
forall a b. (a -> b) -> a -> b
$ VName -> String
baseString VName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_p"
(Param, Exp) -> CompilerM op s (Param, Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([C.cparam|$ty:ty *$id:p_name|], [C.cexp|$id:p_name|])
declsCode :: (HeaderSection -> Bool) -> CompilerState s -> T.Text
declsCode :: forall s. (HeaderSection -> Bool) -> CompilerState s -> Text
declsCode HeaderSection -> Bool
p =
[Text] -> Text
T.unlines
([Text] -> Text)
-> (CompilerState s -> [Text]) -> CompilerState s -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Definition -> Text) -> [Definition] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Definition -> Text
forall a. Pretty a => a -> Text
prettyText
([Definition] -> [Text])
-> (CompilerState s -> [Definition]) -> CompilerState s -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HeaderSection, DList Definition) -> [Definition])
-> [(HeaderSection, DList Definition)] -> [Definition]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DList Definition -> [Definition]
forall a. DList a -> [a]
DL.toList (DList Definition -> [Definition])
-> ((HeaderSection, DList Definition) -> DList Definition)
-> (HeaderSection, DList Definition)
-> [Definition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderSection, DList Definition) -> DList Definition
forall a b. (a, b) -> b
snd)
([(HeaderSection, DList Definition)] -> [Definition])
-> (CompilerState s -> [(HeaderSection, DList Definition)])
-> CompilerState s
-> [Definition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HeaderSection, DList Definition) -> Bool)
-> [(HeaderSection, DList Definition)]
-> [(HeaderSection, DList Definition)]
forall a. (a -> Bool) -> [a] -> [a]
filter (HeaderSection -> Bool
p (HeaderSection -> Bool)
-> ((HeaderSection, DList Definition) -> HeaderSection)
-> (HeaderSection, DList Definition)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderSection, DList Definition) -> HeaderSection
forall a b. (a, b) -> a
fst)
([(HeaderSection, DList Definition)]
-> [(HeaderSection, DList Definition)])
-> (CompilerState s -> [(HeaderSection, DList Definition)])
-> CompilerState s
-> [(HeaderSection, DList Definition)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map HeaderSection (DList Definition)
-> [(HeaderSection, DList Definition)]
forall k a. Map k a -> [(k, a)]
M.toList
(Map HeaderSection (DList Definition)
-> [(HeaderSection, DList Definition)])
-> (CompilerState s -> Map HeaderSection (DList Definition))
-> CompilerState s
-> [(HeaderSection, DList Definition)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerState s -> Map HeaderSection (DList Definition)
forall s. CompilerState s -> Map HeaderSection (DList Definition)
compHeaderDecls
initDecls, arrayDecls, opaqueDecls, opaqueTypeDecls, entryDecls, miscDecls :: CompilerState s -> T.Text
initDecls :: forall s. CompilerState s -> Text
initDecls = (HeaderSection -> Bool) -> CompilerState s -> Text
forall s. (HeaderSection -> Bool) -> CompilerState s -> Text
declsCode (HeaderSection -> HeaderSection -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderSection
InitDecl)
arrayDecls :: forall s. CompilerState s -> Text
arrayDecls = (HeaderSection -> Bool) -> CompilerState s -> Text
forall s. (HeaderSection -> Bool) -> CompilerState s -> Text
declsCode HeaderSection -> Bool
isArrayDecl
where
isArrayDecl :: HeaderSection -> Bool
isArrayDecl ArrayDecl {} = Bool
True
isArrayDecl HeaderSection
_ = Bool
False
opaqueTypeDecls :: forall s. CompilerState s -> Text
opaqueTypeDecls = (HeaderSection -> Bool) -> CompilerState s -> Text
forall s. (HeaderSection -> Bool) -> CompilerState s -> Text
declsCode HeaderSection -> Bool
isOpaqueTypeDecl
where
isOpaqueTypeDecl :: HeaderSection -> Bool
isOpaqueTypeDecl OpaqueTypeDecl {} = Bool
True
isOpaqueTypeDecl HeaderSection
_ = Bool
False
opaqueDecls :: forall s. CompilerState s -> Text
opaqueDecls = (HeaderSection -> Bool) -> CompilerState s -> Text
forall s. (HeaderSection -> Bool) -> CompilerState s -> Text
declsCode HeaderSection -> Bool
isOpaqueDecl
where
isOpaqueDecl :: HeaderSection -> Bool
isOpaqueDecl OpaqueDecl {} = Bool
True
isOpaqueDecl HeaderSection
_ = Bool
False
entryDecls :: forall s. CompilerState s -> Text
entryDecls = (HeaderSection -> Bool) -> CompilerState s -> Text
forall s. (HeaderSection -> Bool) -> CompilerState s -> Text
declsCode (HeaderSection -> HeaderSection -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderSection
EntryDecl)
miscDecls :: forall s. CompilerState s -> Text
miscDecls = (HeaderSection -> Bool) -> CompilerState s -> Text
forall s. (HeaderSection -> Bool) -> CompilerState s -> Text
declsCode (HeaderSection -> HeaderSection -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderSection
MiscDecl)
defineMemorySpace :: Space -> CompilerM op s (C.Definition, [C.Definition], C.BlockItem)
defineMemorySpace :: forall op s.
Space -> CompilerM op s (Definition, [Definition], BlockItem)
defineMemorySpace Space
space = do
Type
rm <- Space -> CompilerM op s Type
forall op s. Space -> CompilerM op s Type
rawMemCType Space
space
let structdef :: Definition
structdef =
[C.cedecl|struct $id:sname { int *references;
$ty:rm mem;
typename int64_t size;
const char *desc; };|]
Id -> Type -> Maybe Exp -> CompilerM op s ()
forall op s. Id -> Type -> Maybe Exp -> CompilerM op s ()
contextField Id
peakname [C.cty|typename int64_t|] (Maybe Exp -> CompilerM op s ()) -> Maybe Exp -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ Exp -> Maybe Exp
forall a. a -> Maybe a
Just [C.cexp|0|]
Id -> Type -> Maybe Exp -> CompilerM op s ()
forall op s. Id -> Type -> Maybe Exp -> CompilerM op s ()
contextField Id
usagename [C.cty|typename int64_t|] (Maybe Exp -> CompilerM op s ()) -> Maybe Exp -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ Exp -> Maybe Exp
forall a. a -> Maybe a
Just [C.cexp|0|]
[BlockItem]
free <- 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 -> Exp -> CompilerM op s ()
forall a b op s.
(ToExp a, ToExp b) =>
a -> Space -> b -> CompilerM op s ()
freeRawMem [C.cexp|block->mem|] Space
space [C.cexp|desc|]
Type
ctx_ty <- CompilerM op s Type
forall op s. CompilerM op s Type
contextType
let unrefdef :: Definition
unrefdef =
[C.cedecl|int $id:(fatMemUnRef space) ($ty:ctx_ty *ctx, $ty:mty *block, const char *desc) {
if (block->references != NULL) {
*(block->references) -= 1;
if (ctx->detail_memory) {
fprintf(ctx->log, "Unreferencing block %s (allocated as %s) in %s: %d references remaining.\n",
desc, block->desc, $string:spacedesc, *(block->references));
}
if (*(block->references) == 0) {
ctx->$id:usagename -= block->size;
$items:free
free(block->references);
if (ctx->detail_memory) {
fprintf(ctx->log, "%lld bytes freed (now allocated: %lld bytes)\n",
(long long) block->size, (long long) ctx->$id:usagename);
}
}
block->references = NULL;
}
return 0;
}|]
[BlockItem]
alloc <-
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 -> Exp -> Space -> Exp -> CompilerM op s ()
forall a b c op s.
(ToExp a, ToExp b, ToExp c) =>
a -> b -> Space -> c -> CompilerM op s ()
allocRawMem [C.cexp|block->mem|] [C.cexp|size|] Space
space [C.cexp|desc|]
let allocdef :: Definition
allocdef =
[C.cedecl|int $id:(fatMemAlloc space) ($ty:ctx_ty *ctx, $ty:mty *block, typename int64_t size, const char *desc) {
if (size < 0) {
futhark_panic(1, "Negative allocation of %lld bytes attempted for %s in %s.\n",
(long long)size, desc, $string:spacedesc, ctx->$id:usagename);
}
int ret = $id:(fatMemUnRef space)(ctx, block, desc);
if (ret != FUTHARK_SUCCESS) {
return ret;
}
if (ctx->detail_memory) {
fprintf(ctx->log, "Allocating %lld bytes for %s in %s (then allocated: %lld bytes)",
(long long) size,
desc, $string:spacedesc,
(long long) ctx->$id:usagename + size);
}
if (ctx->$id:usagename > ctx->$id:peakname) {
ctx->$id:peakname = ctx->$id:usagename;
if (ctx->detail_memory) {
fprintf(ctx->log, " (new peak).\n");
}
} else if (ctx->detail_memory) {
fprintf(ctx->log, ".\n");
}
$items:alloc
if (ctx->error == NULL) {
block->references = (int*) malloc(sizeof(int));
*(block->references) = 1;
block->size = size;
block->desc = desc;
ctx->$id:usagename += size;
return FUTHARK_SUCCESS;
} else {
// We are naively assuming that any memory allocation error is due to OOM.
// We preserve the original error so that a savvy user can perhaps find
// glory despite our naiveté.
// We cannot use set_error() here because we want to replace the old error.
lock_lock(&ctx->error_lock);
char *old_error = ctx->error;
ctx->error = msgprintf("Failed to allocate memory in %s.\nAttempted allocation: %12lld bytes\nCurrently allocated: %12lld bytes\n%s",
$string:spacedesc,
(long long) size,
(long long) ctx->$id:usagename,
old_error);
free(old_error);
lock_unlock(&ctx->error_lock);
return FUTHARK_OUT_OF_MEMORY;
}
}|]
let setdef :: Definition
setdef =
[C.cedecl|int $id:(fatMemSet space) ($ty:ctx_ty *ctx, $ty:mty *lhs, $ty:mty *rhs, const char *lhs_desc) {
int ret = $id:(fatMemUnRef space)(ctx, lhs, lhs_desc);
if (rhs->references != NULL) {
(*(rhs->references))++;
}
*lhs = *rhs;
return ret;
}
|]
BlockItem -> CompilerM op s ()
forall op s. BlockItem -> CompilerM op s ()
onClear [C.citem|ctx->$id:peakname = 0;|]
let peakmsg :: String
peakmsg = String
"Peak memory usage for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
spacedesc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": %lld bytes.\n"
(Definition, [Definition], BlockItem)
-> CompilerM op s (Definition, [Definition], BlockItem)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Definition
structdef,
[Definition
unrefdef, Definition
allocdef, Definition
setdef],
if Space
space Space -> Space -> Bool
forall a. Eq a => a -> a -> Bool
== Space
DefaultSpace
then [C.citem|{}|]
else [C.citem|str_builder(&builder, $string:peakmsg, (long long) ctx->$id:peakname);|]
)
where
mty :: Type
mty = Space -> Type
fatMemType Space
space
(Id
peakname, Id
usagename, Id
sname, String
spacedesc) = case Space
space of
Space String
sid ->
( String -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
C.toIdent (String
"peak_mem_usage_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sid) SrcLoc
forall a. IsLocation a => a
noLoc,
String -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
C.toIdent (String
"cur_mem_usage_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sid) SrcLoc
forall a. IsLocation a => a
noLoc,
String -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
C.toIdent (String
"memblock_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sid) SrcLoc
forall a. IsLocation a => a
noLoc,
String
"space '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
)
Space
_ ->
( Id
"peak_mem_usage_default",
Id
"cur_mem_usage_default",
Id
"memblock",
String
"default space"
)
data CParts = CParts
{ :: T.Text,
CParts -> Text
cUtils :: T.Text,
CParts -> Text
cCLI :: T.Text,
CParts -> Text
cServer :: T.Text,
CParts -> Text
cLib :: T.Text,
CParts -> Text
cJsonManifest :: T.Text
}
gnuSource :: T.Text
gnuSource :: Text
gnuSource =
[untrimming|
// We need to define _GNU_SOURCE before
// _any_ headers files are imported to get
// the usage statistics of a thread (i.e. have RUSAGE_THREAD) on GNU/Linux
// https://manpages.courier-mta.org/htmlman2/getrusage.2.html
#ifndef _GNU_SOURCE // Avoid possible double-definition warning.
#define _GNU_SOURCE
#endif
|]
disableWarnings :: T.Text
disableWarnings :: Text
disableWarnings =
[untrimming|
#ifdef __clang__
#pragma clang diagnostic ignored "-Wunused-function"
#pragma clang diagnostic ignored "-Wunused-variable"
#pragma clang diagnostic ignored "-Wparentheses"
#pragma clang diagnostic ignored "-Wunused-label"
#elif __GNUC__
#pragma GCC diagnostic ignored "-Wunused-function"
#pragma GCC diagnostic ignored "-Wunused-variable"
#pragma GCC diagnostic ignored "-Wparentheses"
#pragma GCC diagnostic ignored "-Wunused-label"
#pragma GCC diagnostic ignored "-Wunused-but-set-variable"
#endif
|]
asLibrary :: CParts -> (T.Text, T.Text, T.Text)
asLibrary :: CParts -> (Text, Text, Text)
asLibrary CParts
parts =
( Text
"#pragma once\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CParts -> Text
cHeader CParts
parts,
Text
gnuSource Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
disableWarnings Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CParts -> Text
cHeader CParts
parts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CParts -> Text
cUtils CParts
parts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CParts -> Text
cLib CParts
parts,
CParts -> Text
cJsonManifest CParts
parts
)
asExecutable :: CParts -> T.Text
asExecutable :: CParts -> Text
asExecutable CParts
parts =
Text
gnuSource Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
disableWarnings Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CParts -> Text
cHeader CParts
parts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CParts -> Text
cUtils CParts
parts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CParts -> Text
cCLI CParts
parts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CParts -> Text
cLib CParts
parts
asServer :: CParts -> T.Text
asServer :: CParts -> Text
asServer CParts
parts =
Text
gnuSource Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
disableWarnings Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CParts -> Text
cHeader CParts
parts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CParts -> Text
cUtils CParts
parts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CParts -> Text
cServer CParts
parts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CParts -> Text
cLib CParts
parts
compileProg' ::
MonadFreshNames m =>
T.Text ->
T.Text ->
Operations op s ->
s ->
CompilerM op s () ->
T.Text ->
(Space, [Space]) ->
[Option] ->
Definitions op ->
m (CParts, CompilerState s)
compileProg' :: forall (m :: * -> *) op s.
MonadFreshNames m =>
Text
-> Text
-> Operations op s
-> s
-> CompilerM op s ()
-> Text
-> (Space, [Space])
-> [Option]
-> Definitions op
-> m (CParts, CompilerState s)
compileProg' Text
backend Text
version Operations op s
ops s
def CompilerM op s ()
extra Text
header_extra (Space
arr_space, [Space]
spaces) [Option]
options Definitions op
prog = do
VNameSource
src <- m VNameSource
forall (m :: * -> *). MonadFreshNames m => m VNameSource
getNameSource
let ((Text
prototypes, Text
definitions, Text
entry_point_decls, Manifest
manifest), CompilerState s
endstate) =
Operations op s
-> VNameSource
-> s
-> CompilerM op s (Text, Text, Text, Manifest)
-> ((Text, Text, Text, Manifest), CompilerState s)
forall op s a.
Operations op s
-> VNameSource -> s -> CompilerM op s a -> (a, CompilerState s)
runCompilerM Operations op s
ops VNameSource
src s
def CompilerM op s (Text, Text, Text, Manifest)
compileProgAction
initdecls :: Text
initdecls = CompilerState s -> Text
forall s. CompilerState s -> Text
initDecls CompilerState s
endstate
entrydecls :: Text
entrydecls = CompilerState s -> Text
forall s. CompilerState s -> Text
entryDecls CompilerState s
endstate
arraydecls :: Text
arraydecls = CompilerState s -> Text
forall s. CompilerState s -> Text
arrayDecls CompilerState s
endstate
opaquetypedecls :: Text
opaquetypedecls = CompilerState s -> Text
forall s. CompilerState s -> Text
opaqueTypeDecls CompilerState s
endstate
opaquedecls :: Text
opaquedecls = CompilerState s -> Text
forall s. CompilerState s -> Text
opaqueDecls CompilerState s
endstate
miscdecls :: Text
miscdecls = CompilerState s -> Text
forall s. CompilerState s -> Text
miscDecls CompilerState s
endstate
let headerdefs :: Text
headerdefs =
[untrimming|
// Headers
#include <stdint.h>
#include <stddef.h>
#include <stdbool.h>
#include <stdio.h>
#include <float.h>
$header_extra
#ifdef __cplusplus
extern "C" {
#endif
// Initialisation
$initdecls
// Arrays
$arraydecls
// Opaque values
$opaquetypedecls
$opaquedecls
// Entry points
$entrydecls
// Miscellaneous
$miscdecls
#define FUTHARK_BACKEND_$backend
$errorsH
#ifdef __cplusplus
}
#endif
|]
let utildefs :: Text
utildefs =
[untrimming|
#include <stdio.h>
#include <stdlib.h>
#include <stdbool.h>
#include <math.h>
#include <stdint.h>
// If NDEBUG is set, the assert() macro will do nothing. Since Futhark
// (unfortunately) makes use of assert() for error detection (and even some
// side effects), we want to avoid that.
#undef NDEBUG
#include <assert.h>
#include <stdarg.h>
$utilH
$cacheH
$halfH
$timingH
|]
let early_decls :: Text
early_decls = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Definition -> Text) -> [Definition] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Definition -> Text
forall a. Pretty a => a -> Text
prettyText ([Definition] -> [Text]) -> [Definition] -> [Text]
forall a b. (a -> b) -> a -> b
$ DList Definition -> [Definition]
forall a. DList a -> [a]
DL.toList (DList Definition -> [Definition])
-> DList Definition -> [Definition]
forall a b. (a -> b) -> a -> b
$ CompilerState s -> DList Definition
forall s. CompilerState s -> DList Definition
compEarlyDecls CompilerState s
endstate
lib_decls :: Text
lib_decls = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Definition -> Text) -> [Definition] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Definition -> Text
forall a. Pretty a => a -> Text
prettyText ([Definition] -> [Text]) -> [Definition] -> [Text]
forall a b. (a -> b) -> a -> b
$ DList Definition -> [Definition]
forall a. DList a -> [a]
DL.toList (DList Definition -> [Definition])
-> DList Definition -> [Definition]
forall a b. (a -> b) -> a -> b
$ CompilerState s -> DList Definition
forall s. CompilerState s -> DList Definition
compLibDecls CompilerState s
endstate
clidefs :: Text
clidefs = [Option] -> Manifest -> Text
cliDefs [Option]
options Manifest
manifest
serverdefs :: Text
serverdefs = [Option] -> Manifest -> Text
serverDefs [Option]
options Manifest
manifest
libdefs :: Text
libdefs =
[untrimming|
#ifdef _MSC_VER
#define inline __inline
#endif
#include <string.h>
#include <string.h>
#include <errno.h>
#include <assert.h>
#include <ctype.h>
$header_extra
$lockH
#define FUTHARK_F64_ENABLED
$cScalarDefs
$contextPrototypesH
$early_decls
$contextH
$prototypes
$lib_decls
$definitions
$entry_point_decls
|]
(CParts, CompilerState s) -> m (CParts, CompilerState s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( CParts :: Text -> Text -> Text -> Text -> Text -> Text -> CParts
CParts
{ cHeader :: Text
cHeader = Text
headerdefs,
cUtils :: Text
cUtils = Text
utildefs,
cCLI :: Text
cCLI = Text
clidefs,
cServer :: Text
cServer = Text
serverdefs,
cLib :: Text
cLib = Text
libdefs,
cJsonManifest :: Text
cJsonManifest = Manifest -> Text
Manifest.manifestToJSON Manifest
manifest
},
CompilerState s
endstate
)
where
Definitions OpaqueTypes
types Constants op
consts (Functions [(Name, Function op)]
funs) = Definitions op
prog
compileProgAction :: CompilerM op s (Text, Text, Text, Manifest)
compileProgAction = do
([Definition]
memstructs, [[Definition]]
memfuns, [BlockItem]
memreport) <- [(Definition, [Definition], BlockItem)]
-> ([Definition], [[Definition]], [BlockItem])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(Definition, [Definition], BlockItem)]
-> ([Definition], [[Definition]], [BlockItem]))
-> CompilerM op s [(Definition, [Definition], BlockItem)]
-> CompilerM op s ([Definition], [[Definition]], [BlockItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Space -> CompilerM op s (Definition, [Definition], BlockItem))
-> [Space]
-> CompilerM op s [(Definition, [Definition], BlockItem)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Space -> CompilerM op s (Definition, [Definition], BlockItem)
forall op s.
Space -> CompilerM op s (Definition, [Definition], BlockItem)
defineMemorySpace [Space]
spaces
[BlockItem]
get_consts <- Constants op -> CompilerM op s [BlockItem]
forall op s. Constants op -> CompilerM op s [BlockItem]
compileConstants Constants op
consts
Type
ctx_ty <- CompilerM op s Type
forall op s. CompilerM op s Type
contextType
([Definition]
prototypes, [Func]
functions) <-
[(Definition, Func)] -> ([Definition], [Func])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Definition, Func)] -> ([Definition], [Func]))
-> CompilerM op s [(Definition, Func)]
-> CompilerM op s ([Definition], [Func])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, Function op) -> CompilerM op s (Definition, Func))
-> [(Name, Function op)] -> CompilerM op s [(Definition, Func)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([BlockItem]
-> [Param]
-> (Name, Function op)
-> CompilerM op s (Definition, Func)
forall op s.
[BlockItem]
-> [Param]
-> (Name, Function op)
-> CompilerM op s (Definition, Func)
compileFun [BlockItem]
get_consts [[C.cparam|$ty:ctx_ty *ctx|]]) [(Name, Function op)]
funs
(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 ()
earlyDecl [Definition]
memstructs
([Definition]
entry_points, [(Text, EntryPoint)]
entry_points_manifest) <-
[(Definition, (Text, EntryPoint))]
-> ([Definition], [(Text, EntryPoint)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Definition, (Text, EntryPoint))]
-> ([Definition], [(Text, EntryPoint)]))
-> ([Maybe (Definition, (Text, EntryPoint))]
-> [(Definition, (Text, EntryPoint))])
-> [Maybe (Definition, (Text, EntryPoint))]
-> ([Definition], [(Text, EntryPoint)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Definition, (Text, EntryPoint))]
-> [(Definition, (Text, EntryPoint))]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Definition, (Text, EntryPoint))]
-> ([Definition], [(Text, EntryPoint)]))
-> CompilerM op s [Maybe (Definition, (Text, EntryPoint))]
-> CompilerM op s ([Definition], [(Text, EntryPoint)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, Function op)
-> CompilerM op s (Maybe (Definition, (Text, EntryPoint))))
-> [(Name, Function op)]
-> CompilerM op s [Maybe (Definition, (Text, EntryPoint))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Name
-> Function op
-> CompilerM op s (Maybe (Definition, (Text, EntryPoint))))
-> (Name, Function op)
-> CompilerM op s (Maybe (Definition, (Text, EntryPoint)))
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ([BlockItem]
-> Name
-> Function op
-> CompilerM op s (Maybe (Definition, (Text, EntryPoint)))
forall op s.
[BlockItem]
-> Name
-> Function op
-> CompilerM op s (Maybe (Definition, (Text, EntryPoint)))
onEntryPoint [BlockItem]
get_consts)) [(Name, Function op)]
funs
CompilerM op s ()
extra
(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 ()
earlyDecl ([Definition] -> CompilerM op s ())
-> [Definition] -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ [[Definition]] -> [Definition]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Definition]]
memfuns
Map Text Type
type_funs <- Space -> OpaqueTypes -> CompilerM op s (Map Text Type)
forall op s. Space -> OpaqueTypes -> CompilerM op s (Map Text Type)
generateAPITypes Space
arr_space OpaqueTypes
types
[BlockItem] -> CompilerM op s ()
forall op s. [BlockItem] -> CompilerM op s ()
generateCommonLibFuns [BlockItem]
memreport
(Text, Text, Text, Manifest)
-> CompilerM op s (Text, Text, Text, Manifest)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Definition -> Text) -> [Definition] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Definition -> Text
forall a. Pretty a => a -> Text
prettyText [Definition]
prototypes,
[Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Func -> Text) -> [Func] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Definition -> Text
forall a. Pretty a => a -> Text
prettyText (Definition -> Text) -> (Func -> Definition) -> Func -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Func -> Definition
funcToDef) [Func]
functions,
[Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Definition -> Text) -> [Definition] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Definition -> Text
forall a. Pretty a => a -> Text
prettyText [Definition]
entry_points,
Map Text EntryPoint -> Map Text Type -> Text -> Text -> Manifest
Manifest.Manifest ([(Text, EntryPoint)] -> Map Text EntryPoint
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Text, EntryPoint)]
entry_points_manifest) Map Text Type
type_funs Text
backend Text
version
)
funcToDef :: Func -> Definition
funcToDef Func
func = Func -> SrcLoc -> Definition
C.FuncDef Func
func SrcLoc
loc
where
loc :: SrcLoc
loc = case Func
func of
C.OldFunc DeclSpec
_ Id
_ Decl
_ [Id]
_ Maybe [InitGroup]
_ [BlockItem]
_ SrcLoc
l -> SrcLoc
l
C.Func DeclSpec
_ Id
_ Decl
_ Params
_ [BlockItem]
_ SrcLoc
l -> SrcLoc
l
compileProg ::
MonadFreshNames m =>
T.Text ->
T.Text ->
Operations op () ->
CompilerM op () () ->
T.Text ->
(Space, [Space]) ->
[Option] ->
Definitions op ->
m CParts
compileProg :: forall (m :: * -> *) op.
MonadFreshNames m =>
Text
-> Text
-> Operations op ()
-> CompilerM op () ()
-> Text
-> (Space, [Space])
-> [Option]
-> Definitions op
-> m CParts
compileProg Text
backend Text
version Operations op ()
ops CompilerM op () ()
extra Text
header_extra (Space
arr_space, [Space]
spaces) [Option]
options Definitions op
prog =
(CParts, CompilerState ()) -> CParts
forall a b. (a, b) -> a
fst ((CParts, CompilerState ()) -> CParts)
-> m (CParts, CompilerState ()) -> m CParts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> Text
-> Operations op ()
-> ()
-> CompilerM op () ()
-> Text
-> (Space, [Space])
-> [Option]
-> Definitions op
-> m (CParts, CompilerState ())
forall (m :: * -> *) op s.
MonadFreshNames m =>
Text
-> Text
-> Operations op s
-> s
-> CompilerM op s ()
-> Text
-> (Space, [Space])
-> [Option]
-> Definitions op
-> m (CParts, CompilerState s)
compileProg' Text
backend Text
version Operations op ()
ops () CompilerM op () ()
extra Text
header_extra (Space
arr_space, [Space]
spaces) [Option]
options Definitions op
prog
generateCommonLibFuns :: [C.BlockItem] -> CompilerM op s ()
generateCommonLibFuns :: forall op s. [BlockItem] -> CompilerM op s ()
generateCommonLibFuns [BlockItem]
memreport = do
Type
ctx <- CompilerM op s Type
forall op s. CompilerM op s Type
contextType
Type
cfg <- CompilerM op s Type
forall op s. CompilerM op s Type
configType
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
[BlockItem]
profilereport <- (CompilerState s -> [BlockItem]) -> CompilerM op s [BlockItem]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((CompilerState s -> [BlockItem]) -> CompilerM op s [BlockItem])
-> (CompilerState s -> [BlockItem]) -> CompilerM op s [BlockItem]
forall a b. (a -> b) -> a -> b
$ DList BlockItem -> [BlockItem]
forall a. DList a -> [a]
DL.toList (DList BlockItem -> [BlockItem])
-> (CompilerState s -> DList BlockItem)
-> CompilerState s
-> [BlockItem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerState s -> DList BlockItem
forall s. CompilerState s -> DList BlockItem
compProfileItems
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
publicDef_ String
"context_config_set_cache_file" HeaderSection
MiscDecl ((String -> (Definition, Definition)) -> CompilerM op s ())
-> (String -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \String
s ->
( [C.cedecl|void $id:s($ty:cfg* cfg, const char *f);|],
[C.cedecl|void $id:s($ty:cfg* cfg, const char *f) {
cfg->cache_fname = f;
}|]
)
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
publicDef_ String
"get_tuning_param_count" HeaderSection
InitDecl ((String -> (Definition, Definition)) -> CompilerM op s ())
-> (String -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \String
s ->
( [C.cedecl|int $id:s(void);|],
[C.cedecl|int $id:s(void) {
return sizeof(tuning_param_names)/sizeof(tuning_param_names[0]);
}|]
)
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
publicDef_ String
"get_tuning_param_name" HeaderSection
InitDecl ((String -> (Definition, Definition)) -> CompilerM op s ())
-> (String -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \String
s ->
( [C.cedecl|const char* $id:s(int);|],
[C.cedecl|const char* $id:s(int i) {
return tuning_param_names[i];
}|]
)
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
publicDef_ String
"get_tuning_param_class" HeaderSection
InitDecl ((String -> (Definition, Definition)) -> CompilerM op s ())
-> (String -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \String
s ->
( [C.cedecl|const char* $id:s(int);|],
[C.cedecl|const char* $id:s(int i) {
return tuning_param_classes[i];
}|]
)
String
sync <- String -> CompilerM op s String
forall op s. String -> CompilerM op s String
publicName String
"context_sync"
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
publicDef_ String
"context_report" HeaderSection
MiscDecl ((String -> (Definition, Definition)) -> CompilerM op s ())
-> (String -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \String
s ->
( [C.cedecl|char* $id:s($ty:ctx *ctx);|],
[C.cedecl|char* $id:s($ty:ctx *ctx) {
if ($id:sync(ctx) != 0) {
return NULL;
}
struct str_builder builder;
str_builder_init(&builder);
$items:memreport
if (ctx->profiling) {
$items:profilereport
}
return builder.str;
}|]
)
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
publicDef_ String
"context_get_error" HeaderSection
MiscDecl ((String -> (Definition, Definition)) -> CompilerM op s ())
-> (String -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \String
s ->
( [C.cedecl|char* $id:s($ty:ctx* ctx);|],
[C.cedecl|char* $id:s($ty:ctx* ctx) {
char* error = ctx->error;
ctx->error = NULL;
return error;
}|]
)
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
publicDef_ String
"context_set_logging_file" HeaderSection
MiscDecl ((String -> (Definition, Definition)) -> CompilerM op s ())
-> (String -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \String
s ->
( [C.cedecl|void $id:s($ty:ctx* ctx, typename FILE* f);|],
[C.cedecl|void $id:s($ty:ctx* ctx, typename FILE* f) {
ctx->log = f;
}|]
)
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
publicDef_ String
"context_pause_profiling" HeaderSection
MiscDecl ((String -> (Definition, Definition)) -> CompilerM op s ())
-> (String -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \String
s ->
( [C.cedecl|void $id:s($ty:ctx* ctx);|],
[C.cedecl|void $id:s($ty:ctx* ctx) {
ctx->profiling_paused = 1;
}|]
)
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
publicDef_ String
"context_unpause_profiling" HeaderSection
MiscDecl ((String -> (Definition, Definition)) -> CompilerM op s ())
-> (String -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \String
s ->
( [C.cedecl|void $id:s($ty:ctx* ctx);|],
[C.cedecl|void $id:s($ty:ctx* ctx) {
ctx->profiling_paused = 0;
}|]
)
[BlockItem]
clears <- (CompilerState s -> [BlockItem]) -> CompilerM op s [BlockItem]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((CompilerState s -> [BlockItem]) -> CompilerM op s [BlockItem])
-> (CompilerState s -> [BlockItem]) -> CompilerM op s [BlockItem]
forall a b. (a -> b) -> a -> b
$ DList BlockItem -> [BlockItem]
forall a. DList a -> [a]
DL.toList (DList BlockItem -> [BlockItem])
-> (CompilerState s -> DList BlockItem)
-> CompilerState s
-> [BlockItem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerState s -> DList BlockItem
forall s. CompilerState s -> DList BlockItem
compClearItems
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
publicDef_ String
"context_clear_caches" HeaderSection
MiscDecl ((String -> (Definition, Definition)) -> CompilerM op s ())
-> (String -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \String
s ->
( [C.cedecl|int $id:s($ty:ctx* ctx);|],
[C.cedecl|int $id:s($ty:ctx* ctx) {
$items:(criticalSection ops clears)
return ctx->error != NULL;
}|]
)
compileConstants :: Constants op -> CompilerM op s [C.BlockItem]
compileConstants :: forall op s. Constants op -> CompilerM op s [BlockItem]
compileConstants (Constants [Param]
ps Code op
init_consts) = do
Type
ctx_ty <- CompilerM op s Type
forall op s. CompilerM op s Type
contextType
[FieldGroup]
const_fields <- (Param -> CompilerM op s FieldGroup)
-> [Param] -> CompilerM op s [FieldGroup]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Param -> CompilerM op s FieldGroup
forall {op} {s}. Param -> CompilerM op s FieldGroup
constParamField [Param]
ps
let const_fields' :: [FieldGroup]
const_fields'
| [FieldGroup] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldGroup]
const_fields = [[C.csdecl|int dummy;|]]
| Bool
otherwise = [FieldGroup]
const_fields
Id -> Type -> Maybe Exp -> CompilerM op s ()
forall op s. Id -> Type -> Maybe Exp -> CompilerM op s ()
contextField Id
"constants" [C.cty|struct { $sdecls:const_fields' }|] Maybe Exp
forall a. Maybe a
Nothing
Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
earlyDecl [C.cedecl|static int init_constants($ty:ctx_ty*);|]
Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
earlyDecl [C.cedecl|static int free_constants($ty:ctx_ty*);|]
CompilerM op s () -> CompilerM op s ()
forall op s a. CompilerM op s a -> CompilerM op s a
inNewFunction (CompilerM op s () -> CompilerM op s ())
-> CompilerM op s () -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ do
let ([BlockItem]
defs, [BlockItem]
undefs) = [(BlockItem, BlockItem)] -> ([BlockItem], [BlockItem])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(BlockItem, BlockItem)] -> ([BlockItem], [BlockItem]))
-> [(BlockItem, BlockItem)] -> ([BlockItem], [BlockItem])
forall a b. (a -> b) -> a -> b
$ (Param -> (BlockItem, BlockItem))
-> [Param] -> [(BlockItem, BlockItem)]
forall a b. (a -> b) -> [a] -> [b]
map Param -> (BlockItem, BlockItem)
constMacro [Param]
ps
[BlockItem]
init_consts' <- 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
(Param -> CompilerM op s ()) -> [Param] -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Param -> CompilerM op s ()
forall {op} {s}. Param -> CompilerM op s ()
resetMemConst [Param]
ps
Code op -> CompilerM op s ()
forall op s. Code op -> CompilerM op s ()
compileCode Code op
init_consts
[BlockItem]
decl_mem <- CompilerM op s [BlockItem]
forall op s. CompilerM op s [BlockItem]
declAllocatedMem
[BlockItem]
free_mem <- CompilerM op s [BlockItem]
forall op s. CompilerM op s [BlockItem]
freeAllocatedMem
Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
libDecl
[C.cedecl|static int init_constants($ty:ctx_ty *ctx) {
(void)ctx;
int err = 0;
$items:defs
$items:decl_mem
$items:init_consts'
$items:free_mem
$items:undefs
cleanup:
return err;
}|]
CompilerM op s () -> CompilerM op s ()
forall op s a. CompilerM op s a -> CompilerM op s a
inNewFunction (CompilerM op s () -> CompilerM op s ())
-> CompilerM op s () -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ do
[BlockItem]
free_consts <- 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
$ (Param -> CompilerM op s ()) -> [Param] -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Param -> CompilerM op s ()
forall {op} {s}. Param -> CompilerM op s ()
freeConst [Param]
ps
Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
libDecl
[C.cedecl|static int free_constants($ty:ctx_ty *ctx) {
(void)ctx;
$items:free_consts
return 0;
}|]
(Param -> CompilerM op s BlockItem)
-> [Param] -> CompilerM op s [BlockItem]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Param -> CompilerM op s BlockItem
forall {op} {s}. Param -> CompilerM op s BlockItem
getConst [Param]
ps
where
constParamField :: Param -> CompilerM op s FieldGroup
constParamField (ScalarParam VName
name PrimType
bt) = do
let ctp :: Type
ctp = PrimType -> Type
primTypeToCType PrimType
bt
FieldGroup -> CompilerM op s FieldGroup
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.csdecl|$ty:ctp $id:name;|]
constParamField (MemParam VName
name Space
space) = do
Type
ty <- VName -> Space -> CompilerM op s Type
forall op s. VName -> Space -> CompilerM op s Type
memToCType VName
name Space
space
FieldGroup -> CompilerM op s FieldGroup
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.csdecl|$ty:ty $id:name;|]
constMacro :: Param -> (BlockItem, BlockItem)
constMacro Param
p = ([C.citem|$escstm:def|], [C.citem|$escstm:undef|])
where
p' :: String
p' = Id -> String
forall a. Pretty a => a -> String
pretty (VName -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
C.toIdent (Param -> VName
paramName Param
p) SrcLoc
forall a. Monoid a => a
mempty)
def :: String
def = String
"#define " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"ctx->constants." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
undef :: String
undef = String
"#undef " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p'
resetMemConst :: Param -> CompilerM op s ()
resetMemConst ScalarParam {} = () -> CompilerM op s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
resetMemConst (MemParam VName
name Space
space) = VName -> Space -> CompilerM op s ()
forall a op s. ToExp a => a -> Space -> CompilerM op s ()
resetMem VName
name Space
space
freeConst :: Param -> CompilerM op s ()
freeConst ScalarParam {} = () -> CompilerM op s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
freeConst (MemParam VName
name Space
space) = Exp -> Space -> CompilerM op s ()
forall a op s. ToExp a => a -> Space -> CompilerM op s ()
unRefMem [C.cexp|ctx->constants.$id:name|] Space
space
getConst :: Param -> CompilerM op s BlockItem
getConst (ScalarParam VName
name PrimType
bt) = do
let ctp :: Type
ctp = PrimType -> Type
primTypeToCType PrimType
bt
BlockItem -> CompilerM op s BlockItem
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.citem|$ty:ctp $id:name = ctx->constants.$id:name;|]
getConst (MemParam VName
name Space
space) = do
Type
ty <- VName -> Space -> CompilerM op s Type
forall op s. VName -> Space -> CompilerM op s Type
memToCType VName
name Space
space
BlockItem -> CompilerM op s BlockItem
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.citem|$ty:ty $id:name = ctx->constants.$id:name;|]