1{- 2 GCBackend: Flounder stub generator for generic code 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 GCBackend where 15 16import Data.Char 17 18import qualified CAbsSyntax as C 19import Syntax 20import GHBackend (flounder_backends, export_fn_name, bind_fn_name, accept_fn_name, connect_fn_name, connect_handlers_fn_name, disconnect_handlers_fn_name, rpc_tx_vtbl_type, rpc_init_fn_name) 21import qualified Backend 22import BackendCommon 23import LMP (lmp_bind_type, lmp_bind_fn_name) 24import qualified UMP (bind_type, bind_fn_name) 25import qualified UMP_IPI (bind_type, bind_fn_name) 26import qualified Multihop (m_bind_type, m_bind_fn_name) 27import Local (local_init_fn_name) 28 29 30-- import GHBackend (msg_signature_generic, intf_vtbl_param) 31 32-- name of the bind continuation function 33bind_cont_name :: String -> String 34bind_cont_name ifn = ifscope ifn "bind_continuation_direct" 35 36-- name of an alternative bind continuation function 37bind_cont_name2 :: String -> String 38bind_cont_name2 ifn = ifscope ifn "bind_contination_multihop" 39 40-- Name of the RPC function 41rpc_fn_name ifn mn = idscope ifn mn "rpc" 42local_rpc_fn_name ifn mn = idscope ifn mn "local_rpc" 43 44-- Name of the RPC vtable 45rpc_vtbl_name ifn = ifscope ifn "rpc_vtbl" 46local_rpc_vtbl_name ifn = ifscope ifn "local_rpc_vtbl" 47 48-- Name of the error handler 49rpc_error_fn_name :: String -> String 50rpc_error_fn_name ifn = ifscope ifn "rpc_client_error" 51 52compile :: String -> String -> Interface -> String 53compile infile outfile interface = 54 unlines $ C.pp_unit $ stub_body infile interface 55 56stub_body :: String -> Interface -> C.Unit 57stub_body infile (Interface ifn descr decls) = C.UnitList [ 58 intf_preamble infile ifn descr, 59 C.Blank, 60 61 C.Include C.Standard "barrelfish/barrelfish.h", 62 C.Include C.Standard "flounder/flounder_support.h", 63 C.Include C.Standard ("if/" ++ ifn ++ "_defs.h"), 64 C.Blank, 65 66 C.MultiComment [ "Export function" ], 67 export_fn_def ifn, 68 C.Blank, 69 70 C.MultiComment [ "Functions to accept/connect over a already shared frame" ], 71 accept_fn_def ifn, 72 C.Blank, 73 74 C.MultiComment [ "Generic bind function" ], 75 -- the two bind functions use the idc drivers in a different order 76 bind_cont_def ifn (bind_cont_name ifn) (bind_backends ifn (bind_cont_name ifn)), 77 bind_cont_def ifn (bind_cont_name2 ifn) (multihop_bind_backends ifn (bind_cont_name2 ifn)), 78 bind_fn_def ifn, 79 connect_fn_def ifn] 80 81 82compile_message_handlers :: String -> String -> Interface -> String 83compile_message_handlers infile outfile interface = 84 unlines $ C.pp_unit $ stub_body_message_handlers infile interface 85 86stub_body_message_handlers :: String -> Interface -> C.Unit 87stub_body_message_handlers infile (Interface ifn descr decls) = C.UnitList [ 88 intf_preamble infile ifn descr, 89 C.Blank, 90 91 C.Include C.Standard "barrelfish/barrelfish.h", 92 C.Include C.Standard "flounder/flounder_support.h", 93 C.Include C.Standard ("if/" ++ ifn ++ "_defs.h"), 94 C.Blank, 95 96 C.MultiComment [ "Message handlers" ], 97 C.UnitList [ msg_handler ifn m types | m@(Message MMessage _ _ _) <- messages ], 98 C.UnitList [ msg_handler ifn m types | m@(Message MResponse _ _ _) <- messages ], 99 C.UnitList [ msg_handler ifn m types | m <- rpcs ], 100 C.Blank, 101 102 C.MultiComment [ "Connect handlers function" ], 103 connect_handlers_fn_def ifn messages, 104 C.Blank, 105 106 C.MultiComment [ "Disconnect handlers function" ], 107 disconnect_handlers_fn_def ifn messages, 108 C.Blank, 109 110 C.MultiComment [ "RPC wrapper functions" ], 111 C.UnitList [ rpc_fn ifn types m | m <- rpcs ], 112 C.UnitList [ local_rpc_fn ifn types m | m <- rpcs ], 113 C.Blank, 114 115 C.MultiComment [ "RPC Vtable" ], 116 rpc_vtbl ifn rpcs, 117 local_rpc_vtbl ifn rpcs, 118 119 C.MultiComment [ "RPC init function" ], 120 rpc_init_fn ifn rpcs, 121 122 C.Blank] 123 124 where 125 (types, messagedecls) = Backend.partitionTypesMessages decls 126 messages = rpcs_to_msgs messagedecls 127 rpcs = [m | m@(RPC _ _ _) <- messagedecls] 128 129 130msg_handler :: String -> MessageDef -> [TypeDef] -> C.Unit 131msg_handler ifname msg@(Message _ mn args _) types = C.FunctionDef C.Static (C.TypeName "void") name [C.Param (C.Ptr C.Void) "arg"] [ 132 localvar (C.Ptr $ C.Struct $ intf_bind_type ifname) 133 intf_bind_var (Just $ C.Variable "arg"), 134 localvar (C.TypeName "errval_t") "err" Nothing, 135 if null args then C.SBlank else localvar (C.Struct $ msg_argstruct_name RX ifname mn) "arguments" (Just (bindvar `C.DerefField` "rx_union" `C.FieldOf` mn)), 136 C.SBlank, 137 138 C.Ex $ C.Assignment errvar $ C.CallInd receive_next [bindvar], 139 C.Ex $ C.Call "assert" [C.Call "err_is_ok" [errvar]], 140 C.StmtList $ call_message_handler_msgargs ifname mn types args 141 ] 142 where 143 name = msg_handler_fn_name ifname msg 144 receive_next = C.DerefField bindvar "receive_next" 145 146msg_handler ifname msg@(RPC mn args a) types = C.FunctionDef C.Static (C.TypeName "void") name [C.Param (C.Ptr C.Void) "arg"] [ 147 localvar (C.Ptr $ C.Struct $ intf_bind_type ifname) 148 intf_bind_var (Just $ C.Variable "arg"), 149 localvar (C.TypeName "errval_t") "err" Nothing, 150 if null in_args then C.SBlank else localvar (C.Struct $ msg_argstruct_name RX ifname (rpc_call_name mn)) "arguments" (Just (bindvar `C.DerefField` "rx_union" `C.FieldOf` (rpc_call_name mn))), 151 localvar (C.TypeName "uint32_t") "token" (Just $ binding_incoming_token), 152 C.SBlank, 153 154 C.Ex $ C.Assignment errvar $ C.CallInd receive_next [bindvar], 155 C.Ex $ C.Call "assert" [C.Call "err_is_ok" [errvar]], 156 C.If (rpc_rx_handler) [ 157 if null out_args then C.SBlank else localvar (C.Struct $ msg_argstruct_name RX ifname (rpc_resp_name mn)) "result" Nothing, 158 C.StmtList $ call_rpc_handler ifname mn types args, 159 C.Ex $ C.Call "thread_set_outgoing_token" [C.Binary C.BitwiseAnd (C.Variable "token") (C.Variable "~1" )], 160 C.StmtList $ send_response ifname mn types args 161 ] [ 162 C.StmtList $ call_message_handler_rpcargs ifname mn types args 163 ] 164 ] 165 where 166 name = msg_handler_fn_name ifname (RPC (rpc_call_name mn) args a) 167 receive_next = C.DerefField bindvar "receive_next" 168 rpc_rx_handler = C.DerefField bindvar "rpc_rx_vtbl" `C.FieldOf` (rpc_call_name mn) 169 in_args = [a | RPCArgIn tr a <- args] 170 out_args = [a | RPCArgOut tr a <- args] 171 tx_handler = C.DerefField bindvar "tx_vtbl" `C.FieldOf` (rpc_resp_name mn) 172 binding_outgoing_token = C.DerefField bindvar "outgoing_token" 173 binding_incoming_token = C.DerefField bindvar "incoming_token" 174 175connect_handlers_fn_def :: String -> [MessageDef] -> C.Unit 176connect_handlers_fn_def n messages = 177 C.FunctionDef C.Static (C.TypeName "errval_t") (connect_handlers_fn_name n) 178 [C.Param (C.Ptr $ C.Struct $ intf_bind_type n) intf_bind_var] [ 179 localvar (C.TypeName "errval_t") "err" Nothing, 180 181 C.StmtList [connect_handler n m | m <- messages], 182 C.Return $ C.Variable "SYS_ERR_OK" 183 ] 184 185connect_handler :: String -> MessageDef -> C.Stmt 186connect_handler n msg@(Message _ mn _ _) = C.StmtList [ 187 C.Ex $ C.Call "flounder_support_waitset_chanstate_init_persistent" [message_chanstate], 188 C.Ex $ C.Assignment errvar $ C.Call "flounder_support_register" [waitset, message_chanstate, closure, C.Variable "false"], 189 C.Ex $ C.Assignment (C.DerefField message_chanstate "trigger") $ C.CallInd (bindvar `C.DerefField` "get_receiving_chanstate") [bindvar], 190 C.Ex $ C.Call "assert" [C.Call "err_is_ok" [errvar]] 191 ] 192 where 193 waitset = bindvar `C.DerefField` "waitset" 194 message_chanstate = C.Binary C.Plus (C.DerefField bindvar "message_chanstate") (C.Variable $ msg_enum_elem_name n mn) 195 closure = C.StructConstant "event_closure" 196 [("handler", C.Variable $ msg_handler_fn_name n msg), ("arg", bindvar)] 197 198disconnect_handlers_fn_def :: String -> [MessageDef] -> C.Unit 199disconnect_handlers_fn_def n messages = 200 C.FunctionDef C.Static (C.TypeName "errval_t") (disconnect_handlers_fn_name n) 201 [C.Param (C.Ptr $ C.Struct $ intf_bind_type n) intf_bind_var] [ 202 C.StmtList [disconnect_handler n m | m <- messages], 203 C.Return $ C.Variable "SYS_ERR_OK" 204 ] 205 206disconnect_handler :: String -> MessageDef -> C.Stmt 207disconnect_handler n msg@(Message _ mn _ _) = C.StmtList [ 208 C.Ex $ C.Call "flounder_support_deregister_chan" [message_chanstate] 209 ] 210 where 211 message_chanstate = C.Binary C.Plus (C.DerefField bindvar "message_chanstate") (C.Variable $ msg_enum_elem_name n mn) 212 213export_fn_def :: String -> C.Unit 214export_fn_def n = 215 C.FunctionDef C.NoScope (C.TypeName "errval_t") (export_fn_name n) params [ 216 localvar (C.Ptr $ C.Struct $ export_type n) "e" 217 (Just $ C.Call "malloc" [C.SizeOfT $ C.Struct $ export_type n]), 218 C.If (C.Binary C.Equals exportvar (C.Variable "NULL")) 219 [C.Return $ C.Variable "LIB_ERR_MALLOC_FAIL"] [], 220 C.SBlank, 221 C.SComment "fill in common parts of export struct", 222 C.StmtList [C.Ex $ C.Assignment dste (C.Variable srcn) | (dste, srcn) <- [ 223 (exportvar `C.DerefField` "connect_cb", "connect_cb"), 224 (exportvar `C.DerefField` "waitset", "ws"), 225 (exportvar `C.DerefField` "st", "st"), 226 (commonvar `C.FieldOf` "export_callback", "export_cb"), 227 (commonvar `C.FieldOf` "flags", "flags"), 228 (commonvar `C.FieldOf` "connect_cb_st", "e"), 229 (commonvar `C.FieldOf` "export_cb_st", "st")]], 230 C.SBlank, 231 C.SComment "fill in connect handler for each enabled backend", 232 C.StmtList [ 233 C.SIfDef ("CONFIG_FLOUNDER_BACKEND_" ++ (map toUpper drv)) 234 [C.Ex $ C.Assignment 235 (commonvar `C.FieldOf` (drv_connect_callback drv)) 236 (C.Variable $ drv_connect_handler_name drv n)] [] 237 | drv <- flounder_backends ], 238 C.SBlank, 239 240 C.Return $ C.Call "idc_export_service" [C.AddressOf commonvar] 241 ] 242 where 243 params = [ C.Param (C.Ptr $ C.TypeName "void") "st", 244 C.Param (C.Ptr $ C.TypeName "idc_export_callback_fn") "export_cb", 245 C.Param (C.Ptr $ C.TypeName $ connect_callback_name n) "connect_cb", 246 C.Param (C.Ptr $ C.Struct "waitset") "ws", 247 C.Param (C.TypeName "idc_export_flags_t") "flags"] 248 exportvar = C.Variable "e" 249 commonvar = exportvar `C.DerefField` "common" 250 251 -- XXX: UMP_IPI uses the UMP connect callback 252 drv_connect_callback "ump_ipi" = drv_connect_callback "ump" 253 drv_connect_callback drv = drv ++ "_connect_callback" 254 255accept_fn_def :: String -> C.Unit 256accept_fn_def n = 257 C.FunctionDef C.NoScope (C.TypeName "errval_t") (accept_fn_name n) params [ 258 C.StmtList [ 259 -- #ifdef CONFIG_FLOUNDER_BACKEND_UMP 260 C.SIfDef "CONFIG_FLOUNDER_BACKEND_UMP" [ 261 C.Return $ C.Call (drv_accept_fn_name "ump" n) 262 [ C.Variable intf_frameinfo_var, 263 C.Variable "st", 264 C.Variable intf_cont_var, 265 C.Variable "ws", 266 C.Variable "flags"] 267 ] 268 -- #else 269 [ C.StmtList [ 270 C.Ex $ C.Call "assert" [ 271 C.Unary C.Not $ C.StringConstant "UMP backend not enabled!" 272 ], 273 C.Return $ C.Variable "ERR_NOTIMP" 274 ] 275 ] 276 ] 277 ] 278 where 279 params = [ C.Param (C.Ptr $ C.Struct $ intf_frameinfo_type n) intf_frameinfo_var, 280 C.Param (C.Ptr $ C.TypeName "void") "st", 281 -- C.Param (C.Ptr $ C.TypeName "idc_export_callback_fn") "export_cb", 282 C.Param (C.Ptr $ C.TypeName $ intf_bind_cont_type n) intf_cont_var, 283 C.Param (C.Ptr $ C.Struct "waitset") "ws", 284 C.Param (C.TypeName "idc_export_flags_t") "flags"] 285 286 287connect_fn_def :: String -> C.Unit 288connect_fn_def n = 289 C.FunctionDef C.NoScope (C.TypeName "errval_t") (connect_fn_name n) params [ 290 C.StmtList [ 291 -- #ifdef CONFIG_FLOUNDER_BACKEND_UMP 292 C.SIfDef "CONFIG_FLOUNDER_BACKEND_UMP" [ 293 C.Return $ C.Call (drv_connect_fn_name "ump" n) 294 [ C.Variable intf_frameinfo_var, 295 C.Variable intf_cont_var, 296 C.Variable "st", 297 C.Variable "ws", 298 C.Variable "flags" ] 299 ] 300 -- #else 301 [ C.StmtList [ 302 C.Ex $ C.Call "assert" [ 303 C.Unary C.Not $ C.StringConstant "UMP backend not enabled!" 304 ], 305 C.Return $ C.Variable "ERR_NOTIMP" 306 ] 307 ] ] 308 ] 309 where 310 params = [ C.Param (C.Ptr $ C.Struct $ intf_frameinfo_type n) intf_frameinfo_var, 311 C.Param (C.Ptr $ C.TypeName $ intf_bind_cont_type n) intf_cont_var, 312 C.Param (C.Ptr $ C.TypeName "void") "st", 313 C.Param (C.Ptr $ C.Struct "waitset") "ws", 314 C.Param (C.TypeName "idc_bind_flags_t") "flags"] 315 316 317-- bind continuation function 318bind_cont_def :: String -> String -> [BindBackend] -> C.Unit 319bind_cont_def ifn fn_name backends = 320 C.FunctionDef C.Static C.Void fn_name params [ 321 C.SComment "This bind cont function uses the different backends in the following order:", 322 C.SComment $ unwords $ map flounder_backend backends, 323 C.SBlank, 324 325 localvar (C.Ptr $ C.Struct "flounder_generic_bind_attempt") "b" 326 (Just $ C.Variable "st"), 327 C.Switch driver_num cases 328 [C.Ex $ C.Call "assert" [C.Unary C.Not $ C.StringConstant "invalid state"]], 329 C.SBlank, 330 C.Label "out", 331 C.Ex $ C.Call (connect_handlers_fn_name ifn) [C.Variable intf_bind_var], 332 C.Ex $ C.CallInd (C.Cast (C.Ptr $ C.TypeName $ intf_bind_cont_type ifn) 333 (bindst `C.DerefField` "callback")) 334 [bindst `C.DerefField` "st", errvar, C.Variable intf_bind_var], 335 C.Ex $ C.Call "free" [bindst] 336 ] 337 where 338 params = [ C.Param (C.Ptr $ C.Void) "st", 339 C.Param (C.TypeName "errval_t") "err", 340 C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var] 341 driver_num = bindst `C.DerefField` "driver_num" 342 bindst = C.Variable "b" 343 cases = [ C.Case (C.NumConstant $ toInteger n) (mkcase n) 344 | n <- [0 .. length backends] ] 345 346 mkcase n 347 | n == 0 = try_next 348 349 | n == length backends = [ 350 C.SIfDef config_prev_driver 351 [C.If (test_cb_success prev_backend) 352 -- success! 353 [success_callback] 354 -- failure, but clean up attempt 355 [C.StmtList $ cleanup_bind prev_backend, 356 C.If (C.Unary C.Not $ test_cb_try_next prev_backend) 357 [fail_callback errvar] 358 []] 359 ] 360 [], 361 fail_callback (C.Variable "FLOUNDER_ERR_GENERIC_BIND_NO_MORE_DRIVERS") 362 ] 363 364 | otherwise = [ 365 C.SIfDef config_prev_driver 366 [C.If (test_cb_success prev_backend) 367 -- success! 368 [success_callback] 369 370 -- failure, cleanup and decide whether to continue 371 [C.StmtList $ cleanup_bind prev_backend, 372 C.If (test_cb_try_next prev_backend) 373 [C.Goto ("try_next_" ++ show n)] 374 [C.SComment "report permanent failure to user", 375 fail_callback errvar] 376 ], 377 378 C.Label ("try_next_" ++ show n) 379 ] [], 380 381 -- previous driver not enabled, just try the next 382 C.StmtList try_next] 383 where 384 prev_backend = backends !! (n - 1) 385 next_backend = backends !! n 386 config_prev_driver = "CONFIG_FLOUNDER_BACKEND_" 387 ++ (map toUpper (flounder_backend prev_backend)) 388 config_next_driver = "CONFIG_FLOUNDER_BACKEND_" 389 ++ (map toUpper (flounder_backend next_backend)) 390 391 try_next = [C.Ex $ C.PostInc driver_num, 392 C.SIfDef config_next_driver 393 [C.SComment "try next backend", 394 C.StmtList $ start_bind next_backend, 395 C.If (C.Call "err_is_fail" [errvar]) 396 -- bind attempt failed 397 [C.StmtList $ cleanup_bind next_backend, 398 fail_callback errvar] 399 [C.ReturnVoid]] 400 [C.SComment "skip non-enabled backend (fall through)"]] 401 402 fail_callback err = C.StmtList $ 403 (if err /= errvar 404 then [C.Ex $ C.Assignment errvar err] 405 else []) 406 ++ [ 407 C.Ex $ C.Assignment (C.Variable intf_bind_var) (C.Variable "NULL"), 408 C.Goto "out"] 409 410 success_callback = C.Goto "out" 411 412 413bind_fn_def :: String -> C.Unit 414bind_fn_def n = 415 C.FunctionDef C.NoScope (C.TypeName "errval_t") (bind_fn_name n) params [ 416 C.SComment "allocate state", 417 localvar (C.Ptr $ C.Struct "flounder_generic_bind_attempt") "b" 418 (Just $ C.Call "malloc" [C.SizeOfT $ C.Struct "flounder_generic_bind_attempt"]), 419 C.If (C.Binary C.Equals (C.Variable "b") (C.Variable "NULL")) 420 [C.Return $ C.Variable "LIB_ERR_MALLOC_FAIL"] [], 421 C.SBlank, 422 C.SComment "fill in binding state", 423 C.StmtList [C.Ex $ C.Assignment (C.Variable "b" `C.DerefField` dstf) srce 424 | (dstf, srce) <- [ 425 ("iref", C.Variable "iref"), 426 ("waitset", C.Variable "waitset"), 427 ("driver_num", C.NumConstant 0), 428 ("callback", C.Variable intf_cont_var), 429 ("st", C.Variable "st"), 430 ("flags", C.Variable "flags")]], 431 C.SBlank, 432 C.If (C.Binary C.BitwiseAnd (C.Variable "flags") (C.Variable "IDC_BIND_FLAG_MULTIHOP")) 433 [C.Ex $ C.Call (bind_cont_name2 n) [C.Variable "b", C.Variable "SYS_ERR_OK", C.Variable "NULL"]] 434 [C.Ex $ C.Call (bind_cont_name n) [C.Variable "b", C.Variable "SYS_ERR_OK", C.Variable "NULL"]], 435 C.SBlank, 436 C.Return $ C.Variable "SYS_ERR_OK" 437 ] 438 where 439 params = [ C.Param (C.TypeName "iref_t") "iref", 440 C.Param (C.Ptr $ C.TypeName $ intf_bind_cont_type n) intf_cont_var, 441 C.Param (C.Ptr $ C.TypeName "void") "st", 442 C.Param (C.Ptr $ C.Struct "waitset") "waitset", 443 C.Param (C.TypeName "idc_bind_flags_t") "flags" ] 444 445rpc_rx_union_elem :: String -> String -> C.Expr 446rpc_rx_union_elem mn fn = 447 C.FieldOf (C.FieldOf (C.DerefField bindvar "rx_union") 448 (rpc_resp_name mn)) fn 449 450rpc_fn :: String -> [TypeDef] -> MessageDef -> C.Unit 451rpc_fn ifn typedefs msg@(RPC n args _) = 452 C.FunctionDef C.Static (C.TypeName "errval_t") (rpc_fn_name ifn n) params [ 453 localvar (C.TypeName "errval_t") errvar_name (Just $ C.Variable "SYS_ERR_OK"), 454 C.Ex $ C.Call "assert" [C.Unary C.Not rpc_progress_var], 455 C.Ex $ C.Call "assert" [C.Binary C.Equals async_err_var (C.Variable "SYS_ERR_OK")], 456 C.Ex $ C.Call "thread_set_rpc_in_progress" [C.Variable "true"], 457 C.SBlank, 458 C.SComment "set provided caprefs on underlying binding", 459 binding_save_rx_slots, 460 C.SBlank, 461 C.SComment "call send function", 462 C.Ex $ C.Assignment binding_error (C.Variable "SYS_ERR_OK"), 463 C.Ex $ C.Call "thread_set_outgoing_token" [C.Call "thread_set_token" [message_chanstate]], 464 C.Ex $ C.Assignment errvar $ C.CallInd tx_func tx_func_args, 465 C.If (C.Call "err_is_fail" [errvar]) [ 466 C.Goto "out"] [], 467 C.SBlank, 468 C.SComment "wait for message to be sent and reply or error to be present", 469 C.Ex $ C.Assignment errvar $ C.Call "wait_for_channel" 470 [waitset_var, message_chanstate, C.AddressOf binding_error], 471 C.SBlank, 472 C.If (C.Call "err_is_fail" [errvar]) [ 473 C.Goto "out"] [], 474 C.SBlank, 475 476 C.StmtList [assign typedefs arg | arg <- rxargs], 477 C.Ex $ C.Assignment errvar $ C.CallInd receive_next [bindvar], 478 C.Label "out", 479 C.Ex $ C.Call "thread_set_rpc_in_progress" [C.Variable "false"], 480 C.Ex $ C.Call "thread_clear_token" [receiving_chanstate], 481 C.Return errvar 482 ] 483 where 484 params = [C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var] 485 ++ concat [rpc_argdecl2 TX ifn typedefs a | a <- args] 486 rpc_progress_var = C.Call "thread_get_rpc_in_progress" [] 487 async_err_var = C.Call "thread_get_async_error" [] 488 waitset_var = C.DerefField bindvar "waitset" 489 tx_func = C.DerefField bindvar "tx_vtbl" `C.FieldOf` (rpc_call_name n) 490 tx_func_args = [bindvar, C.Variable "BLOCKING_CONT"] ++ (map C.Variable $ concat $ map mkargs txargs) 491 mkargs (Arg _ (Name an)) = [an] 492 mkargs (Arg _ (StringArray an _)) = [an] 493 mkargs (Arg _ (DynamicArray an al _)) = [an, al] 494 (txargs, rxargs) = partition_rpc_args args 495 is_cap_arg (Arg (Builtin t) _) = t == Cap || t == GiveAwayCap 496 is_cap_arg (Arg _ _) = False 497 rx_cap_args = filter is_cap_arg rxargs 498 binding_save_rx_slot (Arg tr (Name an)) = C.Ex $ 499 C.Call "thread_store_recv_slot" [(C.DerefPtr $ C.Variable an)] 500 binding_save_rx_slots = C.StmtList [ binding_save_rx_slot c | c <- rx_cap_args ] 501 token_name = "token" 502 outgoing_token = bindvar `C.DerefField` "outgoing_token" 503 receiving_chanstate = C.CallInd (bindvar `C.DerefField` "get_receiving_chanstate") [bindvar] 504 binding_error = C.DerefField bindvar "error" 505 message_chanstate = C.Binary C.Plus (C.DerefField bindvar "message_chanstate") (C.Variable $ msg_enum_elem_name ifn (rpc_resp_name n)) 506 receive_next = C.DerefField bindvar "receive_next" 507 assign td (Arg tr (Name an)) = case lookup_typeref typedefs tr of 508 TArray t n _ -> C.If (rpc_rx_union_elem n an) [ C.Ex $ C.Call "mem__cpy" [ 509 (rpc_rx_union_elem n an), 510 (C.Variable an), 511 C.SizeOfT $ C.TypeName (type_c_name1 ifn n)]][] 512 _ -> C.If (C.Variable an) [ 513 C.Ex $ C.Assignment (C.DerefPtr $ C.Variable an) (rpc_rx_union_elem n an)] [] 514 assign _ (Arg _ (StringArray an l)) = C.If (C.Variable an) [ 515 C.Ex $ C.Call "strncpy" [(C.Variable an), (rpc_rx_union_elem n an), C.NumConstant l] 516 ] [] 517 assign _ (Arg _ (DynamicArray an al l)) = C.If (C.Binary C.And (C.Variable an) (C.Variable al)) [ 518 C.Ex $ C.Assignment (C.DerefPtr $ C.Variable al) (rpc_rx_union_elem n al), 519 C.Ex $ C.Call "memcpy" [(C.Variable an), (rpc_rx_union_elem n an), C.DerefPtr $ C.Variable al] 520 ] [] 521 errvar_name = "_err" 522 errvar = C.Variable errvar_name 523 524 525 526local_rpc_fn :: String -> [TypeDef] -> MessageDef -> C.Unit 527local_rpc_fn ifn typedefs msg@(RPC n args _) = 528 C.FunctionDef C.Static (C.TypeName "errval_t") (local_rpc_fn_name ifn n) params [ 529 C.Ex $ C.Call "assert" [C.Binary C.NotEquals tx_func (C.Variable "NULL")], 530 C.Return $ C.CallInd tx_func (localbindvar:(map C.Variable $ concat $ map mkargs rpc_args)) 531 ] 532 where 533 params = [C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var] 534 ++ concat [rpc_argdecl2 TX ifn typedefs a | a <- args] 535 rpc_args = map rpc_arg args 536 tx_func = C.DerefField localbindvar "rpc_rx_vtbl" `C.FieldOf` (rpc_call_name n) 537 localbindvar = C.DerefField bindvar "local_binding" 538 rpc_arg (RPCArgIn t v) = Arg t v 539 rpc_arg (RPCArgOut t v) = Arg t v 540 mkargs (Arg _ (Name an)) = [an] 541 mkargs (Arg _ (StringArray an _)) = [an] 542 mkargs (Arg _ (DynamicArray an al _)) = [an, al] 543 (txargs, rxargs) = partition_rpc_args args 544 545rpc_vtbl :: String -> [MessageDef] -> C.Unit 546rpc_vtbl ifn ml = 547 C.StructDef C.Static (rpc_tx_vtbl_type ifn) (rpc_vtbl_name ifn) fields 548 where 549 fields = [let mn = msg_name m in (mn, rpc_fn_name ifn mn) | m <- ml] 550 551local_rpc_vtbl :: String -> [MessageDef] -> C.Unit 552local_rpc_vtbl ifn ml = 553 C.StructDef C.Static (rpc_tx_vtbl_type ifn) (local_rpc_vtbl_name ifn) fields 554 where 555 fields = [let mn = msg_name m in (mn, local_rpc_fn_name ifn mn) | m <- ml] 556 557 558arg_names :: MessageArgument -> [String] 559arg_names (Arg _ v) = var_names v 560 where 561 var_names (Name n) = [n] 562 var_names (StringArray n _) = [n] 563 var_names (DynamicArray n1 n2 _) = [n1, n2] 564 565rpc_init_fn :: String -> [MessageDef] -> C.Unit 566rpc_init_fn ifn ml = C.FunctionDef C.NoScope (C.Void) 567 (rpc_init_fn_name ifn) (rpc_init_fn_params ifn) $ 568 [ 569 C.SBlank, 570 C.SComment "Setup state of RPC client object", 571 C.If (C.DerefField bindvar "local_binding") [ 572 C.Ex $ C.Assignment (C.DerefField bindvar "rpc_tx_vtbl") (C.Variable $ local_rpc_vtbl_name ifn) 573 ][ 574 C.Ex $ C.Assignment (C.DerefField bindvar "rpc_tx_vtbl") (C.Variable $ rpc_vtbl_name ifn) 575 ], 576 C.SBlank, 577 C.SComment "Set RX handlers on binding object for RPCs", 578 C.StmtList [C.Ex $ C.Assignment (C.FieldOf (C.DerefField bindvar "rx_vtbl") 579 (rpc_resp_name mn)) 580 (C.Variable "NULL") | RPC mn _ _ <- ml], 581 C.Ex $ C.Assignment (bindvar `C.DerefField` "error_handler") (C.Variable "NULL"), 582 C.SBlank, 583 C.ReturnVoid] 584 where 585 rpc_init_fn_params n = [C.Param (C.Ptr $ C.Struct (intf_bind_type n)) "_binding"] 586 587---------------------------------------------------------------------------- 588-- everything that we need to know about a backend to attempt a generic bind 589---------------------------------------------------------------------------- 590data BindBackend = BindBackend { 591 flounder_backend :: String, -- name of the flounder backend 592 start_bind :: [C.Stmt], -- code to attempt a bind 593 test_cb_success :: C.Expr, -- expression to test if a bind succeeded (in the callback) 594 test_cb_try_next :: C.Expr, -- expression to test if a bind might succeed with another backend 595 cleanup_bind :: [C.Stmt] -- code to cleanup a failed bind 596} 597 598-- the available bind backends 599-- Cation: order of list matters (we will try to bind in that order) 600bind_backends :: String -> String -> [BindBackend] 601bind_backends ifn cont_fn_name = map (\i -> i ifn (C.Variable cont_fn_name)) 602 [lmp_bind_backend, 603 local_bind_backend, 604 ump_ipi_bind_backend, 605 ump_bind_backend, 606 multihop_bind_backend] 607 608-- backends in different order (prefer multihop over ump, etc.) 609multihop_bind_backends :: String -> String -> [BindBackend] 610multihop_bind_backends ifn cont_fn_name = map (\i -> i ifn (C.Variable cont_fn_name)) 611 [lmp_bind_backend, 612 multihop_bind_backend, 613 ump_ipi_bind_backend, 614 ump_bind_backend] 615 616bindst = C.Variable "b" 617binding = bindst `C.DerefField` "binding" 618bind_iref = bindst `C.DerefField` "iref" 619waitset = bindst `C.DerefField` "waitset" 620flags = bindst `C.DerefField` "flags" 621 622lmp_bind_backend ifn cont = 623 BindBackend { 624 flounder_backend = "lmp", 625 start_bind = [ 626 C.Ex $ C.Assignment binding $ 627 C.Call "malloc" [C.SizeOfT $ C.Struct $ lmp_bind_type ifn], 628 C.Ex $ C.Call "assert" [C.Binary C.NotEquals binding (C.Variable "NULL")], 629 C.Ex $ C.Assignment errvar $ 630 C.Call (lmp_bind_fn_name ifn) [binding, bind_iref, cont, C.Variable "b", waitset, 631 flags, 632 C.Variable "DEFAULT_LMP_BUF_WORDS"] 633 ], 634 test_cb_success = C.Call "err_is_ok" [errvar], 635 test_cb_try_next = C.Binary C.Or 636 (C.Binary C.Equals (C.Call "err_no" [errvar]) (C.Variable "MON_ERR_IDC_BIND_NOT_SAME_CORE")) 637 (C.Binary C.Equals (C.Call "err_no" [errvar]) (C.Variable "MON_ERR_IDC_BIND_LOCAL")), 638 cleanup_bind = [ C.Ex $ C.Call "free" [binding] ] 639 } 640 641local_bind_backend ifn (C.Variable cont) = 642 BindBackend { 643 flounder_backend = "local", 644 start_bind = [ 645 C.If (C.Binary C.Equals (C.Call "err_no" [errvar]) (C.Variable "MON_ERR_IDC_BIND_LOCAL")) 646 [ 647 C.Ex $ C.Assignment binding $ C.Call "malloc" [C.SizeOfT $ C.Struct $ intf_bind_type ifn], 648 C.Ex $ C.Call "assert" [C.Binary C.NotEquals binding (C.Variable "NULL")], 649 localvar (C.Ptr $ C.Struct "idc_export") "e" $ Nothing, 650 localvar (C.Ptr $ C.Void) "ret_binding" $ Nothing, 651 C.Ex $ C.Assignment errvar $ C.Call "idc_get_service" [bind_iref, C.AddressOf $ C.Variable "e"], 652 C.Ex $ C.CallInd (C.DerefField (C.Variable "e") "local_connect_callback") [C.Variable "e", binding, C.AddressOf $ C.Variable "ret_binding"], 653 C.Ex $ C.Call (local_init_fn_name ifn) [binding, waitset, C.Variable "ret_binding"], 654 C.Ex $ C.Call cont [C.Variable "b", C.Variable "SYS_ERR_OK", binding] 655 ] [ 656 C.Ex $ C.Call cont [C.Variable "b", errvar, C.Variable "NULL"], 657 C.Ex $ C.Assignment errvar (C.Variable "SYS_ERR_OK") 658 ] 659 ], 660 test_cb_success = C.Call "err_is_ok" [errvar], 661 test_cb_try_next = C.Variable "true", 662 cleanup_bind = [] 663 } 664 665ump_bind_backend ifn cont = 666 BindBackend { 667 flounder_backend = "ump", 668 start_bind = [ 669 C.Ex $ C.Assignment binding $ 670 C.Call "malloc" [C.SizeOfT $ C.Struct $ UMP.bind_type ifn], 671 C.Ex $ C.Call "assert" [C.Binary C.NotEquals binding (C.Variable "NULL")], 672 C.Ex $ C.Assignment errvar $ 673 C.Call (UMP.bind_fn_name ifn) [binding, bind_iref, cont, C.Variable "b", waitset, 674 flags, 675 C.Variable "DEFAULT_UMP_BUFLEN", 676 C.Variable "DEFAULT_UMP_BUFLEN"] 677 ], 678 test_cb_success = C.Call "err_is_ok" [errvar], 679 test_cb_try_next = C.Variable "true", 680 cleanup_bind = [ C.Ex $ C.Call "free" [binding] ] 681 } 682 683ump_ipi_bind_backend ifn cont = 684 BindBackend { 685 flounder_backend = "ump_ipi", 686 start_bind = [ 687 C.Ex $ C.Assignment binding $ 688 C.Call "malloc" [C.SizeOfT $ C.Struct $ UMP_IPI.bind_type ifn], 689 C.Ex $ C.Call "assert" [C.Binary C.NotEquals binding (C.Variable "NULL")], 690 C.Ex $ C.Assignment errvar $ 691 C.Call (UMP_IPI.bind_fn_name ifn) [binding, bind_iref, cont, C.Variable "b", waitset, 692 flags, 693 C.Variable "DEFAULT_UMP_BUFLEN", 694 C.Variable "DEFAULT_UMP_BUFLEN"] 695 ], 696 test_cb_success = C.Call "err_is_ok" [errvar], 697 test_cb_try_next = C.Variable "true", 698 cleanup_bind = [ C.Ex $ C.Call "free" [binding] ] 699 } 700 701multihop_bind_backend ifn cont = 702 BindBackend { 703 flounder_backend = "multihop", 704 start_bind = [C.Ex $ C.Assignment binding $ 705 C.Call "malloc" [C.SizeOfT $ C.Struct $ Multihop.m_bind_type ifn], 706 C.Ex $ C.Call "assert" [C.Binary C.NotEquals binding (C.Variable "NULL")], 707 C.Ex $ C.Assignment errvar $ 708 C.Call (Multihop.m_bind_fn_name ifn) [binding, bind_iref, cont, C.Variable "b", waitset, flags]], 709 test_cb_success = C.Call "err_is_ok" [errvar], 710 test_cb_try_next = C.Variable "true", 711 cleanup_bind = [ C.Ex $ C.Call "free" [binding] ] 712 } 713