1{- 2 THCBackend: generate interface to Flounder THC stubs 3 4 Part of Flounder: a message passing IDL for Barrelfish 5 6 Copyright (c) 2007-2010, ETH Zurich. 7 All rights reserved. 8 9 This file is distributed under the terms in the attached LICENSE file. 10 If you do not find this file, copies can be found by writing to: 11 ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group. 12-} 13 14module THCBackend where 15 16import Data.List 17 18import qualified CAbsSyntax as C 19import qualified BackendCommon as BC 20import Syntax 21import Backend 22 23------------------------------------------------------------------------ 24-- Language mapping: C identifier names 25------------------------------------------------------------------------ 26 27-- Name of the struct holding message args for SAR 28msg_argstruct_name :: String -> String -> String 29msg_argstruct_name ifn n = idscope ifn n "args_t" 30 31rpc_argstruct_name :: String -> String -> String -> String 32rpc_argstruct_name ifn n inout = idscope ifn n (inout ++ "_args_t") 33 34rpc_union_name :: String -> String -> String 35rpc_union_name ifn n = idscope ifn n "_union_t" 36 37-- Name of the enumeration of message numbers 38msg_enum_name :: String -> String 39msg_enum_name ifn = ifscope ifn "msg_enum_t" 40 41call_msg_enum_name :: String -> String 42call_msg_enum_name ifn = ifscope ifn "call_msg_enum_t" 43 44resp_msg_enum_name :: String -> String 45resp_msg_enum_name ifn = ifscope ifn "resp_msg_enum_t" 46 47-- Name of each element of the message number enumeration 48msg_enum_elem_name :: String -> String -> String 49msg_enum_elem_name ifn mn = ifscope ifn mn 50 51call_msg_enum_elem_name :: String -> String -> String 52call_msg_enum_elem_name ifn mn = ifscope ifn ("_call_" ++ mn) 53 54resp_msg_enum_elem_name :: String -> String -> String 55resp_msg_enum_elem_name ifn mn = ifscope ifn ("_resp_" ++ mn) 56 57-- Name of the union type holding all the arguments for a message 58binding_arg_union_type :: String -> String 59binding_arg_union_type ifn = ifscope ifn "thc_arg_union" 60 61-- Scope a list of strings 62ifscope :: String -> String -> String 63ifscope ifn s = ifn ++ "_" ++ s 64 65idscope :: String -> String -> String -> String 66idscope ifn s suffix = ifscope ifn (s ++ "__" ++ suffix) 67 68-- Name of the binding struct for an interface type 69intf_bind_type :: String -> String -> String 70intf_bind_type ifn sender = ifscope ifn $ "thc_" ++ sender ++ "_binding_t" 71 72-- Variable used to refer to a binding 73intf_bind_var = "_thc_binding" 74 75-- Name of the type of a message function 76msg_sig_type :: String -> String -> String -> MessageDef -> String 77msg_sig_type ifn sender sendrecv m = idscope ifn (BC.msg_name m) "thc_" ++ sender ++ "_" ++ sendrecv ++ "_t" 78msg_sig_type_x :: String -> String -> String -> MessageDef -> String 79msg_sig_type_x ifn sender sendrecv m = idscope ifn (BC.msg_name m) "thc_" ++ sender ++ "_" ++ sendrecv ++ "_t_x" 80 81-- Name of the type of an RPC call function 82call_sig_type :: String -> MessageDef -> String 83call_sig_type ifn m@(RPC n _ _) = idscope ifn n "thc_call__t" 84 85call_sig_type_x :: String -> MessageDef -> String 86call_sig_type_x ifn m@(RPC n _ _) = idscope ifn n "thc_call__t_x" 87 88call_ooo_sig_type :: String -> MessageDef -> String 89call_ooo_sig_type ifn m@(RPC n _ _) = idscope ifn n "thc_ooo_call__t" 90 91call_ooo_sig_type_x :: String -> MessageDef -> String 92call_ooo_sig_type_x ifn m@(RPC n _ _) = idscope ifn n "thc_ooo_call__t_x" 93 94-- Name of the type of a receive-any function 95rx_any_sig_type :: String -> String -> String 96rx_any_sig_type ifn receiver = idscope ifn "recv_any" "thc_" ++ receiver ++ "_t" 97 98rx_any_sig_type_x :: String -> String -> String 99rx_any_sig_type_x ifn receiver = idscope ifn "recv_any" "thc_" ++ receiver ++ "_t_x" 100 101-- Name of the structure in which receive-any supplies a message 102rx_any_struct_name :: String -> String -> String 103rx_any_struct_name ifn receiver = ifscope ifn (receiver ++ "_msg") 104 105rx_any_type_name :: String -> String -> String 106rx_any_type_name ifn receiver = ifscope ifn (receiver ++ "_msg_t") 107 108-- Name of the struct type for the method vtable 109intf_vtbl_type :: String -> String -> String -> String 110intf_vtbl_type ifn sender sendrecv = ifscope ifn $ "thc_" ++ sender ++ "_" ++ sendrecv 111 112intf_vtbl_type_x :: String -> String -> String -> String 113intf_vtbl_type_x ifn sender sendrecv = ifscope ifn $ "thc_" ++ sender ++ "_" ++ sendrecv ++ "_x" 114 115intf_selector_type :: String -> String -> String 116intf_selector_type ifn sender = ifscope ifn (sender ++ "_selector") 117 118-- Name of the struct types for the RPC call vtables 119rpc_seq_vtbl_type :: String -> String 120rpc_seq_vtbl_type ifn = ifscope ifn $ "thc_rpc_seq" 121 122rpc_fifo_vtbl_type :: String -> String 123rpc_fifo_vtbl_type ifn = ifscope ifn $ "thc_rpc_fifo" 124 125rpc_ooo_vtbl_type :: String -> String 126rpc_ooo_vtbl_type ifn = ifscope ifn $ "thc_rpc_ooo" 127 128rpc_seq_vtbl_type_x :: String -> String 129rpc_seq_vtbl_type_x ifn = ifscope ifn $ "thc_rpc_seq_x" 130 131rpc_fifo_vtbl_type_x :: String -> String 132rpc_fifo_vtbl_type_x ifn = ifscope ifn $ "thc_rpc_fifo_x" 133 134rpc_ooo_vtbl_type_x :: String -> String 135rpc_ooo_vtbl_type_x ifn = ifscope ifn $ "thc_rpc_ooo_x" 136 137-- Name of a function to initialize a client/server THC binding 138init_client_name :: String -> String 139init_client_name ifn = ifscope ifn $ "thc_init_client" 140 141init_service_name :: String -> String 142init_service_name ifn = ifscope ifn $ "thc_init_service" 143 144-- Type and name for the sequencer used for OOO RPC IDs 145ooo_rpc_seq_type = "thc_seq_t" 146ooo_rpc_seq_name = "ooo_rpc_seq" 147 148-- Type and name for the generic per-binding state 149thc_per_binding_state_struct = "thc_per_binding_state_t" 150thc_per_binding_state_name = "thc_per_binding" 151 152thc_binding_lock_name = "thc_binding_lock" 153 154-- Type and name for the generic per-receivable-message state 155thc_per_recv_state_struct = "thc_per_recv_t" 156thc_per_recv_state_name = "thc_per_recv" 157 158-- Type for the export_info / connect_info struct 159thc_export_info_struct_name ifn = ifscope ifn "thc_export_info" 160thc_export_info_t ifn = C.Struct $ thc_export_info_struct_name ifn 161thc_connect_info_struct_name ifn = ifscope ifn "thc_connect_info" 162thc_connect_info_t ifn = C.Struct $ thc_connect_info_struct_name ifn 163 164-- Names for the THC export/accept/connect functions 165thc_export_fn_name ifn = ifscope ifn "thc_export" 166thc_accept_fn_name ifn = ifscope ifn "thc_accept" 167thc_connect_fn_name ifn = ifscope ifn "thc_connect" 168thc_connect_by_name_fn_name ifn = ifscope ifn "thc_connect_by_name" 169 170------------------------------------------------------------------------ 171-- Language mapping: Create the THC header file for the interface 172------------------------------------------------------------------------ 173 174compile :: String -> String -> Interface -> String 175compile infile outfile interface = 176 unlines $ C.pp_unit $ intf_thc_header_file infile interface 177 178intf_thc_header_file :: String -> Interface -> C.Unit 179intf_thc_header_file infile interface@(Interface name _ _) = 180 let sym = "__" ++ name ++ "_THC_IF_H" 181 in 182 C.IfNDef sym ([ C.Define sym [] "1"] ++ (intf_thc_header_body infile interface)) [] 183 184intf_thc_header_body :: String -> Interface -> [C.Unit] 185intf_thc_header_body infile interface@(Interface name descr decls) = 186 let (types, messages) = partitionTypesMessages decls 187 in [ BC.intf_preamble infile name descr, 188 189 C.IfDef "BARRELFISH" [ C.Include C.Local "thc/thcstubs.h", 190 C.Include C.Local ("if/" ++ name ++ "_defs.h") ] 191 [ C.Include C.Local "thcstubs.h", 192 C.Include C.Local (name ++ ".h") ], 193 C.Blank, 194 C.MultiComment [ "Typedefs for binding structures" ], 195 C.Blank, 196 C.TypeDef (C.Struct $ intf_bind_type name "client") (intf_bind_type name "client"), 197 C.TypeDef (C.Struct $ intf_bind_type name "service") (intf_bind_type name "service"), 198 199 C.Blank, 200 C.MultiComment [ "Struct type for holding the args for each msg" ], 201 C.UnitList [ msg_argstruct name m | m <- messages ], 202 C.Blank, 203 204 C.MultiComment [ "Union type for all message arguments" ], 205 intf_union name messages, 206 C.Blank, 207 208 C.MultiComment [ "Enumerations for message numbers" ], 209 msg_enums msg_enum_name msg_enum_elem_name name messages, 210 msg_enums call_msg_enum_name call_msg_enum_elem_name name [ m | m <- messages, isForward m ], 211 msg_enums resp_msg_enum_name resp_msg_enum_elem_name name [ m | m <- messages, isBackward m ], 212 C.Blank, 213 214 C.Blank, 215 C.MultiComment [ "Signatures for individual send/receive operations" ], 216 C.Blank, 217 C.UnitList [ send_signature ClientSide "client" name m | m <- messages, isForward m ], 218 C.UnitList [ send_signature_x ClientSide "client" name m | m <- messages, isForward m ], 219 C.UnitList [ receive_signature ServerSide "service" name m | m <- messages, isForward m ], 220 C.UnitList [ receive_signature_x ServerSide "service" name m | m <- messages, isForward m ], 221 C.UnitList [ send_signature ServerSide "service" name m | m <- messages, isBackward m ], 222 C.UnitList [ send_signature_x ServerSide "service" name m | m <- messages, isBackward m ], 223 C.UnitList [ receive_signature ClientSide "client" name m | m <- messages, isBackward m ], 224 C.UnitList [ receive_signature_x ClientSide "client" name m | m <- messages, isBackward m ], 225 C.UnitList [ call_signature name m | m <- messages, isRPC m ], 226 C.UnitList [ call_signature_x name m | m <- messages, isRPC m ], 227 C.UnitList [ call_ooo_signature name m | m <- messages, isOOORPC m ], 228 C.UnitList [ call_ooo_signature_x name m | m <- messages, isOOORPC m ], 229 230 C.Blank, 231 C.MultiComment [ "VTables of send/receive operations" ], 232 C.Blank, 233 C.StructDecl (intf_vtbl_type name "client" "send_vtbl") [ intf_vtbl_op name "client" "send" m | m <- messages, isForward m] , 234 C.StructDecl (intf_vtbl_type_x name "client" "send_vtbl") [ intf_vtbl_op_x name "client" "send" m | m <- messages, isForward m] , 235 C.StructDecl (intf_vtbl_type name "service" "receive_vtbl") [ intf_vtbl_op name "service" "recv" m | m <- messages, isForward m] , 236 C.StructDecl (intf_vtbl_type_x name "service" "receive_vtbl") [ intf_vtbl_op_x name "service" "recv" m | m <- messages, isForward m] , 237 C.StructDecl (intf_selector_type name "service") [ intf_selector_op name "service" "receive_handler" m | m <- messages, isForward m] , 238 C.StructDecl (intf_vtbl_type name "service" "send_vtbl") [ intf_vtbl_op name "service" "send" m | m <- messages, isBackward m] , 239 C.StructDecl (intf_vtbl_type_x name "service" "send_vtbl") [ intf_vtbl_op_x name "service" "send" m | m <- messages, isBackward m] , 240 C.StructDecl (intf_vtbl_type name "client" "receive_vtbl") [ intf_vtbl_op name "client" "recv" m | m <- messages, isBackward m] , 241 C.StructDecl (intf_vtbl_type_x name "client" "receive_vtbl") [ intf_vtbl_op_x name "client" "recv" m | m <- messages, isBackward m] , 242 C.StructDecl (intf_selector_type name "client") [ intf_selector_op name "client" "receive_handler" m | m <- messages, isBackward m] , 243 244 C.Blank, 245 C.MultiComment [ "VTables of RPC operations" ], 246 C.Blank, 247 C.StructDecl (rpc_seq_vtbl_type name) [ rpc_seq_vtbl_op name m | m <- messages, isRPC m ], 248 C.StructDecl (rpc_seq_vtbl_type_x name) [ rpc_seq_vtbl_op_x name m | m <- messages, isRPC m ], 249 C.StructDecl (rpc_fifo_vtbl_type name) [ rpc_fifo_vtbl_op name m | m <- messages, isRPC m ], 250 C.StructDecl (rpc_fifo_vtbl_type_x name) [ rpc_fifo_vtbl_op_x name m | m <- messages, isRPC m ], 251 C.StructDecl (rpc_ooo_vtbl_type name) [ rpc_ooo_vtbl_op name m | m <- messages, isOOORPC m ], 252 C.StructDecl (rpc_ooo_vtbl_type_x name) [ rpc_ooo_vtbl_op_x name m | m <- messages, isOOORPC m ], 253 254 C.Blank, 255 C.MultiComment [ "Types for recv_any operations" ], 256 C.Blank, 257 C.UnitList [ receive_any_types name "client" ], 258 C.UnitList [ receive_any_types name "service" ], 259 260 C.Blank, 261 C.MultiComment [ "Binding structures" ], 262 C.Blank, 263 C.UnitList [ binding_struct ClientSide name [ m | m <- messages, isBackward m ] ], 264 C.UnitList [ binding_struct ServerSide name [ m | m <- messages, isForward m ] ], 265 266 C.Blank, 267 C.MultiComment [ "Initialize a THC binding over an IDC binding", 268 "(defined in THC-stubs backend)" ], 269 C.Blank, 270 C.GVarDecl C.Extern C.NonConst 271 (C.Function C.NoScope (C.TypeName "errval_t") [ 272 C.Param (C.Ptr $ C.TypeName $ intf_bind_type name "client") "thc", 273 C.Param (C.Ptr $ C.Struct $ BC.intf_bind_type name) "idc_c2s", 274 C.Param (C.Ptr $ C.Struct $ BC.intf_bind_type name) "idc_s2c" 275 ]) (init_client_name name) Nothing, 276 C.GVarDecl C.Extern C.NonConst 277 (C.Function C.NoScope (C.TypeName "errval_t") [ 278 C.Param (C.Ptr $ C.TypeName $ intf_bind_type name "service") "thc", 279 C.Param (C.Ptr $ C.Struct $ BC.intf_bind_type name) "idc_c2s", 280 C.Param (C.Ptr $ C.Struct $ BC.intf_bind_type name) "idc_s2c" 281 ]) (init_service_name name) Nothing, 282 283 C.Blank, 284 C.MultiComment [ "THC helper functions for establishing connections" ], 285 C.StructDecl (thc_export_info_struct_name name) [ 286 C.Param (C.TypeName "thc_sem_t") "export_cb_done_sem", 287 C.Param (C.TypeName "thc_sem_t") "connect_cb_done_sem", 288 C.Param (C.TypeName "thc_sem_t") "accept_call_present_sem", 289 C.Param (C.TypeName "thc_lock_t") "next_accept_lock", 290 C.Param (C.Ptr $ C.Ptr $ C.Struct $ BC.intf_bind_type name) "b", 291 C.Param (C.TypeName "thc_lock_t") "info_lock", 292 C.Param (C.TypeName "errval_t") "err", 293 C.Param (C.ConstT $ C.Ptr $ C.TypeName "char") "service_name", 294 C.Param (C.TypeName "iref_t") "iref", 295 C.Param (C.Ptr $ C.TypeName "iref_t") "iref_ptr" 296 ], 297 C.StructDecl (thc_connect_info_struct_name name) [ 298 C.Param (C.TypeName "thc_sem_t") "bind_cb_done_sem", 299 C.Param (C.TypeName "errval_t") "err", 300 C.Param (C.Ptr $ C.Struct $ BC.intf_bind_type name) "b" 301 ], 302 C.GVarDecl C.Extern C.NonConst 303 (C.Function C.NoScope (C.TypeName "errval_t") [ 304 C.Param (C.Ptr $ thc_export_info_t name) "info", 305 C.Param (C.ConstT $ C.Ptr $ C.TypeName "char") "service_name", 306 C.Param (C.Ptr $ C.Struct "waitset") "ws", 307 C.Param (C.TypeName "idc_export_flags_t") "flags", 308 C.Param (C.Ptr $ C.TypeName "iref_t") "iref" 309 ]) (thc_export_fn_name name) Nothing, 310 C.GVarDecl C.Extern C.NonConst 311 (C.Function C.NoScope (C.TypeName "errval_t") [ 312 C.Param (C.Ptr $ thc_export_info_t name) "info", 313 C.Param (C.Ptr $ C.Ptr $ C.Struct $ BC.intf_bind_type name) "b" 314 ]) (thc_accept_fn_name name) Nothing, 315 C.GVarDecl C.Extern C.NonConst 316 (C.Function C.NoScope (C.TypeName "errval_t") [ 317 C.Param (C.TypeName "iref_t") "iref", 318 C.Param (C.Ptr $ C.Struct "waitset") "ws", 319 C.Param (C.TypeName "idc_bind_flags_t") "flags", 320 C.Param (C.Ptr $ C.Ptr $ C.Struct $ BC.intf_bind_type name) "b" 321 ]) (thc_connect_fn_name name) Nothing, 322 C.GVarDecl C.Extern C.NonConst 323 (C.Function C.NoScope (C.TypeName "errval_t") [ 324 C.Param (C.ConstT $ C.Ptr $ C.TypeName "char") "service_name", 325 C.Param (C.Ptr $ C.Struct "waitset") "ws", 326 C.Param (C.TypeName "idc_bind_flags_t") "flags", 327 C.Param (C.Ptr $ C.Ptr $ C.Struct $ BC.intf_bind_type name) "b" 328 ]) (thc_connect_by_name_fn_name name) Nothing 329 330 ] 331 332isRPC :: MessageDef -> Bool 333isRPC (RPC _ _ _) = True 334isRPC _ = False 335 336isOOORPC :: MessageDef -> Bool 337isOOORPC (RPC _ ((RPCArgIn (Builtin UInt64) (Name "seq_in")):(RPCArgOut (Builtin UInt64) (Name "seq_out")):_) _) = True 338isOOORPC _ = False 339 340binding_struct :: Side -> String -> [MessageDef] -> C.Unit 341binding_struct side ifn messages = 342 let end = (case side of 343 ClientSide -> "client" 344 ServerSide -> "service") 345 nmessages = length messages 346 rpcparams ServerSide = [] 347 rpcparams ClientSide = [C.Param (C.Struct $ rpc_seq_vtbl_type ifn) "call_seq", 348 C.Param (C.Struct $ rpc_fifo_vtbl_type ifn) "call_fifo", 349 C.Param (C.Struct $ rpc_ooo_vtbl_type ifn) "call", 350 C.Param (C.Struct $ rpc_seq_vtbl_type_x ifn) "call_seq_x", 351 C.Param (C.Struct $ rpc_fifo_vtbl_type_x ifn) "call_fifo_x", 352 C.Param (C.Struct $ rpc_ooo_vtbl_type_x ifn) "call_x", 353 C.Param (C.TypeName $ ooo_rpc_seq_type) ooo_rpc_seq_name 354 ] 355 in 356 C.StructDecl (intf_bind_type ifn end) $ concat [ 357 [C.Param (C.Struct $ thc_per_binding_state_struct) thc_per_binding_state_name], 358 [C.Param (C.Struct $ intf_vtbl_type ifn end "send_vtbl") "send"], 359 [C.Param (C.Struct $ intf_vtbl_type_x ifn end "send_vtbl") "send_x"], 360 [C.Param (C.Struct $ intf_vtbl_type ifn end "receive_vtbl") "recv"], 361 [C.Param (C.Struct $ intf_vtbl_type_x ifn end "receive_vtbl") "recv_x"], 362 [C.Param (C.TypeName $ rx_any_sig_type ifn end) "recv_any"], 363 [C.Param (C.TypeName $ rx_any_sig_type_x ifn end) "recv_any_x"], 364 rpcparams side, 365 [C.Param (C.Array (fromIntegral nmessages) $ C.Struct $ thc_per_recv_state_struct) thc_per_recv_state_name], 366 [C.Param (C.Ptr $ C.TypeName "void") "_c2s_st"], 367 [C.Param (C.Ptr $ C.TypeName "void") "_s2c_st"] 368 ] 369 370receive_any_types :: String -> String -> C.Unit 371receive_any_types ifn receiver = 372 let 373 params = [ C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifn receiver) intf_bind_var, 374 C.Param (C.Ptr $ C.Struct $ rx_any_struct_name ifn receiver) "msg", 375 C.Param (C.Struct $ intf_selector_type ifn receiver) "ops" ] 376 rx_t_name = rx_any_sig_type ifn receiver 377 rx_t_name_x = rx_any_sig_type_x ifn receiver 378 in 379 C.UnitList [ 380 C.StructDecl (rx_any_struct_name ifn receiver) 381 [ C.Param (C.Enum $ msg_enum_name ifn) "msg", 382 C.Param (C.Union $ binding_arg_union_type ifn ) "args" 383 ], 384 C.TypeDef (C.Struct $ rx_any_struct_name ifn receiver) (rx_any_type_name ifn receiver), 385 C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) ("(*" ++ rx_t_name ++ ")"), 386 C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) ("(*" ++ rx_t_name_x ++ ")") 387 ] 388 389rpc_seq_vtbl_op :: String -> MessageDef -> C.Param 390rpc_seq_vtbl_op ifn m@(RPC n _ _) = 391 C.Param (C.TypeName $ call_sig_type ifn m) n 392 393rpc_fifo_vtbl_op :: String -> MessageDef -> C.Param 394rpc_fifo_vtbl_op ifn m@(RPC n _ _) = 395 C.Param (C.TypeName $ call_sig_type ifn m) n 396 397rpc_ooo_vtbl_op :: String -> MessageDef -> C.Param 398rpc_ooo_vtbl_op ifn m@(RPC n _ _) = 399 C.Param (C.TypeName $ call_ooo_sig_type ifn m) n 400 401rpc_seq_vtbl_op_x :: String -> MessageDef -> C.Param 402rpc_seq_vtbl_op_x ifn m@(RPC n _ _) = 403 C.Param (C.TypeName $ call_sig_type_x ifn m) n 404 405rpc_fifo_vtbl_op_x :: String -> MessageDef -> C.Param 406rpc_fifo_vtbl_op_x ifn m@(RPC n _ _) = 407 C.Param (C.TypeName $ call_sig_type_x ifn m) n 408 409rpc_ooo_vtbl_op_x :: String -> MessageDef -> C.Param 410rpc_ooo_vtbl_op_x ifn m@(RPC n _ _) = 411 C.Param (C.TypeName $ call_ooo_sig_type_x ifn m) n 412 413intf_vtbl_op :: String -> String -> String -> MessageDef -> C.Param 414intf_vtbl_op ifn sender sendrecv m = 415 C.Param (C.TypeName $ msg_sig_type ifn sender sendrecv m) (BC.msg_name m) 416 417intf_vtbl_op_x :: String -> String -> String -> MessageDef -> C.Param 418intf_vtbl_op_x ifn sender sendrecv m = 419 C.Param (C.TypeName $ msg_sig_type_x ifn sender sendrecv m) (BC.msg_name m) 420 421intf_selector_op :: String -> String -> String -> MessageDef -> C.Param 422intf_selector_op ifn sender sendrecv m = 423 C.Param (C.TypeName "int") (BC.msg_name m) 424 425-- Should do this properly rather than string munging. 426fnptr :: String -> String 427fnptr s = "(*" ++ s ++ ")" 428 429call_signature :: String -> MessageDef -> C.Unit 430call_signature ifname m@(RPC s args _) = 431 let name = call_sig_type ifname m 432 binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname "client") 433 intf_bind_var 434 params = [ binding ] ++ concat [ rpc_call_argdecl ifname a | a <- args ] 435 in 436 C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name 437 438call_signature_x :: String -> MessageDef -> C.Unit 439call_signature_x ifname m@(RPC s args _) = 440 let name = call_sig_type_x ifname m 441 binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname "client") 442 intf_bind_var 443 params = [ binding ] ++ concat [ rpc_call_argdecl ifname a | a <- args ] 444 in 445 C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name 446 447call_ooo_signature :: String -> MessageDef -> C.Unit 448call_ooo_signature ifname m@(RPC s args _) = 449 let name = call_ooo_sig_type ifname m 450 binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname "client") 451 intf_bind_var 452 params = [ binding ] ++ concat [ rpc_call_argdecl ifname a | a <- (tail (tail args)) ] 453 in 454 C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name 455 456call_ooo_signature_x :: String -> MessageDef -> C.Unit 457call_ooo_signature_x ifname m@(RPC s args _) = 458 let name = call_ooo_sig_type_x ifname m 459 binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname "client") 460 intf_bind_var 461 params = [ binding ] ++ concat [ rpc_call_argdecl ifname a | a <- (tail (tail args)) ] 462 in 463 C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name 464 465send_signature :: Side -> String -> String -> MessageDef -> C.Unit 466 467send_signature side sender ifname m@(Message dir _ args _) = 468 let name = msg_sig_type ifname sender "send" m 469 binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname sender) 470 intf_bind_var 471 params = [ binding ] ++ concat [ BC.msg_argdecl BC.TX ifname a | a <- args ] 472 in 473 C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name 474 475send_signature side sender ifname m@(RPC s args _) = 476 let name = msg_sig_type ifname sender "send" m 477 binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname sender) 478 intf_bind_var 479 params = [ binding ] ++ concat [ rpc_send_argdecl side ifname a | a <- args ] 480 in 481 C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name 482 483receive_signature side receiver ifname m@(Message dir _ args _) = 484 let name = msg_sig_type ifname receiver "recv" m 485 binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname receiver) 486 intf_bind_var 487 params = [ binding ] ++ concat [ receive_msg_argdecl ifname a | a <- args ] 488 in 489 C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name 490 491receive_signature side receiver ifname m@(RPC s args _) = 492 let name = msg_sig_type ifname receiver "recv" m 493 binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname receiver) 494 intf_bind_var 495 params = [ binding ] ++ concat [ rpc_receive_argdecl side ifname a | a <- args ] 496 in 497 C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name 498 499send_signature_x side sender ifname m@(Message dir _ args _) = 500 let name = msg_sig_type_x ifname sender "send" m 501 binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname sender) 502 intf_bind_var 503 params = [ binding ] ++ concat [ BC.msg_argdecl BC.TX ifname a | a <- args ] 504 in 505 C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name 506 507send_signature_x side sender ifname m@(RPC s args _) = 508 let name = msg_sig_type_x ifname sender "send" m 509 binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname sender) 510 intf_bind_var 511 params = [ binding ] ++ concat [ rpc_send_argdecl side ifname a | a <- args ] 512 in 513 C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name 514 515receive_signature_x side receiver ifname m@(Message dir _ args _) = 516 let name = msg_sig_type_x ifname receiver "recv" m 517 binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname receiver) 518 intf_bind_var 519 params = [ binding ] ++ concat [ receive_msg_argdecl ifname a | a <- args ] 520 in 521 C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name 522 523receive_signature_x side receiver ifname m@(RPC s args _) = 524 let name = msg_sig_type_x ifname receiver "recv" m 525 binding = C.Param (C.Ptr $ C.TypeName $ intf_bind_type ifname receiver) 526 intf_bind_var 527 params = [ binding ] ++ concat [ rpc_receive_argdecl side ifname a | a <- args ] 528 in 529 C.TypeDef (C.Function C.NoScope (C.TypeName "errval_t") params) $ fnptr name 530 531rpc_call_argdecl :: String -> RPCArgument -> [C.Param] 532rpc_call_argdecl ifn (RPCArgIn tr v) = BC.msg_argdecl BC.TX ifn (Arg tr v) 533rpc_call_argdecl ifn (RPCArgOut tr v) = receive_msg_argdecl ifn (Arg tr v) 534 535rpc_send_argdecl :: Side -> String -> RPCArgument -> [C.Param] 536rpc_send_argdecl ClientSide ifn (RPCArgIn tr v) = BC.msg_argdecl BC.TX ifn (Arg tr v) 537rpc_send_argdecl ClientSide ifn (RPCArgOut _ _) = [] 538rpc_send_argdecl ServerSide ifn (RPCArgIn _ _) = [] 539rpc_send_argdecl ServerSide ifn (RPCArgOut tr v) = BC.msg_argdecl BC.TX ifn (Arg tr v) 540 541receive_msg_argdecl :: String -> MessageArgument -> [C.Param] 542receive_msg_argdecl ifn (Arg tr (Name n)) = 543 [ C.Param (C.Ptr $ BC.type_c_type ifn tr) n ] 544receive_msg_argdecl ifn (Arg tr (StringArray n l)) = 545 [ C.Param (BC.type_c_type ifn tr) n ] 546receive_msg_argdecl ifn (Arg tr (DynamicArray n l _)) = 547 [ C.Param (C.Ptr $ BC.type_c_type ifn tr) n, 548 C.Param (C.Ptr $ BC.type_c_type ifn size) l ] 549 550rpc_receive_argdecl :: Side -> String -> RPCArgument -> [C.Param] 551rpc_receive_argdecl ClientSide ifn (RPCArgOut tr v) = receive_msg_argdecl ifn (Arg tr v) 552rpc_receive_argdecl ClientSide ifn (RPCArgIn _ _) = [] 553rpc_receive_argdecl ServerSide ifn (RPCArgOut _ _) = [] 554rpc_receive_argdecl ServerSide ifn (RPCArgIn tr v) = receive_msg_argdecl ifn (Arg tr v) 555 556msg_enums :: (String -> String) -> (String -> String -> String) -> String -> [MessageDef] -> C.Unit 557msg_enums enum element ifname msgs = 558 C.EnumDecl (enum ifname) 559 ([ C.EnumItem (element ifname n) Nothing 560 | m@(Message _ n _ _) <- msgs ] 561 ++ 562 [ C.EnumItem (element ifname n) Nothing 563 | m@(RPC n _ _) <- msgs ] 564 ) 565 566-- 567-- Generate a struct to hold the arguments of a message while it's being sent. 568-- 569msg_argstruct :: String -> MessageDef -> C.Unit 570msg_argstruct ifname m@(Message _ n [] _) = C.NoOp 571msg_argstruct ifname m@(Message _ n args _) = 572 let tn = msg_argstruct_name ifname n 573 in 574 C.StructDecl tn (concat [ BC.msg_argstructdecl BC.RX ifname [] a | a <- args ]) 575msg_argstruct ifname m@(RPC n args _) = 576 C.UnitList [ 577 C.StructDecl (rpc_argstruct_name ifname n "in") 578 (concat [ rpc_argdecl ClientSide ifname a | a <- args ]), 579 C.StructDecl (rpc_argstruct_name ifname n "out") 580 (concat [ rpc_argdecl ServerSide ifname a | a <- args ]), 581 C.UnionDecl (rpc_union_name ifname n) [ 582 C.Param (C.Struct $ rpc_argstruct_name ifname n "in") "in", 583 C.Param (C.Struct $ rpc_argstruct_name ifname n "out") "out" 584 ] 585 ] 586 587-- 588-- Generate a union of all the above 589-- 590intf_union :: String -> [MessageDef] -> C.Unit 591intf_union ifn msgs = 592 C.UnionDecl (binding_arg_union_type ifn) 593 ([ C.Param (C.Struct $ msg_argstruct_name ifn n) n 594 | m@(Message _ n a _) <- msgs, 0 /= length a ] 595 ++ 596 [ C.Param (C.Union $ rpc_union_name ifn n) n 597 | m@(RPC n a _) <- msgs, 0 /= length a ]) 598 599rpc_argdecl :: Side -> String -> RPCArgument -> [C.Param] 600rpc_argdecl ClientSide ifn (RPCArgIn tr v) = BC.msg_argstructdecl BC.RX ifn [] (Arg tr v) 601rpc_argdecl ClientSide ifn (RPCArgOut _ _) = [] 602rpc_argdecl ServerSide ifn (RPCArgOut tr v) = BC.msg_argstructdecl BC.RX ifn [] (Arg tr v) 603rpc_argdecl ServerSide ifn (RPCArgIn _ _) = [] 604