module Futhark.CodeGen.Backends.CSOpenCL.Boilerplate
( generateBoilerplate
, kernelRuntime
, kernelRuns
) where
import qualified Data.Map as M
import Futhark.CodeGen.ImpCode.OpenCL hiding (Index, If, SubExp(..))
import Futhark.CodeGen.Backends.GenericCSharp as CS
import Futhark.CodeGen.Backends.GenericCSharp.AST as AST
import Futhark.CodeGen.OpenCL.Heuristics
import Futhark.Util (zEncodeString)
intT, longT, stringT, intArrayT, stringArrayT :: CSType
intT :: CSType
intT = CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int32T
longT :: CSType
longT = CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int64T
stringT :: CSType
stringT = CSPrim -> CSType
Primitive CSPrim
StringT
intArrayT :: CSType
intArrayT = CSComp -> CSType
Composite (CSComp -> CSType) -> CSComp -> CSType
forall a b. (a -> b) -> a -> b
$ CSType -> CSComp
ArrayT CSType
intT
stringArrayT :: CSType
stringArrayT = CSComp -> CSType
Composite (CSComp -> CSType) -> CSComp -> CSType
forall a b. (a -> b) -> a -> b
$ CSType -> CSComp
ArrayT CSType
stringT
errorMsgNumArgs :: ErrorMsg a -> Int
errorMsgNumArgs :: ErrorMsg a -> Int
errorMsgNumArgs = [PrimType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([PrimType] -> Int)
-> (ErrorMsg a -> [PrimType]) -> ErrorMsg a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMsg a -> [PrimType]
forall a. ErrorMsg a -> [PrimType]
errorMsgArgTypes
formatEscape :: String -> String
formatEscape :: String -> String
formatEscape = (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
escapeChar
where escapeChar :: Char -> String
escapeChar Char
'{' = String
"{{"
escapeChar Char
'}' = String
"}}"
escapeChar Char
c = [Char
c]
failureCase :: Integer -> FailureMsg -> CSStmt
failureCase :: Integer -> FailureMsg -> CSStmt
failureCase Integer
i (FailureMsg (ErrorMsg [ErrorMsgPart Exp]
parts) String
backtrace) =
CSExp -> [CSStmt] -> [CSStmt] -> CSStmt
If (String -> CSExp -> CSExp -> CSExp
BinOp String
"==" (String -> CSExp
Var String
"failure_idx") (Integer -> CSExp
Integer Integer
i))
[ let (String
formatstr, [CSExp]
formatargs) = Integer -> [ErrorMsgPart Exp] -> (String, [CSExp])
forall a. Integer -> [ErrorMsgPart a] -> (String, [CSExp])
onParts Integer
0 [ErrorMsgPart Exp]
parts
in CSExp -> [CSExp] -> CSStmt
AST.Assert (Bool -> CSExp
AST.Bool Bool
False) ([CSExp] -> CSStmt) -> [CSExp] -> CSStmt
forall a b. (a -> b) -> a -> b
$
String -> CSExp
String (String
formatstr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nBacktrace:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
formatEscape String
backtrace) CSExp -> [CSExp] -> [CSExp]
forall a. a -> [a] -> [a]
:
[CSExp]
formatargs
]
[]
where onParts :: Integer -> [ErrorMsgPart a] -> (String, [CSExp])
onParts Integer
_ [] = (String
"", [])
onParts Integer
j (ErrorString String
s : [ErrorMsgPart a]
parts') =
let (String
formatstr, [CSExp]
formatargs) = Integer -> [ErrorMsgPart a] -> (String, [CSExp])
onParts Integer
j [ErrorMsgPart a]
parts'
in (String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
formatstr, [CSExp]
formatargs)
onParts Integer
j (ErrorInt32 a
_ : [ErrorMsgPart a]
parts') =
let (String
formatstr, [CSExp]
formatargs) = Integer -> [ErrorMsgPart a] -> (String, [CSExp])
onParts (Integer
jInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) [ErrorMsgPart a]
parts'
in (String
"{" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
j String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
formatstr, CSExp -> CSIdx -> CSExp
Index (String -> CSExp
Var String
"args") (CSExp -> CSIdx
IdxExp (CSExp -> CSIdx) -> CSExp -> CSIdx
forall a b. (a -> b) -> a -> b
$ Integer -> CSExp
Integer Integer
j) CSExp -> [CSExp] -> [CSExp]
forall a. a -> [a] -> [a]
: [CSExp]
formatargs)
generateBoilerplate :: String -> String -> M.Map KernelName Safety -> [PrimType]
-> M.Map Name SizeClass
-> [FailureMsg]
-> CS.CompilerM OpenCL () ()
generateBoilerplate :: String
-> String
-> Map String Safety
-> [PrimType]
-> Map Name SizeClass
-> [FailureMsg]
-> CompilerM OpenCL () ()
generateBoilerplate String
opencl_code String
opencl_prelude Map String Safety
kernels [PrimType]
types Map Name SizeClass
sizes [FailureMsg]
failures = do
[CSStmt]
final_inits <- CompilerM OpenCL () [CSStmt]
forall op s. CompilerM op s [CSStmt]
CS.contextFinalInits
let ([(CSType, String)]
opencl_fields, [CSStmt]
opencl_inits, CSStmt
top_decls, [CSStmt]
later_top_decls) =
Map String Safety
-> String
-> String
-> ([(CSType, String)], [CSStmt], CSStmt, [CSStmt])
openClDecls Map String Safety
kernels String
opencl_code String
opencl_prelude
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm CSStmt
top_decls
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped CSType
stringArrayT (String -> CSExp
Var String
"SizeNames")
(CSExp -> Maybe CSExp
forall a. a -> Maybe a
Just (CSExp -> Maybe CSExp) -> CSExp -> Maybe CSExp
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
Collection String
"string[]" ((Name -> CSExp) -> [Name] -> [CSExp]
forall a b. (a -> b) -> [a] -> [b]
map (String -> CSExp
String (String -> CSExp) -> (Name -> String) -> Name -> CSExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. Pretty a => a -> String
pretty) ([Name] -> [CSExp]) -> [Name] -> [CSExp]
forall a b. (a -> b) -> a -> b
$ Map Name SizeClass -> [Name]
forall k a. Map k a -> [k]
M.keys Map Name SizeClass
sizes))
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped CSType
stringArrayT (String -> CSExp
Var String
"SizeVars")
(CSExp -> Maybe CSExp
forall a. a -> Maybe a
Just (CSExp -> Maybe CSExp) -> CSExp -> Maybe CSExp
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
Collection String
"string[]" ((Name -> CSExp) -> [Name] -> [CSExp]
forall a b. (a -> b) -> [a] -> [b]
map (String -> CSExp
String (String -> CSExp) -> (Name -> String) -> Name -> CSExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
zEncodeString (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. Pretty a => a -> String
pretty) ([Name] -> [CSExp]) -> [Name] -> [CSExp]
forall a b. (a -> b) -> a -> b
$ Map Name SizeClass -> [Name]
forall k a. Map k a -> [k]
M.keys Map Name SizeClass
sizes))
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped CSType
stringArrayT (String -> CSExp
Var String
"SizeClasses")
(CSExp -> Maybe CSExp
forall a. a -> Maybe a
Just (CSExp -> Maybe CSExp) -> CSExp -> Maybe CSExp
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
Collection String
"string[]" ((SizeClass -> CSExp) -> [SizeClass] -> [CSExp]
forall a b. (a -> b) -> [a] -> [b]
map (String -> CSExp
String (String -> CSExp) -> (SizeClass -> String) -> SizeClass -> CSExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SizeClass -> String
forall a. Pretty a => a -> String
pretty) ([SizeClass] -> [CSExp]) -> [SizeClass] -> [CSExp]
forall a b. (a -> b) -> a -> b
$ Map Name SizeClass -> [SizeClass]
forall k a. Map k a -> [a]
M.elems Map Name SizeClass
sizes))
let get_num_sizes :: String
get_num_sizes = String -> String
CS.publicName String
"GetNumSizes"
let get_size_name :: String
get_size_name = String -> String
CS.publicName String
"GetSizeName"
let get_size_class :: String
get_size_class = String -> String
CS.publicName String
"GetSizeClass"
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt
CS.privateFunDef String
get_num_sizes CSType
intT []
[ CSExp -> CSStmt
Return (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ (Integer -> CSExp
Integer (Integer -> CSExp) -> (Int -> Integer) -> Int -> CSExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger) (Int -> CSExp) -> Int -> CSExp
forall a b. (a -> b) -> a -> b
$ Map Name SizeClass -> Int
forall k a. Map k a -> Int
M.size Map Name SizeClass
sizes ]
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt
CS.privateFunDef String
get_size_name (CSPrim -> CSType
Primitive CSPrim
StringT) [(CSType
intT, String
"i")]
[ CSExp -> CSStmt
Return (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ CSExp -> CSIdx -> CSExp
Index (String -> CSExp
Var String
"SizeNames") (CSExp -> CSIdx
IdxExp (CSExp -> CSIdx) -> CSExp -> CSIdx
forall a b. (a -> b) -> a -> b
$ String -> CSExp
Var String
"i") ]
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt
CS.privateFunDef String
get_size_class (CSPrim -> CSType
Primitive CSPrim
StringT) [(CSType
intT, String
"i")]
[ CSExp -> CSStmt
Return (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ CSExp -> CSIdx -> CSExp
Index (String -> CSExp
Var String
"SizeClasses") (CSExp -> CSIdx
IdxExp (CSExp -> CSIdx) -> CSExp -> CSIdx
forall a b. (a -> b) -> a -> b
$ String -> CSExp
Var String
"i") ]
let cfg :: String
cfg = String -> String
CS.publicName String
"ContextConfig"
let new_cfg :: String
new_cfg = String -> String
CS.publicName String
"ContextConfigNew"
let cfg_set_debugging :: String
cfg_set_debugging = String -> String
CS.publicName String
"ContextConfigSetDebugging"
let cfg_set_device :: String
cfg_set_device = String -> String
CS.publicName String
"ContextConfigSetDevice"
let cfg_set_platform :: String
cfg_set_platform = String -> String
CS.publicName String
"ContextConfigSetPlatform"
let cfg_dump_program_to :: String
cfg_dump_program_to = String -> String
CS.publicName String
"ContextConfigDumpProgramTo"
let cfg_load_program_from :: String
cfg_load_program_from = String -> String
CS.publicName String
"ContextConfigLoadProgramFrom"
let cfg_set_default_group_size :: String
cfg_set_default_group_size = String -> String
CS.publicName String
"ContextConfigSetDefaultGroupSize"
let cfg_set_default_num_groups :: String
cfg_set_default_num_groups = String -> String
CS.publicName String
"ContextConfigSetDefaultNumGroups"
let cfg_set_default_tile_size :: String
cfg_set_default_tile_size = String -> String
CS.publicName String
"ContextConfigSetDefaultTileSize"
let cfg_set_default_threshold :: String
cfg_set_default_threshold = String -> String
CS.publicName String
"ContextConfigSetDefaultThreshold"
let cfg_set_size :: String
cfg_set_size = String -> String
CS.publicName String
"ContextConfigSetSize"
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ String -> [(CSType, String)] -> CSStmt
StructDef String
"Sizes" ((Name -> (CSType, String)) -> [Name] -> [(CSType, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
k -> (CSType
intT, String -> String
zEncodeString (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Pretty a => a -> String
pretty Name
k)) ([Name] -> [(CSType, String)]) -> [Name] -> [(CSType, String)]
forall a b. (a -> b) -> a -> b
$ Map Name SizeClass -> [Name]
forall k a. Map k a -> [k]
M.keys Map Name SizeClass
sizes)
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ String -> [(CSType, String)] -> CSStmt
StructDef String
cfg [ (String -> CSType
CustomT String
"OpenCLConfig", String
"OpenCL")
, (CSType
intArrayT, String
"Sizes")]
let tmp_cfg :: CSExp
tmp_cfg = String -> CSExp
Var String
"tmp_cfg"
sizeInit :: SizeClass -> CSExp
sizeInit (SizeBespoke Name
_ Int32
x) = Integer -> CSExp
Integer (Integer -> CSExp) -> Integer -> CSExp
forall a b. (a -> b) -> a -> b
$ Int32 -> Integer
forall a. Integral a => a -> Integer
toInteger Int32
x
sizeInit SizeClass
_ = Integer -> CSExp
Integer Integer
0
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt
CS.privateFunDef String
new_cfg (String -> CSType
CustomT String
cfg) []
[ CSExp -> CSExp -> CSStmt
Assign CSExp
tmp_cfg (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
CS.simpleInitClass String
cfg []
, CSExp -> CSExp -> CSStmt
Reassign (CSExp -> String -> CSExp
Field CSExp
tmp_cfg String
"Sizes") (String -> [CSExp] -> CSExp
Collection String
"int[]" ((SizeClass -> CSExp) -> [SizeClass] -> [CSExp]
forall a b. (a -> b) -> [a] -> [b]
map SizeClass -> CSExp
sizeInit (Map Name SizeClass -> [SizeClass]
forall k a. Map k a -> [a]
M.elems Map Name SizeClass
sizes)))
, CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
CS.simpleCall String
"OpenCLConfigInit" [ CSExp -> CSExp
Out (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ CSExp -> String -> CSExp
Field CSExp
tmp_cfg String
"OpenCL", (Integer -> CSExp
Integer (Integer -> CSExp) -> (Int -> Integer) -> Int -> CSExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger) (Int -> CSExp) -> Int -> CSExp
forall a b. (a -> b) -> a -> b
$ Map Name SizeClass -> Int
forall k a. Map k a -> Int
M.size Map Name SizeClass
sizes
, String -> CSExp
Var String
"SizeNames", String -> CSExp
Var String
"SizeVars", CSExp -> String -> CSExp
Field CSExp
tmp_cfg String
"Sizes", String -> CSExp
Var String
"SizeClasses" ]
, CSExp -> CSStmt
Return CSExp
tmp_cfg
]
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt
CS.privateFunDef String
cfg_set_debugging CSType
VoidT [(CSType -> CSType
RefT (CSType -> CSType) -> CSType -> CSType
forall a b. (a -> b) -> a -> b
$ String -> CSType
CustomT String
cfg, String
"_cfg"),(CSPrim -> CSType
Primitive CSPrim
BoolT, String
"flag")]
[CSExp -> CSExp -> CSStmt
Reassign (String -> CSExp
Var String
"_cfg.OpenCL.Debugging") (String -> CSExp
Var String
"flag")]
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt
CS.privateFunDef String
cfg_set_device CSType
VoidT [(CSType -> CSType
RefT (CSType -> CSType) -> CSType -> CSType
forall a b. (a -> b) -> a -> b
$ String -> CSType
CustomT String
cfg, String
"_cfg"),(CSType
stringT, String
"s")]
[CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
CS.simpleCall String
"SetPreferredDevice" [CSExp -> CSExp
Ref (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ String -> CSExp
Var String
"_cfg.OpenCL", String -> CSExp
Var String
"s"]]
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt
CS.privateFunDef String
cfg_set_platform CSType
VoidT [(CSType -> CSType
RefT (CSType -> CSType) -> CSType -> CSType
forall a b. (a -> b) -> a -> b
$ String -> CSType
CustomT String
cfg, String
"_cfg"),(CSType
stringT, String
"s")]
[CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
CS.simpleCall String
"SetPreferredPlatform" [CSExp -> CSExp
Ref (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ String -> CSExp
Var String
"_cfg.OpenCL", String -> CSExp
Var String
"s"]]
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt
CS.privateFunDef String
cfg_dump_program_to CSType
VoidT [(CSType -> CSType
RefT (CSType -> CSType) -> CSType -> CSType
forall a b. (a -> b) -> a -> b
$ String -> CSType
CustomT String
cfg, String
"_cfg"),(CSType
stringT, String
"path")]
[CSExp -> CSExp -> CSStmt
Reassign (String -> CSExp
Var String
"_cfg.OpenCL.DumpProgramTo") (String -> CSExp
Var String
"path")]
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt
CS.privateFunDef String
cfg_load_program_from CSType
VoidT [(CSType -> CSType
RefT (CSType -> CSType) -> CSType -> CSType
forall a b. (a -> b) -> a -> b
$ String -> CSType
CustomT String
cfg, String
"_cfg"),(CSType
stringT, String
"path")]
[CSExp -> CSExp -> CSStmt
Reassign (String -> CSExp
Var String
"_cfg.OpenCL.LoadProgramFrom") (String -> CSExp
Var String
"path")]
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt
CS.privateFunDef String
cfg_set_default_group_size CSType
VoidT [(CSType -> CSType
RefT (CSType -> CSType) -> CSType -> CSType
forall a b. (a -> b) -> a -> b
$ String -> CSType
CustomT String
cfg, String
"_cfg"),(CSType
intT, String
"size")]
[CSExp -> CSExp -> CSStmt
Reassign (String -> CSExp
Var String
"_cfg.OpenCL.DefaultGroupSize") (String -> CSExp
Var String
"size")]
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt
CS.privateFunDef String
cfg_set_default_num_groups CSType
VoidT [(CSType -> CSType
RefT (CSType -> CSType) -> CSType -> CSType
forall a b. (a -> b) -> a -> b
$ String -> CSType
CustomT String
cfg, String
"_cfg"),(CSType
intT, String
"num")]
[CSExp -> CSExp -> CSStmt
Reassign (String -> CSExp
Var String
"_cfg.OpenCL.DefaultNumGroups") (String -> CSExp
Var String
"num")]
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt
CS.privateFunDef String
cfg_set_default_tile_size CSType
VoidT [(CSType -> CSType
RefT (CSType -> CSType) -> CSType -> CSType
forall a b. (a -> b) -> a -> b
$ String -> CSType
CustomT String
cfg, String
"_cfg"),(CSType
intT, String
"size")]
[CSExp -> CSExp -> CSStmt
Reassign (String -> CSExp
Var String
"_cfg.OpenCL.DefaultTileSize") (String -> CSExp
Var String
"size")]
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt
CS.privateFunDef String
cfg_set_default_threshold CSType
VoidT [(CSType -> CSType
RefT (CSType -> CSType) -> CSType -> CSType
forall a b. (a -> b) -> a -> b
$ String -> CSType
CustomT String
cfg, String
"_cfg"),(CSType
intT, String
"size")]
[CSExp -> CSExp -> CSStmt
Reassign (String -> CSExp
Var String
"_cfg.OpenCL.DefaultThreshold") (String -> CSExp
Var String
"size")]
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt
CS.privateFunDef String
cfg_set_size (CSPrim -> CSType
Primitive CSPrim
BoolT) [(CSType -> CSType
RefT (CSType -> CSType) -> CSType -> CSType
forall a b. (a -> b) -> a -> b
$ String -> CSType
CustomT String
cfg, String
"_cfg")
, (CSType
stringT, String
"SizeName")
, (CSType
intT, String
"SizeValue")]
[ String -> CSExp -> [CSStmt] -> CSStmt
AST.For String
"i" ((Integer -> CSExp
Integer (Integer -> CSExp) -> (Int -> Integer) -> Int -> CSExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger) (Int -> CSExp) -> Int -> CSExp
forall a b. (a -> b) -> a -> b
$ Map Name SizeClass -> Int
forall k a. Map k a -> Int
M.size Map Name SizeClass
sizes)
[ CSExp -> [CSStmt] -> [CSStmt] -> CSStmt
If (String -> CSExp -> CSExp -> CSExp
BinOp String
"==" (String -> CSExp
Var String
"SizeName") (CSExp -> CSIdx -> CSExp
Index (String -> CSExp
Var String
"SizeNames") (CSExp -> CSIdx
IdxExp (String -> CSExp
Var String
"i"))))
[ CSExp -> CSExp -> CSStmt
Reassign (CSExp -> CSIdx -> CSExp
Index (String -> CSExp
Var String
"_cfg.Sizes") (CSExp -> CSIdx
IdxExp (String -> CSExp
Var String
"i"))) (String -> CSExp
Var String
"SizeValue")
, CSExp -> CSStmt
Return (Bool -> CSExp
AST.Bool Bool
True)] []
]
, CSExp -> CSStmt
Return (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ Bool -> CSExp
AST.Bool Bool
False ]
let ctx_ :: String
ctx_ = String -> String
CS.publicName String
"Context"
let new_ctx :: String
new_ctx = String -> String
CS.publicName String
"ContextNew"
let sync_ctx :: String
sync_ctx = String -> String
CS.publicName String
"ContextSync"
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ String -> [(CSType, String)] -> CSStmt
StructDef String
ctx_ ([(CSType, String)] -> CSStmt) -> [(CSType, String)] -> CSStmt
forall a b. (a -> b) -> a -> b
$
[ (CSPrim -> CSType
Primitive CSPrim
IntPtrT, String
"NULL")
, (String -> CSType
CustomT String
"CLMemoryHandle", String
"EMPTY_MEM_HANDLE")
, (String -> CSType
CustomT String
"OpenCLFreeList", String
"FreeList")
, (CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int64T, String
"CurrentMemUsageDevice")
, (CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int64T, String
"PeakMemUsageDevice")
, (CSPrim -> CSType
Primitive CSPrim
BoolT, String
"DetailMemory")
, (CSPrim -> CSType
Primitive CSPrim
BoolT, String
"Debugging")
, (String -> CSType
CustomT String
"CLMemoryHandle", String
"GlobalFailure")
, (CSType
intT, String
"GlobalFailureIsAnOption")
, (String -> CSType
CustomT String
"CLMemoryHandle", String
"GlobalFailureArgs")
, (String -> CSType
CustomT String
"OpenCLContext", String
"OpenCL")
, (String -> CSType
CustomT String
"Sizes", String
"Sizes") ]
[(CSType, String)] -> [(CSType, String)] -> [(CSType, String)]
forall a. [a] -> [a] -> [a]
++ [(CSType, String)]
opencl_fields
(CSStmt -> CompilerM OpenCL () ())
-> [CSStmt] -> CompilerM OpenCL () ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm [CSStmt]
later_top_decls
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.addMemberDecl (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped (String -> CSType
CustomT String
cfg) (String -> CSExp
Var String
"Cfg") Maybe CSExp
forall a. Maybe a
Nothing
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.addMemberDecl (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped (String -> CSType
CustomT String
ctx_) (String -> CSExp
Var String
"Ctx") Maybe CSExp
forall a. Maybe a
Nothing
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.beforeParse (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ CSExp -> CSExp -> CSStmt
Reassign (String -> CSExp
Var String
"Cfg") (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
CS.simpleCall String
new_cfg []
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.atInit (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
CS.simpleCall String
new_ctx [String -> CSExp
Var String
"Cfg"]
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.atInit (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ CSExp -> CSExp -> CSStmt
Reassign (String -> CSExp
Var String
"Ctx.EMPTY_MEM_HANDLE") (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
CS.simpleCall String
"EmptyMemHandle" [String -> CSExp
Var String
"Ctx.OpenCL.Context"]
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.atInit (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ CSExp -> CSExp -> CSStmt
Reassign (String -> CSExp
Var String
"Ctx.FreeList") (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
CS.simpleCall String
"OpenCLFreeListInit" []
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.addMemberDecl (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped (CSPrim -> CSType
Primitive CSPrim
BoolT) (String -> CSExp
Var String
"Synchronous") (CSExp -> Maybe CSExp
forall a. a -> Maybe a
Just (CSExp -> Maybe CSExp) -> CSExp -> Maybe CSExp
forall a b. (a -> b) -> a -> b
$ Bool -> CSExp
AST.Bool Bool
False)
let set_required_types :: [CSStmt]
set_required_types = [CSExp -> CSExp -> CSStmt
Reassign (String -> CSExp
Var String
"RequiredTypes") (Bool -> CSExp
AST.Bool Bool
True)
| FloatType -> PrimType
FloatType FloatType
Float64 PrimType -> [PrimType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PrimType]
types]
set_sizes :: [CSStmt]
set_sizes = (Int -> Name -> CSStmt) -> [Int] -> [Name] -> [CSStmt]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i Name
k -> CSExp -> CSExp -> CSStmt
Reassign (CSExp -> String -> CSExp
Field (String -> CSExp
Var String
"Ctx.Sizes") (String -> String
zEncodeString (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Pretty a => a -> String
pretty Name
k))
(CSExp -> CSIdx -> CSExp
Index (String -> CSExp
Var String
"Cfg.Sizes") (CSExp -> CSIdx
IdxExp (CSExp -> CSIdx) -> CSExp -> CSIdx
forall a b. (a -> b) -> a -> b
$ (Integer -> CSExp
Integer (Integer -> CSExp) -> (Int -> Integer) -> Int -> CSExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger) Int
i)))
[(Int
0::Int)..] ([Name] -> [CSStmt]) -> [Name] -> [CSStmt]
forall a b. (a -> b) -> a -> b
$ Map Name SizeClass -> [Name]
forall k a. Map k a -> [k]
M.keys Map Name SizeClass
sizes
max_failure_args :: Int
max_failure_args =
(Int -> Int -> Int) -> Int -> [Int] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (FailureMsg -> Int) -> [FailureMsg] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (ErrorMsg Exp -> Int
forall a. ErrorMsg a -> Int
errorMsgNumArgs (ErrorMsg Exp -> Int)
-> (FailureMsg -> ErrorMsg Exp) -> FailureMsg -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FailureMsg -> ErrorMsg Exp
failureError) [FailureMsg]
failures
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt
CS.privateFunDef String
new_ctx CSType
VoidT [(String -> CSType
CustomT String
cfg, String
"Cfg")] ([CSStmt] -> CSStmt) -> [CSStmt] -> CSStmt
forall a b. (a -> b) -> a -> b
$
[ CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped (String -> CSType
CustomT String
"ComputeErrorCode") (String -> CSExp
Var String
"error") Maybe CSExp
forall a. Maybe a
Nothing
, CSExp -> CSExp -> CSStmt
Reassign (String -> CSExp
Var String
"Ctx.DetailMemory") (String -> CSExp
Var String
"Cfg.OpenCL.Debugging")
, CSExp -> CSExp -> CSStmt
Reassign (String -> CSExp
Var String
"Ctx.Debugging") (String -> CSExp
Var String
"Cfg.OpenCL.Debugging")
, CSExp -> CSExp -> CSStmt
Reassign (String -> CSExp
Var String
"Ctx.OpenCL.Cfg") (String -> CSExp
Var String
"Cfg.OpenCL")]
[CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
opencl_inits [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++
[ CSExp -> CSExp -> CSStmt
Assign (String -> CSExp
Var String
"RequiredTypes") (Bool -> CSExp
AST.Bool Bool
False) ]
[CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
set_required_types [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++
[ CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped (String -> CSType
CustomT String
"CLProgramHandle") (String -> CSExp
Var String
"prog")
(CSExp -> Maybe CSExp
forall a. a -> Maybe a
Just (CSExp -> Maybe CSExp) -> CSExp -> Maybe CSExp
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
CS.simpleCall String
"SetupOpenCL" [ CSExp -> CSExp
Ref (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ String -> CSExp
Var String
"Ctx"
, String -> CSExp
Var String
"OpenCLProgram"
, String -> CSExp
Var String
"RequiredTypes"])] [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++
[ CSExp -> CSExp -> CSStmt
Reassign (String -> CSExp
Var String
"Ctx.GlobalFailureIsAnOption") (Integer -> CSExp
Integer Integer
0)
, [CSStmt] -> CSStmt
Unsafe
[ CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
CS.simpleCall String
"OPENCL_SUCCEED"
[String -> [CSExp] -> CSExp
CS.simpleCall String
"OpenCLAllocActual" [ CSExp -> CSExp
Ref (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ String -> CSExp
Var String
"Ctx"
, Integer -> CSExp
Integer Integer
4
, CSExp -> CSExp
Ref (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ String -> CSExp
Var String
"Ctx.GlobalFailure"]]
, CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped CSType
intT (String -> CSExp
Var String
"no_failure") (CSExp -> Maybe CSExp
forall a. a -> Maybe a
Just (Integer -> CSExp
Integer (-Integer
1)))
, CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
CS.simpleCall String
"OPENCL_SUCCEED"
[String -> [CSExp] -> CSExp
CS.simpleCall String
"CL10.EnqueueWriteBuffer"
[ String -> CSExp
Var String
"Ctx.OpenCL.Queue", String -> CSExp
Var String
"Ctx.GlobalFailure", Bool -> CSExp
AST.Bool Bool
True
, CSExp -> CSExp
CS.toIntPtr (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ Integer -> CSExp
Integer Integer
0
, CSExp -> CSExp
CS.toIntPtr (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ Integer -> CSExp
Integer Integer
4
, CSExp -> CSExp
CS.toIntPtr (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ CSExp -> CSExp
Addr (String -> CSExp
Var String
"no_failure")
, Integer -> CSExp
Integer Integer
0, CSExp
Null, CSExp
Null]]
, CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
CS.simpleCall String
"OPENCL_SUCCEED"
[String -> [CSExp] -> CSExp
CS.simpleCall String
"OpenCLAllocActual" [ CSExp -> CSExp
Ref (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ String -> CSExp
Var String
"Ctx"
, Integer -> CSExp
Integer (Integer -> CSExp) -> Integer -> CSExp
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
max_failure_args Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
, CSExp -> CSExp
Ref (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ String -> CSExp
Var String
"Ctx.GlobalFailureArgs"]]]]
[CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ ((String, Safety) -> [CSStmt]) -> [(String, Safety)] -> [CSStmt]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, Safety) -> [CSStmt]
loadKernel (Map String Safety -> [(String, Safety)]
forall k a. Map k a -> [(k, a)]
M.toList Map String Safety
kernels)
[CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
final_inits
[CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
set_sizes
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.stm (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt
CS.privateFunDef String
sync_ctx CSType
VoidT []
[ CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped CSType
intT (String -> CSExp
Var String
"failure_idx") (CSExp -> Maybe CSExp
forall a. a -> Maybe a
Just (CSExp -> Maybe CSExp) -> CSExp -> Maybe CSExp
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
CS.simpleInitClass (CSType -> String
forall a. Pretty a => a -> String
pretty CSType
intT) [])
, [CSStmt] -> CSStmt
Unsafe [ CSExp -> CSExp -> CSStmt
CS.assignScalarPointer (String -> CSExp
Var String
"failure_idx") (String -> CSExp
Var String
"ptr")
, CSExp -> CSExp -> CSStmt
Reassign (String -> CSExp
Var String
"Ctx.GlobalFailureIsAnOption") (Integer -> CSExp
Integer Integer
0)
, CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
CS.simpleCall String
"OPENCL_SUCCEED" [
String -> [CSExp] -> CSExp
CS.simpleCall String
"CL10.EnqueueReadBuffer"
[ String -> CSExp
Var String
"Ctx.OpenCL.Queue", String -> CSExp
Var String
"Ctx.GlobalFailure", Bool -> CSExp
AST.Bool Bool
True
, CSExp -> CSExp
CS.toIntPtr (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ Integer -> CSExp
Integer Integer
0
, CSExp -> CSExp
CS.toIntPtr (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ Integer -> CSExp
Integer Integer
4
, CSExp -> CSExp
CS.toIntPtr (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ String -> CSExp
Var String
"ptr"
, Integer -> CSExp
Integer Integer
0, CSExp
Null, CSExp
Null]
]
]
, CSExp -> [CSStmt] -> [CSStmt] -> CSStmt
If (String -> CSExp -> CSExp -> CSExp
BinOp String
"!=" (String -> CSExp
Var String
"failure_idx") (Integer -> CSExp
Integer (-Integer
1)))
([ CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped CSType
intArrayT (String -> CSExp
Var String
"args") (Maybe CSExp -> CSStmt) -> Maybe CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ CSExp -> Maybe CSExp
forall a. a -> Maybe a
Just (CSExp -> Maybe CSExp) -> CSExp -> Maybe CSExp
forall a b. (a -> b) -> a -> b
$ CSType -> Either Int [CSExp] -> CSExp
CreateArray CSType
intT (Either Int [CSExp] -> CSExp) -> Either Int [CSExp] -> CSExp
forall a b. (a -> b) -> a -> b
$
Int -> Either Int [CSExp]
forall a b. a -> Either a b
Left (Int -> Either Int [CSExp]) -> Int -> Either Int [CSExp]
forall a b. (a -> b) -> a -> b
$ Int
max_failure_args Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
, [CSStmt] -> CSStmt
Unsafe [
CSExp -> CSExp -> [CSStmt] -> CSStmt
Fixed (String -> CSExp
Var String
"ptr") (CSExp -> CSExp
Addr (CSExp -> CSIdx -> CSExp
Index (String -> CSExp
Var String
"args") (CSIdx -> CSExp) -> CSIdx -> CSExp
forall a b. (a -> b) -> a -> b
$ CSExp -> CSIdx
IdxExp (CSExp -> CSIdx) -> CSExp -> CSIdx
forall a b. (a -> b) -> a -> b
$ Integer -> CSExp
Integer Integer
0))
[CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
CS.simpleCall String
"CL10.EnqueueReadBuffer"
[ String -> CSExp
Var String
"Ctx.OpenCL.Queue", String -> CSExp
Var String
"Ctx.GlobalFailureArgs", Bool -> CSExp
AST.Bool Bool
True
, CSExp -> CSExp
CS.toIntPtr (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ Integer -> CSExp
Integer Integer
0
, CSExp -> CSExp
CS.toIntPtr (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ Integer -> CSExp
Integer (Integer -> CSExp) -> Integer -> CSExp
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
max_failure_args
, CSExp -> CSExp
CS.toIntPtr (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ String -> CSExp
Var String
"ptr"
, Integer -> CSExp
Integer Integer
0, CSExp
Null, CSExp
Null]]]] [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++
(Integer -> FailureMsg -> CSStmt)
-> [Integer] -> [FailureMsg] -> [CSStmt]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Integer -> FailureMsg -> CSStmt
failureCase [Integer
0..] [FailureMsg]
failures)
[]
]
CSStmt -> CompilerM OpenCL () ()
forall op s. CSStmt -> CompilerM op s ()
CS.debugReport (CSStmt -> CompilerM OpenCL () ())
-> CSStmt -> CompilerM OpenCL () ()
forall a b. (a -> b) -> a -> b
$ [String] -> CSStmt
openClReport ([String] -> CSStmt) -> [String] -> CSStmt
forall a b. (a -> b) -> a -> b
$ Map String Safety -> [String]
forall k a. Map k a -> [k]
M.keys Map String Safety
kernels
openClDecls :: M.Map KernelName Safety -> String -> String
-> ([(CSType, String)], [CSStmt], CSStmt, [CSStmt])
openClDecls :: Map String Safety
-> String
-> String
-> ([(CSType, String)], [CSStmt], CSStmt, [CSStmt])
openClDecls Map String Safety
kernels String
opencl_program String
opencl_prelude =
([(CSType, String)]
ctx_fields, [CSStmt]
ctx_inits, CSStmt
openCL_boilerplate, [CSStmt]
openCL_load)
where ctx_fields :: [(CSType, String)]
ctx_fields =
[ (CSType
intT, String
"TotalRuns")
, (CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int64T, String
"TotalRuntime")]
[(CSType, String)] -> [(CSType, String)] -> [(CSType, String)]
forall a. [a] -> [a] -> [a]
++ (String -> [(CSType, String)]) -> [String] -> [(CSType, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
name -> [(String -> CSType
CustomT String
"CLKernelHandle", String
name)
,(CSType
longT, String -> String
kernelRuntime String
name)
,(CSType
intT, String -> String
kernelRuns String
name)])
(Map String Safety -> [String]
forall k a. Map k a -> [k]
M.keys Map String Safety
kernels)
ctx_inits :: [CSStmt]
ctx_inits =
[ CSExp -> CSExp -> CSStmt
Reassign (String -> CSExp
Var (String -> CSExp) -> String -> CSExp
forall a b. (a -> b) -> a -> b
$ String -> String
ctx String
"TotalRuns") (Integer -> CSExp
Integer Integer
0)
, CSExp -> CSExp -> CSStmt
Reassign (String -> CSExp
Var (String -> CSExp) -> String -> CSExp
forall a b. (a -> b) -> a -> b
$ String -> String
ctx String
"TotalRuntime") (Integer -> CSExp
Integer Integer
0) ]
[CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ (String -> [CSStmt]) -> [String] -> [CSStmt]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
name -> [ CSExp -> CSExp -> CSStmt
Reassign (String -> CSExp
Var (String -> CSExp) -> String -> CSExp
forall a b. (a -> b) -> a -> b
$ (String -> String
ctx (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
kernelRuntime) String
name) (Integer -> CSExp
Integer Integer
0)
, CSExp -> CSExp -> CSStmt
Reassign (String -> CSExp
Var (String -> CSExp) -> String -> CSExp
forall a b. (a -> b) -> a -> b
$ (String -> String
ctx (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
kernelRuns) String
name) (Integer -> CSExp
Integer Integer
0)])
(Map String Safety -> [String]
forall k a. Map k a -> [k]
M.keys Map String Safety
kernels)
futhark_context :: String
futhark_context = String -> String
CS.publicName String
"Context"
openCL_load :: [CSStmt]
openCL_load = [String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt
CS.privateFunDef String
"PostOpenCLSetup" CSType
VoidT
[ (CSType -> CSType
RefT (CSType -> CSType) -> CSType -> CSType
forall a b. (a -> b) -> a -> b
$ String -> CSType
CustomT String
futhark_context, String
"Ctx")
, (CSType -> CSType
RefT (CSType -> CSType) -> CSType -> CSType
forall a b. (a -> b) -> a -> b
$ String -> CSType
CustomT String
"OpenCLDeviceOption", String
"Option")] ([CSStmt] -> CSStmt) -> [CSStmt] -> CSStmt
forall a b. (a -> b) -> a -> b
$ (SizeHeuristic -> CSStmt) -> [SizeHeuristic] -> [CSStmt]
forall a b. (a -> b) -> [a] -> [b]
map SizeHeuristic -> CSStmt
sizeHeuristicsCode [SizeHeuristic]
sizeHeuristicsTable]
openCL_boilerplate :: CSStmt
openCL_boilerplate =
CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped CSType
stringArrayT (String -> CSExp
Var String
"OpenCLProgram")
(CSExp -> Maybe CSExp
forall a. a -> Maybe a
Just (CSExp -> Maybe CSExp) -> CSExp -> Maybe CSExp
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
Collection String
"string[]" [String -> CSExp
String (String -> CSExp) -> String -> CSExp
forall a b. (a -> b) -> a -> b
$ String
opencl_prelude String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
opencl_program])
loadKernel :: (String, Safety) -> [CSStmt]
loadKernel :: (String, Safety) -> [CSStmt]
loadKernel (String
name, Safety
_) =
[ CSExp -> CSExp -> CSStmt
Reassign (String -> CSExp
Var (String -> CSExp) -> String -> CSExp
forall a b. (a -> b) -> a -> b
$ String -> String
ctx String
name)
(String -> [CSExp] -> CSExp
CS.simpleCall String
"CL10.CreateKernel" [String -> CSExp
Var String
"prog", String -> CSExp
String String
name, CSExp -> CSExp
Out (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ String -> CSExp
Var String
"error"])
, CSExp -> [CSExp] -> CSStmt
AST.Assert (String -> CSExp -> CSExp -> CSExp
BinOp String
"==" (String -> CSExp
Var String
"error") (Integer -> CSExp
Integer Integer
0)) []
, CSExp -> [CSStmt] -> [CSStmt] -> CSStmt
If (String -> CSExp
Var String
"Ctx.Debugging")
[CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
consoleErrorWriteLine String
"Created kernel {0}" [String -> CSExp
Var (String -> CSExp) -> String -> CSExp
forall a b. (a -> b) -> a -> b
$ String -> String
ctx String
name]]
[]
]
kernelRuntime :: String -> String
kernelRuntime :: String -> String
kernelRuntime = (String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"_TotalRuntime")
kernelRuns :: String -> String
kernelRuns :: String -> String
kernelRuns = (String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"_Runs")
openClReport :: [String] -> CSStmt
openClReport :: [String] -> CSStmt
openClReport [String]
names =
CSExp -> [CSStmt] -> [CSStmt] -> CSStmt
If (String -> CSExp
Var String
"Ctx.Debugging") ([CSStmt]
report_kernels [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt
report_total]) []
where longest_name :: Int
longest_name = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
names
report_kernels :: [CSStmt]
report_kernels = (String -> CSStmt) -> [String] -> [CSStmt]
forall a b. (a -> b) -> [a] -> [b]
map String -> CSStmt
reportKernel [String]
names
format_string :: String -> String
format_string String
name =
let padding :: String
padding = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
longest_name Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name) Char
' '
in [String] -> String
unwords [String
"Kernel",
String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
padding,
String
"executed {0} times, with average runtime: {1}\tand total runtime: {2}"]
reportKernel :: String -> CSStmt
reportKernel String
name =
let runs :: String
runs = String -> String
ctx (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
kernelRuns String
name
total_runtime :: String
total_runtime = String -> String
ctx (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
kernelRuntime String
name
in CSExp -> [CSStmt] -> [CSStmt] -> CSStmt
If (String -> CSExp -> CSExp -> CSExp
BinOp String
"!=" (String -> CSExp
Var String
runs) (Integer -> CSExp
Integer Integer
0))
[CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
consoleErrorWriteLine (String -> String
format_string String
name)
[ String -> CSExp
Var String
runs
, CSExp -> CSExp -> CSExp -> CSExp
Ternary (String -> CSExp -> CSExp -> CSExp
BinOp String
"!="
(String -> CSExp -> CSExp -> CSExp
BinOp String
"/"
(CSType -> CSExp -> CSExp
Cast (CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int64T) (String -> CSExp
Var String
total_runtime))
(String -> CSExp
Var String
runs))
(Integer -> CSExp
Integer Integer
0))
(String -> CSExp
Var String
runs) (Integer -> CSExp
Integer Integer
1)
, CSType -> CSExp -> CSExp
Cast (CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int64T) (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ String -> CSExp
Var String
total_runtime]
, String -> CSExp -> CSExp -> CSStmt
AssignOp String
"+" (String -> CSExp
Var (String -> CSExp) -> String -> CSExp
forall a b. (a -> b) -> a -> b
$ String -> String
ctx String
"TotalRuntime") (String -> CSExp
Var String
total_runtime)
, String -> CSExp -> CSExp -> CSStmt
AssignOp String
"+" (String -> CSExp
Var (String -> CSExp) -> String -> CSExp
forall a b. (a -> b) -> a -> b
$ String -> String
ctx String
"TotalRuns") (String -> CSExp
Var String
runs)
] []
ran_text :: String
ran_text = String
"Ran {0} kernels with cumulative runtime: {1}"
report_total :: CSStmt
report_total = CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
consoleErrorWriteLine String
ran_text [ String -> CSExp
Var (String -> CSExp) -> String -> CSExp
forall a b. (a -> b) -> a -> b
$ String -> String
ctx String
"TotalRuns"
, String -> CSExp
Var (String -> CSExp) -> String -> CSExp
forall a b. (a -> b) -> a -> b
$ String -> String
ctx String
"TotalRuntime"]
sizeHeuristicsCode :: SizeHeuristic -> CSStmt
sizeHeuristicsCode :: SizeHeuristic -> CSStmt
sizeHeuristicsCode (SizeHeuristic String
platform_name DeviceType
device_type WhichSize
which HeuristicValue
what) =
let which'' :: CSExp
which'' = String -> CSExp -> CSExp -> CSExp
BinOp String
"==" CSExp
which' (Integer -> CSExp
Integer Integer
0)
option_contains_platform_name :: CSExp
option_contains_platform_name = String -> [CSExp] -> CSExp
CS.simpleCall String
"Option.PlatformName.Contains" [String -> CSExp
String String
platform_name]
option_contains_device_type :: CSExp
option_contains_device_type = String -> CSExp -> CSExp -> CSExp
BinOp String
"==" (String -> CSExp
Var String
"Option.DeviceType") (String -> CSExp
Var (String -> CSExp) -> String -> CSExp
forall a b. (a -> b) -> a -> b
$ DeviceType -> String
clDeviceType DeviceType
device_type)
in CSExp -> [CSStmt] -> [CSStmt] -> CSStmt
If (String -> CSExp -> CSExp -> CSExp
BinOp String
"&&" CSExp
which''
(String -> CSExp -> CSExp -> CSExp
BinOp String
"&&" CSExp
option_contains_platform_name
CSExp
option_contains_device_type))
[ CSStmt
get_size ] []
where clDeviceType :: DeviceType -> String
clDeviceType DeviceType
DeviceGPU = String
"ComputeDeviceTypes.Gpu"
clDeviceType DeviceType
DeviceCPU = String
"ComputeDeviceTypes.Cpu"
which' :: CSExp
which' = case WhichSize
which of
WhichSize
LockstepWidth -> String -> CSExp
Var String
"Ctx.OpenCL.LockstepWidth"
WhichSize
NumGroups -> String -> CSExp
Var String
"Ctx.OpenCL.Cfg.DefaultNumGroups"
WhichSize
GroupSize -> String -> CSExp
Var String
"Ctx.OpenCL.Cfg.DefaultGroupSize"
WhichSize
TileSize -> String -> CSExp
Var String
"Ctx.OpenCL.Cfg.DefaultTileSize"
WhichSize
Threshold -> String -> CSExp
Var String
"Ctx.OpenCL.Cfg.DefaultThreshold"
get_size :: CSStmt
get_size = case HeuristicValue
what of
HeuristicConst Int
x ->
CSExp -> CSExp -> CSStmt
Reassign CSExp
which' (Integer -> CSExp
Integer (Integer -> CSExp) -> Integer -> CSExp
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
x)
HeuristicDeviceInfo String
_ ->
[CSStmt] -> CSStmt
Unsafe
[
CSExp -> CSExp -> [CSStmt] -> CSStmt
Fixed (String -> CSExp
Var String
"ptr") (CSExp -> CSExp
Addr CSExp
which')
[
CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ String -> [CSExp] -> CSExp
CS.simpleCall String
"CL10.GetDeviceInfo"
[ String -> CSExp
Var String
"Ctx.OpenCL.Device", String -> CSExp
Var String
"ComputeDeviceInfo.MaxComputeUnits"
, String -> [CSExp] -> CSExp
CS.simpleCall String
"new IntPtr" [String -> [CSExp] -> CSExp
CS.simpleCall String
"Marshal.SizeOf" [CSExp
which']]
, CSExp -> CSExp
CS.toIntPtr (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ String -> CSExp
Var String
"ptr", CSExp -> CSExp
Out CSExp
ctxNULL ]
]
]
ctx :: String -> String
ctx :: String -> String
ctx = String -> String -> String
forall a. [a] -> [a] -> [a]
(++) String
"Ctx."
ctxNULL :: CSExp
ctxNULL :: CSExp
ctxNULL = String -> CSExp
Var String
"Ctx.NULL"