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
_ ->
                       -- This only works for device info that fits in the variable.
                       [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"