1{- 2 GHBackend: Flounder stub generator for generic header files 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 GHBackend where 15 16import Data.List 17import Data.Char 18 19import qualified CAbsSyntax as C 20import Syntax 21import qualified Backend 22import BackendCommon 23 24accept_fn_name n = ifscope n "accept" 25connect_fn_name n = ifscope n "connect" 26 27export_fn_name n = ifscope n "export" 28bind_fn_name n = ifscope n "bind" 29 30connect_handlers_fn_name n = ifscope n "connect_handlers" 31disconnect_handlers_fn_name n = ifscope n "disconnect_handlers" 32 33-- Name of the init function 34rpc_init_fn_name :: String -> String 35rpc_init_fn_name ifn = ifscope ifn "rpc_client_init" 36 37rpc_rx_vtbl_type ifn = ifscope ifn "rpc_rx_vtbl" 38rpc_tx_vtbl_type ifn = ifscope ifn "rpc_tx_vtbl" 39local_rpc_tx_vtbl_type ifn = ifscope ifn "local_rpc_tx_vtbl" 40 41------------------------------------------------------------------------ 42-- Language mapping: Create the generic header file for the interface 43------------------------------------------------------------------------ 44 45compile :: String -> String -> Interface -> String 46compile infile outfile interface = 47 unlines $ C.pp_unit $ intf_header_file infile interface 48 49header_file :: String -> Interface -> [C.Unit] -> C.Unit 50header_file infile interface@(Interface name _ _) body = 51 let sym = "__" ++ name ++ "_IF_H" 52 in 53 C.IfNDef sym ([ C.Define sym [] "1"] ++ body) [] 54 55intf_header_file :: String -> Interface -> C.Unit 56intf_header_file infile intf = 57 header_file infile intf (intf_header_body infile intf) 58 59intf_header_body :: String -> Interface -> [C.Unit] 60intf_header_body infile interface@(Interface name descr decls) = 61 let 62 (types, messagedecls) = Backend.partitionTypesMessages decls 63 messages = rpcs_to_msgs messagedecls 64 rpcs = [m | m@(RPC _ _ _) <- messagedecls] 65 in 66 [ intf_preamble infile name descr, 67 C.Blank, 68 69 C.Include C.Standard "flounder/flounder.h", 70 C.Include C.Standard "flounder/flounder_support.h", 71 C.Blank, 72 73 C.MultiComment [ "Concrete type definitions" ], 74 C.UnitList $ define_types name types, 75 C.Blank, 76 77 C.MultiComment [ "Forward declaration of binding type" ], 78 C.StructForwardDecl (intf_bind_type name), 79 C.Blank, 80 81 C.MultiComment [ "Contination (callback) and control function types" ], 82 intf_bind_cont_fn name, 83 can_send_fn_typedef name, 84 register_send_fn_typedef name, 85 change_waitset_fn_typedef name, 86 control_fn_typedef name, 87 error_handler_fn_typedef name, 88 receive_next_fn_typedef name, 89 get_receiving_chanstate_fn_typedef name, 90 C.Blank, 91 92 C.MultiComment [ "Enumeration for message numbers" ], 93 msg_enums name messages, 94 C.Blank, 95 96 C.MultiComment [ "Message type signatures (transmit)" ], 97 C.UnitList [ msg_signature TX name m | m <- messages ], 98 C.Blank, 99 100 C.MultiComment [ "Message type signatures (receive)" ], 101 C.UnitList [ msg_signature RX name m | m <- messages ], 102 C.Blank, 103 104 C.MultiComment [ "RPC RX function signatures" ], 105 C.UnitList [ msg_signature_generic RX name types (binding_param name) m 106 | m <- rpcs ], 107 C.Blank, 108 109 C.MultiComment [ "RPC TX Function signatures" ], 110 C.UnitList [ msg_signature_generic TX name types (binding_param name) m 111 | m <- rpcs ], 112 C.Blank, 113 114 C.MultiComment [ "Struct type for holding the RX args for each msg" ], 115 C.UnitList [ msg_argstruct RX name types m | m <- messages ], 116 C.Blank, 117 118 C.MultiComment [ "Struct type for holding the TX args for each msg" ], 119 C.UnitList [ msg_argstruct TX name types m | m <- messages ], 120 C.Blank, 121 122 C.MultiComment [ "Union type for all message arguments" ], 123 intf_union RX name messages, 124 C.Blank, 125 126 C.MultiComment [ "Union type for all message arguments" ], 127 intf_union TX name messages, 128 C.Blank, 129 130 C.MultiComment [ "Maximum Transfer Size" ], 131 msg_arg_sizes name types messages, 132 msg_arg_size name types messages, 133 C.Blank, 134 135 C.MultiComment [ "VTable struct definition for the interface (transmit)" ], 136 intf_vtbl name TX messages, 137 C.Blank, 138 139 C.MultiComment [ "VTable struct definition for the interface (receive)" ], 140 intf_vtbl name RX messages, 141 C.Blank, 142 143 C.MultiComment [ "VTable struct definition for the rpc interface (receive)" ], 144 rpc_rx_vtbl_decl name rpcs, 145 C.Blank, 146 147 C.MultiComment [ "VTable struct definition for the rpc interface (transmit)" ], 148 rpc_tx_vtbl_decl name rpcs, 149 C.Blank, 150 151 C.MultiComment [ "Incoming connect callback type" ], 152 connect_callback_fn name, 153 C.Blank, 154 155 C.MultiComment [ "Export state struct" ], 156 export_struct name, 157 C.Blank, 158 159 C.MultiComment [ "Export function" ], 160 export_function name, 161 C.Blank, 162 163 C.MultiComment [ "The message buffer structure (for accept/connect)" ], 164 frameinfo_struct name messages, 165 C.Blank, 166 167 C.MultiComment [ "Accept function over already shared frame" ], 168 accept_function name, 169 C.Blank, 170 171 C.MultiComment [ "The Binding structure" ], 172 binding_struct name messages, 173 C.Blank, 174 175 C.MultiComment [ "Generic bind function" ], 176 bind_function name, 177 C.Blank, 178 179 C.MultiComment [ "Generic connect function over already shared frame" ], 180 connect_function name, 181 C.Blank, 182 183 C.MultiComment [ "Send wrappers" ], 184 C.UnitList [ tx_wrapper name m | m <- messages ], 185 C.Blank, 186 187 C.MultiComment [ "Backend-specific includes" ], 188 C.UnitList $ backend_includes name, 189 190 C.MultiComment [ "Function to initialise an RPC client" ], 191 rpc_init_fn_proto name, 192 193 C.MultiComment [ "And we're done" ] 194 ] 195 196-- 197-- Generate an enumeration for each message type, to use as procedure numbers. 198-- 199msg_enums :: String -> [MessageDef] -> C.Unit 200msg_enums ifname msgs 201 = C.EnumDecl (msg_enum_name ifname) 202 ([C.EnumItem (msg_enum_elem_name ifname "__dummy") (Just $ C.NumConstant 0)] ++ 203 [C.EnumItem (msg_enum_elem_name ifname "__bind") (Just $ C.NumConstant 1)] ++ 204 [C.EnumItem (msg_enum_elem_name ifname "__bind_reply") (Just $ C.NumConstant 2)] ++ 205 [C.EnumItem (msg_enum_elem_name ifname (msg_name m)) (Just $ C.NumConstant i) 206 | (m, i) <- zip msgs [3..]]) 207 208-- 209-- Generate type definitions for each message signature 210-- 211msg_signature_generic :: Direction -> String -> [TypeDef] -> C.Param -> MessageDef -> C.Unit 212msg_signature_generic dirn ifname typedefs firstparam m = 213 C.TypeDef (C.Function C.NoScope (return_type dirn m) params) name 214 where 215 name = msg_sig_type ifname m dirn 216 continuation = C.Param (C.Struct "event_closure") intf_cont_var 217 -- need a continuation only for non-RPC TX 218 opt_continuation = case dirn of 219 TX -> case m of 220 RPC _ _ _ -> [] 221 otherwise -> [ continuation ] 222 RX -> [] 223 params = [ firstparam ] ++ opt_continuation ++ concat payload 224 payload = case m of 225 Message _ _ args _ -> [ msg_argdecl dirn ifname a | a <- args ] 226 RPC s args _ -> [ rpc_argdecl2 dirn ifname typedefs a | a <- args ] 227 return_type RX m@(Message _ _ _ _) = C.TypeName "void" 228 return_type _ _ = C.TypeName "errval_t" 229 230msg_signature :: Direction -> String -> MessageDef -> C.Unit 231msg_signature dir ifn = msg_signature_generic dir ifn [] (binding_param ifn) 232 233rpc_rx_vtbl_decl :: String -> [MessageDef] -> C.Unit 234rpc_rx_vtbl_decl n ml = 235 C.StructDecl (rpc_rx_vtbl_type n) [ param n m | m <- ml ] 236 where 237 param ifn m = C.Param (C.Ptr $ C.TypeName $ msg_sig_type ifn m RX) ((msg_name m) ++ "_call") 238 239rpc_tx_vtbl_decl :: String -> [MessageDef] -> C.Unit 240rpc_tx_vtbl_decl n ml = 241 C.StructDecl (rpc_tx_vtbl_type n) [ intf_vtbl_param n m TX | m <- ml ] 242 243 244-- 245-- Get the maximum size of the arguments 246-- 247 248msg_arg_size :: String -> [TypeDef] -> [MessageDef] -> C.Unit 249msg_arg_size ifname typedefs messages = C.Define (msg_arg_size_name ifname) [] 250 (C.pp_expr (C.SizeOfT $ C.Union $ binding_arg_union_type RX ifname)) 251 252msg_arg_sizes :: String -> [TypeDef] -> [MessageDef] -> C.Unit 253msg_arg_sizes ifname typedefs messages = 254 C.UnitList [ C.UnitList $ define_msg_arg_size ifname m | m <- messages ] 255 256-- extracts the size of the arguemnts of a message 257define_msg_size :: String -> String-> MessageArgument -> C.Unit 258define_msg_size ifn fn (Arg tr (Name an)) = C.NoOp 259define_msg_size ifn fn (Arg tr (StringArray an maxlen)) = C.Define (arg_size_name ifn fn an) [] (show maxlen) 260define_msg_size ifn fn (Arg tr (DynamicArray an len maxlen)) = C.Define (arg_size_name ifn fn an) [] (show maxlen) 261 262 263-- extracts the size of the arguemnts of an RPC (out) 264define_rpc_size :: String -> String-> RPCArgument -> C.Unit 265define_rpc_size ifn fn (RPCArgOut tr (Name an)) = C.NoOp 266define_rpc_size ifn fn (RPCArgIn _ _) = C.NoOp 267define_rpc_size ifn fn (RPCArgOut tr (StringArray an maxlen)) = C.Define (arg_size_name ifn fn an) [] (show maxlen) 268define_rpc_size ifn fn (RPCArgOut tr (DynamicArray an len maxlen)) = C.Define (arg_size_name ifn fn an) [] (show maxlen) 269 270-- extract the size of arguemnts 271define_msg_arg_size :: String-> MessageDef -> [C.Unit] 272define_msg_arg_size ifn (RPC n [] _) = [] 273define_msg_arg_size ifn (RPC n args _) = [define_rpc_size ifn n arg | arg <- args] 274define_msg_arg_size ifn (Message mtype n [] _) = [] 275define_msg_arg_size ifn (Message mtype n args _) = [define_msg_size ifn n arg | arg <- args] 276 277 278 279-- 280-- Generate a struct to hold the arguments of a message while it's being sent. 281-- 282msg_argstruct :: Direction -> String -> [TypeDef] -> MessageDef -> C.Unit 283msg_argstruct dir ifname typedefs m@(RPC n args _) = 284 C.StructDecl (msg_argstruct_name dir ifname n) 285 (concat [ rpc_argdecl TX ifname a | a <- args ]) 286msg_argstruct dir ifname typedefs m@(Message _ n [] _) = C.NoOp 287msg_argstruct dir ifname typedefs m@(Message _ n args _) = 288 C.StructDecl (msg_argstruct_name dir ifname n) 289 (concat [ msg_argstructdecl dir ifname typedefs a | a <- args ]) 290-- 291-- Generate a union of all the above 292-- 293intf_union :: Direction -> String -> [MessageDef] -> C.Unit 294intf_union dir ifn msgs = 295 C.UnionDecl (binding_arg_union_type dir ifn) 296 ([ C.Param (C.Struct $ msg_argstruct_name dir ifn n) n 297 | m@(Message _ n a _) <- msgs, 0 /= length a ] 298 ++ 299 [ C.Param (C.Struct $ msg_argstruct_name dir ifn n) n 300 | m@(RPC n a _) <- msgs, 0 /= length a ] 301 ) 302 303-- 304-- Generate a struct defn for a vtable for the interface 305-- 306intf_vtbl :: String -> Direction -> [MessageDef] -> C.Unit 307intf_vtbl n d ml = 308 C.StructDecl (intf_vtbl_type n d) [ intf_vtbl_param n m d | m <- ml ] 309 310intf_vtbl_param :: String -> MessageDef -> Direction -> C.Param 311intf_vtbl_param ifn m d = C.Param (C.Ptr $ C.TypeName $ msg_sig_type ifn m d) (msg_name m) 312 313-- 314-- Generate the binding structure 315-- 316binding_struct :: String -> [MessageDef] -> C.Unit 317binding_struct n ml = C.StructDecl (intf_bind_type n) fields 318 where 319 fields = [ 320 C.ParamComment "Arbitrary user state pointer", 321 C.Param (C.Ptr C.Void) "st", 322 C.ParamBlank, 323 324 C.ParamComment "Waitset used for receive handlers", 325 C.Param (C.Ptr $ C.Struct "waitset") "waitset", 326 C.ParamBlank, 327 328 C.ParamComment "Mutex for the use of user code.", 329 C.ParamComment "Must be held before any operation where there is a possibility of", 330 C.ParamComment "concurrent access to the same binding (eg. multiple threads, or", 331 C.ParamComment "asynchronous event handlers that use the same binding object).", 332 C.Param (C.Struct "event_mutex") "mutex", 333 C.ParamBlank, 334 335 C.ParamComment "returns true iff a message could currently be accepted by the binding", 336 C.Param (C.Ptr $ C.TypeName $ can_send_fn_type n) "can_send", 337 C.ParamBlank, 338 339 C.ParamComment "register an event for when a message is likely to be able to be sent", 340 C.Param (C.Ptr $ C.TypeName $ register_send_fn_type n) "register_send", 341 C.ParamBlank, 342 343 C.ParamComment "change the waitset used by a binding", 344 C.Param (C.Ptr $ C.TypeName $ change_waitset_fn_type n) "change_waitset", 345 C.ParamBlank, 346 347 C.ParamComment "perform control operations", 348 C.Param (C.Ptr $ C.TypeName $ control_fn_type n) "control", 349 C.ParamBlank, 350 351 C.ParamComment "error handler for any async errors associated with this binding", 352 C.ParamComment "must be filled-in by user", 353 C.Param (C.Ptr $ C.TypeName $ error_handler_fn_type n) "error_handler", 354 C.ParamBlank, 355 356 C.ParamComment "receive next message", 357 C.Param (C.Ptr $ C.TypeName $ receive_next_fn_type n) "receive_next", 358 C.ParamBlank, 359 360 C.ParamComment "get receiving chanstate", 361 C.Param (C.Ptr $ C.TypeName $ get_receiving_chanstate_fn_type n) "get_receiving_chanstate", 362 C.ParamBlank, 363 364 C.ParamComment "Message send functions (filled in by binding)", 365 C.Param (C.Struct $ intf_vtbl_type n TX) "tx_vtbl", 366 C.ParamBlank, 367 368 C.ParamComment "Incoming message handlers, direct (filled in by user)", 369 C.Param (C.Struct $ intf_vtbl_type n RX) "rx_vtbl", 370 C.ParamBlank, 371 372 C.ParamComment "Incoming message handlers, indirect (filled in by user)", 373 C.Param (C.Struct $ intf_vtbl_type n RX) "message_rx_vtbl", 374 C.ParamBlank, 375 376 C.ParamComment "Incoming message rpc handlers (filled in by user)", 377 C.Param (C.Struct $ rpc_rx_vtbl_type n) "rpc_rx_vtbl", 378 C.ParamBlank, 379 380 C.ParamComment "RPC send functions (filled in by binding)", 381 C.Param (C.Struct $ rpc_tx_vtbl_type n) "rpc_tx_vtbl", 382 C.ParamBlank, 383 384 C.ParamComment "Message channels", 385 C.Param (C.Array (toInteger ((length ml) + 3)) (C.Struct "waitset_chanstate")) "message_chanstate", 386 387 C.ParamComment "Private state belonging to the binding implementation", 388 C.Param (C.Union $ binding_arg_union_type TX n) "tx_union", 389 C.Param (C.Union $ binding_arg_union_type RX n) "rx_union", 390 C.Param (C.Struct "waitset_chanstate") "register_chanstate", 391 C.Param (C.Struct "waitset_chanstate") "tx_cont_chanstate", 392 C.Param (C.Enum $ msg_enum_name n) "tx_msgnum", 393 C.Param (C.Enum $ msg_enum_name n) "rx_msgnum", 394 C.Param (C.TypeName "int") "tx_msg_fragment", 395 C.Param (C.TypeName "int") "rx_msg_fragment", 396 C.Param (C.TypeName "size_t") "tx_str_pos", 397 C.Param (C.TypeName "size_t") "rx_str_pos", 398 C.Param (C.TypeName "size_t") "tx_str_len", 399 C.Param (C.TypeName "size_t") "rx_str_len", 400 C.Param (C.Struct "event_queue_node") "event_qnode", 401 C.Param (C.Ptr $ C.TypeName $ intf_bind_cont_type n) "bind_cont", 402 C.Param (C.TypeName "uint32_t") "incoming_token", 403 C.Param (C.TypeName "uint32_t") "outgoing_token", 404 C.Param (C.Struct "thread_mutex") "rxtx_mutex", 405 C.Param (C.Struct "thread_mutex") "send_mutex", 406 C.Param (C.TypeName "errval_t") "error", 407 C.Param (C.Ptr $ C.Struct $ intf_bind_type n) "local_binding" 408 ] 409 410-- 411-- Generate the binding structure 412-- 413frameinfo_struct :: String -> [MessageDef] -> C.Unit 414frameinfo_struct n ml = C.StructDecl (intf_frameinfo_type n) fields 415 where 416 fields = [ 417 C.ParamComment "Physical address of send buffer", 418 C.Param (C.TypeName "lpaddr_t") "sendbase", 419 C.ParamBlank, 420 C.ParamComment "Pointer to incoming message buffer", 421 C.Param (C.Ptr C.Void) "inbuf", 422 C.ParamBlank, 423 C.ParamComment "Size of the incoming buffer in bytes", 424 C.Param (C.TypeName "size_t") "inbufsize", 425 C.ParamBlank, 426 C.ParamComment "Pointer to outgoing message buffer", 427 C.Param (C.Ptr C.Void) "outbuf", 428 C.ParamBlank, 429 C.ParamComment "Size of the outgoing buffer in bytes", 430 C.Param (C.TypeName "size_t") "outbufsize", 431 C.ParamBlank] 432 433 434 435-- 436-- Generate prototypes for export. 437-- 438 439connect_callback_fn :: String -> C.Unit 440connect_callback_fn n = 441 C.TypeDef 442 (C.Function C.NoScope (C.TypeName "errval_t") params) 443 (connect_callback_name n) 444 where 445 params = [ C.Param (C.Ptr $ C.TypeName "void") "st", 446 C.Param (C.Ptr $ C.Struct $ intf_bind_type n) "binding" ] 447 448export_struct :: String -> C.Unit 449export_struct n = C.StructDecl (export_type n) fields 450 where 451 fields = [ 452 C.Param (C.Struct "idc_export") "common", 453 C.Param (C.Ptr $ C.TypeName $ connect_callback_name n) "connect_cb", 454 C.Param (C.Ptr $ C.Struct "waitset") "waitset", 455 C.Param (C.Ptr $ C.Void) "st"] 456 457export_function :: String -> C.Unit 458export_function n = 459 C.GVarDecl C.Extern C.NonConst 460 (C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing 461 where 462 name = export_fn_name n 463 params = [ C.Param (C.Ptr $ C.TypeName "void") "st", 464 C.Param (C.Ptr $ C.TypeName "idc_export_callback_fn") "export_cb", 465 C.Param (C.Ptr $ C.TypeName $ connect_callback_name n) "connect_cb", 466 C.Param (C.Ptr $ C.Struct "waitset") "ws", 467 C.Param (C.TypeName "idc_export_flags_t") "flags"] 468 469intf_bind_cont_fn :: String -> C.Unit 470intf_bind_cont_fn n = 471 C.TypeDef 472 (C.Function C.NoScope (C.TypeName "void") params) 473 (intf_bind_cont_type n) 474 where 475 params = [ C.Param (C.Ptr $ C.TypeName "void") "st", 476 C.Param (C.TypeName "errval_t") "err", 477 binding_param n ] 478 479can_send_fn_typedef :: String -> C.Unit 480can_send_fn_typedef n = 481 C.TypeDef 482 (C.Function C.NoScope (C.TypeName "bool") params) 483 (can_send_fn_type n) 484 where 485 params = [ binding_param n ] 486 487register_send_fn_typedef :: String -> C.Unit 488register_send_fn_typedef n = 489 C.TypeDef 490 (C.Function C.NoScope (C.TypeName "errval_t") params) 491 (register_send_fn_type n) 492 where 493 params = [ binding_param n, 494 C.Param (C.Ptr $ C.Struct "waitset") "ws", 495 C.Param (C.Struct "event_closure") intf_cont_var ] 496 497change_waitset_fn_typedef :: String -> C.Unit 498change_waitset_fn_typedef n = 499 C.TypeDef 500 (C.Function C.NoScope (C.TypeName "errval_t") params) 501 (change_waitset_fn_type n) 502 where 503 params = [ binding_param n, 504 C.Param (C.Ptr $ C.Struct "waitset") "ws" ] 505 506control_fn_typedef :: String -> C.Unit 507control_fn_typedef n = 508 C.TypeDef 509 (C.Function C.NoScope (C.TypeName "errval_t") params) 510 (control_fn_type n) 511 where 512 params = [ binding_param n, 513 C.Param (C.TypeName "idc_control_t") "control" ] 514 515error_handler_fn_typedef :: String -> C.Unit 516error_handler_fn_typedef n = 517 C.TypeDef 518 (C.Function C.NoScope C.Void params) 519 (error_handler_fn_type n) 520 where 521 params = [ binding_param n, 522 C.Param (C.TypeName "errval_t") "err" ] 523 524receive_next_fn_typedef :: String -> C.Unit 525receive_next_fn_typedef n = 526 C.TypeDef 527 (C.Function C.NoScope (C.TypeName "errval_t") params) 528 (receive_next_fn_type n) 529 where 530 params = [binding_param n] 531 532get_receiving_chanstate_fn_typedef :: String -> C.Unit 533get_receiving_chanstate_fn_typedef n = 534 C.TypeDef 535 (C.Function C.NoScope (C.Ptr $ C.Struct "waitset_chanstate") params) 536 (get_receiving_chanstate_fn_type n) 537 where 538 params = [binding_param n] 539 540bind_function :: String -> C.Unit 541bind_function n = 542 C.GVarDecl C.Extern C.NonConst 543 (C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing 544 where 545 name = bind_fn_name n 546 params = [ C.Param (C.TypeName "iref_t") "i", 547 C.Param (C.Ptr $ C.TypeName $ intf_bind_cont_type n) intf_cont_var, 548 C.Param (C.Ptr $ C.TypeName "void") "st", 549 C.Param (C.Ptr $ C.Struct "waitset") "waitset", 550 C.Param (C.TypeName "idc_bind_flags_t") "flags" ] 551 552-- Function for accepting new flounder connections over a already frame 553accept_function :: String -> C.Unit 554accept_function n = 555 C.GVarDecl C.Extern C.NonConst 556 (C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing 557 where 558 name = accept_fn_name n 559 params = [ C.Param (C.Ptr $ C.Struct $ intf_frameinfo_type n) intf_frameinfo_var, 560 C.Param (C.Ptr $ C.TypeName "void") "st", 561 C.Param (C.Ptr $ C.TypeName $ intf_bind_cont_type n) intf_cont_var, 562 C.Param (C.Ptr $ C.Struct "waitset") "ws", 563 C.Param (C.TypeName "idc_export_flags_t") "flags"] 564 565connect_function :: String -> C.Unit 566connect_function n = 567 C.GVarDecl C.Extern C.NonConst 568 (C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing 569 where 570 name = connect_fn_name n 571 params = [ C.Param (C.Ptr $ C.Struct $ intf_frameinfo_type n) intf_frameinfo_var, 572 C.Param (C.Ptr $ C.TypeName $ intf_bind_cont_type n) intf_cont_var, 573 C.Param (C.Ptr $ C.TypeName "void") "st", 574 C.Param (C.Ptr $ C.Struct "waitset") "ws", 575 C.Param (C.TypeName "idc_bind_flags_t") "flags" ] 576 577rpc_init_fn_proto :: String -> C.Unit 578rpc_init_fn_proto n = 579 C.GVarDecl C.Extern C.NonConst 580 (C.Function C.NoScope (C.Void) (rpc_init_fn_params n)) name Nothing 581 where 582 name = rpc_init_fn_name n 583 rpc_init_fn_params n = [C.Param (C.Ptr $ C.Struct (intf_bind_type n)) "binding"] 584 585-- 586-- Generate send function inline wrappers for each message signature 587-- 588 589tx_wrapper :: String -> MessageDef -> C.Unit 590tx_wrapper ifn (Message _ mn args _) 591 = C.StaticInline (C.TypeName "errval_t") (tx_wrapper_name ifn mn) 592 ([ binding_param ifn, continuation ] ++ concat payload_params) 593 [ C.Return $ C.CallInd (bindvar `C.DerefField` "tx_vtbl" `C.FieldOf` mn) 594 ([bindvar, C.Variable intf_cont_var] ++ payload_args) ] 595 where 596 continuation = C.Param (C.Struct "event_closure") intf_cont_var 597 payload_params = [ msg_argdecl TX ifn a | a <- args ] 598 payload_args = map C.Variable $ concat $ map mkargs args 599 mkargs (Arg _ (Name an)) = [an] 600 mkargs (Arg _ (StringArray an _)) = [an] 601 mkargs (Arg _ (DynamicArray an al _)) = [an, al] 602 603-- 604-- Include the right files for different backends 605-- 606 607flounder_backends = [ "lmp", "ump", "ump_ipi", "multihop", "local" ] 608 609backend_includes :: String -> [ C.Unit ] 610backend_includes n = 611 [ backend_include n b | b <- flounder_backends ] 612 613backend_include n b = 614 C.IfDef ("CONFIG_FLOUNDER_BACKEND_" ++ (map toUpper b)) 615 [ C.Include C.Standard ("if/" ++ n ++ "_" ++ b ++ "_defs.h") ] 616 [] 617 618----------------------------------------------------------------- 619-- Code to generate concrete type definitions 620----------------------------------------------------------------- 621 622define_types :: String -> [TypeDef] -> [C.Unit] 623define_types interfaceName types = 624 [ define_type interfaceName t | t <- types ] 625 626define_type :: String -> TypeDef -> C.Unit 627define_type ifname (TAliasT newType originType) = 628 C.TypeDef (type_c_type ifname $ Builtin originType) (type_c_name1 ifname newType) 629 630{- 631A typedef'd alias: 632\begin{verbatim} 633typedef uint32 alias_type; 634\end{verbatim} 635 636Should compile to: 637\begin{verbatim} 638typedef uint32_t ifname_alias_type_t; 639\end{verbatim} 640-} 641 642define_type ifname (TAlias newType originType) = 643 C.TypeDef (type_c_type ifname originType) (type_c_name1 ifname newType) 644 645{- 646For @TArray@, we have to map the type @name@ to an array of @length@ 647elements of type @typeElts@. In C, this surprisingly corresponds to 648the, correct, following code: 649 650\begin{verbatim} 651typedef typeElts name[length] 652\end{verbatim} 653 654So, we will compile: 655\begin{verbatim} 656typedef uint32 array_type[30]; 657\end{verbatim} 658 659To the following type definition: 660\begin{verbatim} 661typedef uint32_t ifname_array_type_t[30] 662\end{verbatim} 663-} 664 665define_type ifname (TArray typeElts name length) = 666 C.TypeDef 667 (C.Array length $ type_c_type ifname typeElts) 668 (type_c_name1 ifname name) 669 670 671{- 672The following structure: 673\begin{verbatim} 674typedef struct { 675 uint32 int_field; 676 alias_type alias_field; 677} struct_type; 678\end{verbatim} 679 680Should be compiled down to: 681\begin{verbatim} 682typedef struct _ifname_struct_type_t { 683 uint32_t int_field; 684 ifname_alias_type_t alias_field; 685} ifname_struct_type_t; 686\end{verbatim} 687-} 688 689define_type ifname (TStruct name fields) = 690 let struct_name = type_c_struct ifname name 691 type_name = type_c_name1 ifname name 692 in 693 C.UnitList [ 694 (C.StructDecl struct_name 695 [ C.Param (type_c_type ifname ft) fn 696 | TStructField ft fn <- fields ]), 697 C.TypeDef (C.Struct struct_name) type_name ] 698 699{- 700This enumeration: 701\begin{verbatim} 702typedef enum { 703 foo, bar, baz 704} some_enum; 705\end{verbatim} 706 707Generates the following code: 708\begin{verbatim} 709enum ifname_some_enum_t { 710 ifname_some_enum_t_foo = 1, 711 ifname_some_enum_t_bar = 2, 712 ifname_some_enum_t_baz = 3, 713} 714\end{verbatim} 715-} 716 717define_type ifname (TEnum name elements) = 718 C.EnumDecl (type_c_name1 ifname name) 719 [ C.EnumItem (type_c_enum ifname e) Nothing | e <- elements ] 720