1{- 2 UMPCommon.hs: Flounder stub generator for cross-core shared memory message passing. 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 UMPCommon where 15 16import Data.Char 17import Data.Maybe 18 19import qualified CAbsSyntax as C 20import qualified Backend 21import Arch 22import BackendCommon 23import Syntax 24import MsgFragments 25import GHBackend (connect_handlers_fn_name, disconnect_handlers_fn_name) 26 27-- parameters used to modify the behaviour of this backend 28data UMPParams = UMPParams { 29 ump_payload :: Int, -- UMP payload size in bytes, excluding header 30 ump_drv :: String, -- name of underlying interconnect driver 31 ump_arch :: Arch, 32 33 ump_binding_extra_fields :: [C.Param], -- extra fields in binding struct 34 ump_extra_includes :: [String], -- extra includes in header 35 ump_extra_protos :: String -> [C.Unit], -- extra prototypes in header 36 ump_extra_fns :: String -> [C.Unit], -- extra functions in stub 37 38 ump_register_recv :: String -> [C.Stmt], -- register for receive 39 ump_deregister_recv :: String -> [C.Stmt], -- deregister 40 ump_accept_alloc_notify :: Maybe (String -> [C.Stmt]), -- code to allocate notify state for accept 41 ump_bind_alloc_notify :: Maybe (String -> [C.Stmt]), -- code to allocate notify state for bind 42 ump_store_notify_cap :: String -> C.Expr -> [C.Stmt], -- code to store the remote notify cap 43 ump_notify :: [C.Stmt], -- send notification 44 ump_binding_extra_fields_init :: [C.Stmt], -- initialize extra fields in binding structure upon bind 45 ump_connect_extra_fields_init :: [C.Stmt] -- initialize extra fields in binding structure upon connect 46} 47 48template_params = UMPParams { 49 ump_payload = undefined, 50 ump_drv = "ump", 51 ump_arch = undefined, 52 53 ump_binding_extra_fields = [], 54 ump_extra_includes = [], 55 56 ump_extra_protos = \ifn -> [], 57 ump_extra_fns = \ifn -> [], 58 59 ump_register_recv = undefined, 60 ump_deregister_recv = undefined, 61 ump_accept_alloc_notify = Nothing, 62 ump_bind_alloc_notify = Nothing, 63 ump_store_notify_cap = \ifn v -> [C.SComment "notify cap ignored"], 64 ump_notify = [], 65 ump_binding_extra_fields_init = [], 66 ump_connect_extra_fields_init = [] 67} 68 69------------------------------------------------------------------------ 70-- Language mapping: C identifier names 71------------------------------------------------------------------------ 72 73ump_ifscope :: UMPParams -> String -> String -> String 74ump_ifscope p ifn s = ifscope ifn ((ump_drv p) ++ "_" ++ s) 75 76-- Name of the binding struct 77my_bind_type :: UMPParams -> String -> String 78my_bind_type p ifn = ump_ifscope p ifn "binding" 79 80-- Name of the local variable used for the UMP-specific binding type 81my_bind_var_name :: String 82my_bind_var_name = "b" 83my_bindvar = C.Variable my_bind_var_name 84 85-- Name of the bind function 86bind_fn_name p n = ump_ifscope p n "bind" 87 88-- Name of the tx_bind_msg function 89tx_bind_msg_fn_name p n = ump_ifscope p n "tx_bind_msg" 90 91-- Name of the tx_bind_reply function 92tx_bind_reply_fn_name p n = ump_ifscope p n "tx_bind_reply" 93 94-- Name of the connect function 95connect_fn_name p n = ump_ifscope p n "connect" 96 97-- Name of the accept function 98accept_fn_name p n = ump_ifscope p n "accept" 99 100-- Name of the bind continuation function 101bind_cont_fn_name p n = ump_ifscope p n "bind_continuation" 102 103-- Name of the continuation for new monitor bindings 104new_monitor_cont_fn_name p n = ump_ifscope p n "new_monitor_binding_continuation" 105 106-- Name of the destroy function 107destroy_fn_name p n = ump_ifscope p n "destroy" 108 109-- Name of the transmit function 110tx_fn_name p ifn mn = idscope ifn mn ((ump_drv p) ++ "_send") 111 112-- Name of the transmit handler 113tx_handler_name p ifn = ump_ifscope p ifn "send_handler" 114 115-- Name of the cap transmit handler 116tx_cap_handler_name p ifn = ump_ifscope p ifn "cap_send_handler" 117 118-- Name of the transmit vtable 119tx_vtbl_name p ifn = ump_ifscope p ifn "tx_vtbl" 120 121-- Name of the receive handler 122rx_handler_name p ifn = ump_ifscope p ifn "rx_handler" 123 124-- Name of the cap send/recv handlers 125cap_rx_handler_name p ifn = ump_ifscope p ifn "cap_rx_handler" 126 127-- Names of the control functions 128change_waitset_fn_name p ifn = ump_ifscope p ifn "change_waitset" 129 130-- Name of the continuation that runs when we get the monitor mutex 131monitor_mutex_cont_name p ifn = ump_ifscope p ifn "monitor_mutex_cont" 132 133-- Name of the receive next function that should be called when a binding 134-- can start receiving next message 135receive_next_fn_name p ifn = ump_ifscope p ifn "receive_next" 136get_receiving_chanstate_fn_name p ifn = ump_ifscope p ifn "get_receiving_chanstate" 137 138------------------------------------------------------------------------ 139-- Language mapping: Create the header file for this interconnect driver 140------------------------------------------------------------------------ 141 142header :: UMPParams -> String -> String -> Interface -> String 143header p infile outfile intf = 144 unlines $ C.pp_unit $ header_file intf (header_body p infile intf) 145 where 146 header_file :: Interface -> [C.Unit] -> C.Unit 147 header_file interface@(Interface name _ _) body = 148 let sym = "__" ++ name ++ "_" ++ (map toUpper (ump_drv p)) ++ "_H" 149 in C.IfNDef sym ([ C.Define sym [] "1"] ++ body) [] 150 151header_body :: UMPParams -> String -> Interface -> [C.Unit] 152header_body p infile interface@(Interface name descr decls) = [ 153 intf_preamble infile name descr, 154 C.Blank, 155 C.MultiComment [ (map toUpper (ump_drv p)) ++ " interconnect driver" ], 156 C.Blank, 157 C.Include C.Standard $ "barrelfish/ump_chan.h", 158 C.Include C.Standard "flounder/flounder_support_ump.h", 159 C.UnitList $ [C.Include C.Standard i | i <- ump_extra_includes p], 160 C.Blank, 161 binding_struct p name, 162 C.Blank, 163 destroy_function_proto p name, 164 bind_function_proto p name, 165 connect_handler_proto p name, 166 rx_handler_proto p name, 167 accept_function_proto p name, 168 connect_function_proto p name, 169 C.UnitList $ ump_extra_protos p name, 170 C.Blank 171 ] 172 173 174connect_function_proto :: UMPParams -> String -> C.Unit 175connect_function_proto p n = 176 C.GVarDecl C.Extern C.NonConst 177 (C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing 178 where 179 name = connect_fn_name p n 180 params = connect_params p n 181 182connect_params p n = [ C.Param (C.Ptr $ C.Struct $ intf_frameinfo_type n) intf_frameinfo_var, 183 C.Param (C.Ptr $ C.TypeName $ intf_bind_cont_type n) intf_cont_var, 184 C.Param (C.Ptr $ C.TypeName "void") "st", 185 C.Param (C.Ptr $ C.Struct "waitset") "ws", 186 C.Param (C.TypeName "idc_bind_flags_t") "flags" ] 187 188accept_function_proto :: UMPParams -> String -> C.Unit 189accept_function_proto p n = 190 C.GVarDecl C.Extern C.NonConst 191 (C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing 192 where 193 name = accept_fn_name p n 194 params = accept_params p n 195 196accept_params p n = [ C.Param (C.Ptr $ C.Struct $ intf_frameinfo_type n) intf_frameinfo_var, 197 C.Param (C.Ptr $ C.TypeName "void") "st", 198 C.Param (C.Ptr $ C.TypeName $ intf_bind_cont_type n) intf_cont_var, 199 C.Param (C.Ptr $ C.Struct "waitset") "ws", 200 C.Param (C.TypeName "idc_export_flags_t") "flags" ] 201 202 203destroy_function_proto :: UMPParams -> String -> C.Unit 204destroy_function_proto p n = 205 C.GVarDecl C.Extern C.NonConst 206 (C.Function C.NoScope C.Void params) name Nothing 207 where 208 name = destroy_fn_name p n 209 params = [C.Param (C.Ptr $ C.Struct (my_bind_type p n)) "b"] 210 211bind_function_proto :: UMPParams -> String -> C.Unit 212bind_function_proto p n = 213 C.GVarDecl C.Extern C.NonConst 214 (C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing 215 where 216 name = bind_fn_name p n 217 params = bind_params p n 218 219bind_params p n = [ C.Param (C.Ptr $ C.Struct (my_bind_type p n)) "b", 220 C.Param (C.TypeName "iref_t") "iref", 221 C.Param (C.Ptr $ C.TypeName $ intf_bind_cont_type n) intf_cont_var, 222 C.Param (C.Ptr $ C.TypeName "void") "st", 223 C.Param (C.Ptr $ C.Struct "waitset") "waitset", 224 C.Param (C.TypeName "idc_bind_flags_t") "flags", 225 C.Param (C.TypeName "size_t") "inchanlen", 226 C.Param (C.TypeName "size_t") "outchanlen" ] 227 228connect_handler_proto :: UMPParams -> String -> C.Unit 229connect_handler_proto p ifn = C.GVarDecl C.Extern C.NonConst 230 (C.Function C.NoScope (C.TypeName "errval_t") (connect_handler_params p)) 231 (drv_connect_handler_name (ump_drv p) ifn) Nothing 232 233connect_handler_params :: UMPParams -> [C.Param] 234connect_handler_params p 235 = [C.Param (C.Ptr $ C.Void) "st", 236 C.Param (C.Ptr $ C.Struct "monitor_binding") "mb", 237 C.Param (C.TypeName "uintptr_t") "mon_id", 238 C.Param (C.Struct "capref") "frame", 239 C.Param (C.TypeName "size_t") "inchanlen", 240 C.Param (C.TypeName "size_t") "outchanlen", 241 C.Param (C.Struct "capref") "notify_cap"] 242 243binding_struct :: UMPParams -> String -> C.Unit 244binding_struct p ifn = C.StructDecl (my_bind_type p ifn) fields 245 where 246 fields = [ 247 C.Param (C.Struct $ intf_bind_type ifn) "b", 248 C.Param (C.Struct "flounder_ump_state") "ump_state", 249 C.ParamBlank, 250 -- these are needed for the new monitor continuation to know the bind parameters 251 C.ParamComment "bind params for the new monitor continuation", 252 C.Param (C.TypeName "iref_t") "iref", 253 C.Param (C.TypeName "size_t") "inchanlen", 254 C.Param (C.TypeName "size_t") "outchanlen", 255 C.ParamBlank, 256 C.ParamComment "flag indicating that transfers of caps are not supported", 257 C.Param (C.TypeName "uint8_t") "no_cap_transfer", 258 C.Param (C.TypeName "uint8_t") "is_client" 259 ] 260 ++ ump_binding_extra_fields p 261 262rx_handler_proto p ifn = C.GVarDecl C.Extern C.NonConst 263 (C.Function C.NoScope C.Void [C.Param (C.Ptr C.Void) "arg"]) 264 (rx_handler_name p ifn) Nothing 265 266------------------------------------------------------------------------ 267-- Language mapping: Create the stub (implementation) for this interconnect driver 268------------------------------------------------------------------------ 269 270stub :: UMPParams -> String -> String -> Interface -> String 271stub p infile outfile intf = unlines $ C.pp_unit $ stub_body p infile intf 272 273stub_body :: UMPParams -> String -> Interface -> C.Unit 274stub_body p infile intf@(Interface ifn descr decls) = C.UnitList [ 275 intf_preamble infile ifn descr, 276 C.Blank, 277 C.IfDef ("CONFIG_FLOUNDER_BACKEND_" ++ (map toUpper (ump_drv p))) 278 [ C.Blank, 279 C.MultiComment [ "Generated Stub for " ++ (map toUpper (ump_drv p)) ], 280 C.Blank, 281 282 C.Include C.Standard "barrelfish/barrelfish.h", 283 C.Include C.Standard "barrelfish/monitor_client.h", 284 C.Include C.Standard "flounder/flounder_support.h", 285 C.Include C.Standard "flounder/flounder_support_ump.h", 286 C.Include C.Standard ("if/" ++ ifn ++ "_defs.h"), 287 C.Blank, 288 289 C.MultiComment [ "Send handler function" ], 290 tx_handler p ifn msg_specs, 291 C.UnitList $ if (drvname == "ump") then [ tx_bind_msg p ifn ] else [], 292 tx_bind_reply p ifn, 293 C.Blank, 294 295 C.MultiComment [ "Capability sender function" ], 296 tx_cap_handler p ifn msg_specs, 297 C.Blank, 298 299 300 C.MultiComment [ "Receive handler" ], 301 rx_handler p ifn types messages msg_specs, 302 C.Blank, 303 304 C.MultiComment [ "Cap send/receive handlers" ], 305 cap_rx_handler p ifn types messages msg_specs, 306 C.Blank, 307 308 C.UnitList $ if has_caps then 309 [C.MultiComment [ "Monitor mutex acquire continuation" ], 310 monitor_mutex_cont p ifn, 311 C.Blank] 312 else [], 313 314 C.MultiComment [ "Message sender functions" ], 315 316 C.UnitList [ tx_fn p ifn types msg spec | (msg, spec) <- zip messages msg_specs ], 317 C.Blank, 318 319 C.MultiComment [ "Send vtable" ], 320 tx_vtbl p ifn messages, 321 322 C.MultiComment [ "Control functions" ], 323 can_send_fn_def drvname ifn, 324 register_send_fn_def drvname ifn, 325 default_error_handler_fn_def drvname ifn, 326 change_waitset_fn_def p ifn, 327 generic_control_fn_def drvname ifn, 328 receive_next_fn_def p ifn, 329 get_receiving_chanstate_fn_def p ifn, 330 C.Blank, 331 332 C.MultiComment [ "Function to destroy the binding state" ], 333 destroy_fn p ifn, 334 C.Blank, 335 336 C.MultiComment [ "Bind function" ], 337 bind_cont_fn p ifn, 338 C.UnitList $ ump_extra_fns p ifn, 339 new_monitor_cont_fn p ifn, 340 bind_fn p ifn, 341 C.Blank, 342 343 C.MultiComment [ "Connect callback for export" ], 344 connect_handler_fn p ifn, 345 C.Blank, 346 347 C.MultiComment [ "Functions to accept/connect over a already shared frame" ], 348 C.UnitList $ if (drvname == "ump") then [ accept_fn p ifn, connect_fn p ifn ] else [] 349 ] [] ] 350 where 351 drvname = ump_drv p 352 (types, messagedecls) = Backend.partitionTypesMessages decls 353 messages = rpcs_to_msgs messagedecls 354 msg_specs = map (build_msg_spec myarch words_per_frag False types) messages 355 words_per_frag = (ump_payload p) `div` (wordsize (ump_arch p) `div` 8) 356 357 has_caps = [1 | MsgSpec _ _ caps <- msg_specs, caps /= []] /= [] 358 359 -- hack: ensure that we raise an error if any types in the messages depend 360 -- on the architecture-specific sizes (uintptr etc.) 361 myarch = (ump_arch p) { 362 ptrsize = error $ "cannot compile this interface for UMP;" ++ 363 " it uses intptr/uintptr which are non-portable", 364 sizesize = error $ "cannot compile this interface for UMP;" ++ 365 " it uses the size type which is non-portable" 366 } 367 368destroy_fn :: UMPParams -> String -> C.Unit 369destroy_fn p ifn = 370 C.FunctionDef C.NoScope C.Void (destroy_fn_name p ifn) params 371 [C.StmtList common_destroy, 372 C.Ex $ C.Call "ump_chan_destroy" 373 [C.AddressOf $ statevar `C.FieldOf` "chan"]] 374 where 375 statevar = C.DerefField my_bindvar "ump_state" 376 common_destroy = binding_struct_destroy ifn (C.DerefField my_bindvar "b") 377 params = [C.Param (C.Ptr $ C.Struct (my_bind_type p ifn)) "b"] 378 379 380connect_fn :: UMPParams -> String -> C.Unit 381connect_fn p ifn = 382 C.FunctionDef C.NoScope (C.TypeName "errval_t") (connect_fn_name p ifn) params [ 383 localvar (C.TypeName "errval_t") "err" Nothing, 384 385 C.SComment "allocate storage for binding", 386 localvar (C.Ptr $ C.Struct $ my_bind_type p ifn) my_bind_var_name 387 $ Just $ C.Call "malloc" [C.SizeOfT $ C.Struct $ my_bind_type p ifn], 388 C.If (C.Binary C.Equals my_bindvar (C.Variable "NULL")) 389 [C.Return $ C.Variable "LIB_ERR_MALLOC_FAIL"] [], 390 C.SBlank, 391 392 localvar (C.Ptr $ C.Struct $ intf_bind_type ifn) 393 intf_bind_var (Just $ C.AddressOf $ my_bindvar `C.DerefField` "b"), 394 395 C.StmtList common_init, 396 C.Ex $ C.Call "flounder_stub_ump_state_init" [C.AddressOf statevar, my_bindvar], 397 C.Ex $ C.Assignment (common_field "change_waitset") (C.Variable $ change_waitset_fn_name p ifn), 398 C.Ex $ C.Assignment (common_field "control") (C.Variable $ generic_control_fn_name (ump_drv p) ifn), 399 C.Ex $ C.Assignment (common_field "receive_next") (C.Variable $ receive_next_fn_name p ifn), 400 C.Ex $ C.Assignment (common_field "get_receiving_chanstate") (C.Variable $ get_receiving_chanstate_fn_name p ifn), 401 C.Ex $ C.Assignment (common_field "st") (C.Variable "st"), 402 C.Ex $ C.Assignment (intf_bind_v `C.FieldOf` "bind_cont") (C.Variable intf_cont_var), 403 404 C.Ex $ C.Assignment errvar $ C.Call "ump_chan_init" 405 [C.AddressOf $ statevar `C.FieldOf` "chan", 406 (C.DerefField (C.Variable intf_frameinfo_var) "inbuf"), 407 (C.DerefField (C.Variable intf_frameinfo_var) "inbufsize"), 408 (C.DerefField (C.Variable intf_frameinfo_var) "outbuf"), 409 (C.DerefField (C.Variable intf_frameinfo_var) "outbufsize")], 410 C.If (C.Call "err_is_fail" [errvar]) 411 [C.Ex $ C.Call (destroy_fn_name p ifn) [my_bindvar], 412 C.Return $ 413 C.Call "err_push" [errvar, C.Variable "LIB_ERR_UMP_CHAN_INIT"]] 414 [], 415 C.Ex $ C.Assignment (C.FieldOf (common_field "tx_cont_chanstate") "trigger") (C.AddressOf $ C.FieldOf chanvar "send_waitset"), 416 C.SBlank, 417 418 C.Ex $ C.Assignment (sendvar) (C.DerefField (C.Variable "_frameinfo") "sendbase"), 419 C.Ex $ C.Assignment (my_bindvar `C.DerefField` "inchanlen") (C.DerefField (C.Variable intf_frameinfo_var) "inbufsize"), 420 C.Ex $ C.Assignment (my_bindvar `C.DerefField` "outchanlen") (C.DerefField (C.Variable intf_frameinfo_var) "outbufsize"), 421 C.Ex $ C.Assignment (my_bindvar `C.DerefField` "no_cap_transfer") (C.Variable "1"), 422 C.Ex $ C.Assignment (my_bindvar `C.DerefField` "is_client") (C.Variable "1"), 423 C.StmtList $ (ump_binding_extra_fields_init p), 424 C.SBlank, 425 426 C.StmtList $ ump_store_notify_cap p ifn (C.Variable "notify_cap"), 427 C.StmtList $ setup_cap_handlers p ifn, 428 C.SBlank, 429 430 C.StmtList $ register_recv p ifn, 431 C.SBlank, 432 433 C.Return $ C.Call (tx_bind_msg_fn_name p ifn) [my_bindvar]] 434 435 where 436 params = connect_params p ifn 437 errvar = C.Variable "err" 438 statevar = C.DerefField my_bindvar "ump_state" 439 chanvar = statevar `C.FieldOf` "chan" 440 sendvar = chanvar `C.FieldOf` "sendid" 441 common_init = binding_struct_init (ump_drv p) ifn 442 (C.DerefField my_bindvar "b") 443 (C.Variable "ws") 444 (C.Variable $ tx_vtbl_name p ifn) 445 intf_bind_v = C.DerefField my_bindvar "b" 446 common_field f = intf_bind_v `C.FieldOf` f 447 receiving_chanstate = my_bindvar `C.DerefField` "b" `C.FieldOf` "receiving_chanstate" 448 449accept_fn :: UMPParams -> String -> C.Unit 450accept_fn p ifn = 451 C.FunctionDef C.NoScope (C.TypeName "errval_t") (accept_fn_name p ifn) params [ 452 localvar (C.TypeName "errval_t") "err" Nothing, 453 C.SBlank, 454 C.SComment "allocate storage for binding", 455 localvar (C.Ptr $ C.Struct $ my_bind_type p ifn) my_bind_var_name 456 $ Just $ C.Call "malloc" [C.SizeOfT $ C.Struct $ my_bind_type p ifn], 457 C.If (C.Binary C.Equals my_bindvar (C.Variable "NULL")) 458 [C.Return $ C.Variable "LIB_ERR_MALLOC_FAIL"] [], 459 C.SBlank, 460 461 localvar (C.Ptr $ C.Struct $ intf_bind_type ifn) 462 intf_bind_var (Just $ C.AddressOf $ my_bindvar `C.DerefField` "b"), 463 C.StmtList common_init, 464 C.Ex $ C.Call "flounder_stub_ump_state_init" [C.AddressOf statevar, my_bindvar], 465 C.Ex $ C.Assignment errvar $ C.Call "ump_chan_init" 466 [C.AddressOf $ statevar `C.FieldOf` "chan", 467 (C.DerefField (C.Variable intf_frameinfo_var) "inbuf"), 468 (C.DerefField (C.Variable intf_frameinfo_var) "inbufsize"), 469 (C.DerefField (C.Variable intf_frameinfo_var) "outbuf"), 470 (C.DerefField (C.Variable intf_frameinfo_var) "outbufsize")], 471 C.If (C.Call "err_is_fail" [errvar]) 472 [C.Ex $ C.Call (destroy_fn_name p ifn) [my_bindvar], 473 C.Return $ 474 C.Call "err_push" [errvar, C.Variable "LIB_ERR_UMP_CHAN_INIT"]] 475 [], 476 C.Ex $ C.Assignment (C.FieldOf (common_field "tx_cont_chanstate") "trigger") (C.AddressOf $ C.FieldOf chanvar "send_waitset"), 477 C.SBlank, 478 479 C.Ex $ C.Assignment (sendvar) (C.DerefField (C.Variable "_frameinfo") "sendbase"), 480 C.Ex $ C.Assignment (common_field "change_waitset") (C.Variable $ change_waitset_fn_name p ifn), 481 C.Ex $ C.Assignment (common_field "control") (C.Variable $ generic_control_fn_name (ump_drv p) ifn), 482 C.Ex $ C.Assignment (common_field "receive_next") (C.Variable $ receive_next_fn_name p ifn), 483 C.Ex $ C.Assignment (common_field "get_receiving_chanstate") (C.Variable $ get_receiving_chanstate_fn_name p ifn), 484 C.Ex $ C.Assignment (common_field "st") (C.Variable "st"), 485 C.Ex $ C.Assignment (common_field "bind_cont") (C.Variable intf_cont_var), 486 C.Ex $ C.Assignment (my_bindvar `C.DerefField` "inchanlen") (C.DerefField (C.Variable intf_frameinfo_var) "inbufsize"), 487 C.Ex $ C.Assignment (my_bindvar `C.DerefField` "outchanlen") (C.DerefField (C.Variable intf_frameinfo_var) "outbufsize"), 488 C.Ex $ C.Assignment (my_bindvar `C.DerefField` "no_cap_transfer") (C.Variable "1"), 489 C.Ex $ C.Assignment (my_bindvar `C.DerefField` "is_client") (C.Variable "0"), 490 C.StmtList $ register_recv p ifn, 491 C.SBlank, 492 493 C.StmtList $ ump_store_notify_cap p ifn (C.Variable "notify_cap"), 494 C.StmtList $ setup_cap_handlers p ifn, 495 C.SBlank, 496 497 C.Return (C.Variable "SYS_ERR_OK")] 498 where 499 params = accept_params p ifn 500 statevar = C.DerefField my_bindvar "ump_state" 501 chanvar = statevar `C.FieldOf` "chan" 502 sendvar = chanvar `C.FieldOf` "sendid" 503 chanaddr = C.AddressOf $ chanvar 504 common_field f = my_bindvar `C.DerefField` "b" `C.FieldOf` f 505 common_init = binding_struct_init (ump_drv p) ifn 506 (C.DerefField my_bindvar "b") 507 (C.Variable "ws") 508 (C.Variable $ tx_vtbl_name p ifn) 509 510 511bind_fn :: UMPParams -> String -> C.Unit 512bind_fn p ifn = 513 C.FunctionDef C.NoScope (C.TypeName "errval_t") (bind_fn_name p ifn) params [ 514 localvar (C.TypeName "errval_t") "err" Nothing, 515 C.StmtList common_init, 516 C.Ex $ C.Call "flounder_stub_ump_state_init" [C.AddressOf statevar, my_bindvar], 517 C.Ex $ C.Assignment (common_field "change_waitset") (C.Variable $ change_waitset_fn_name p ifn), 518 C.Ex $ C.Assignment (common_field "control") (C.Variable $ generic_control_fn_name (ump_drv p) ifn), 519 C.Ex $ C.Assignment (common_field "receive_next") (C.Variable $ receive_next_fn_name p ifn), 520 C.Ex $ C.Assignment (common_field "get_receiving_chanstate") (C.Variable $ get_receiving_chanstate_fn_name p ifn), 521 C.Ex $ C.Assignment (common_field "st") (C.Variable "st"), 522 C.Ex $ C.Assignment (C.FieldOf (common_field "tx_cont_chanstate") "trigger") (C.AddressOf $ C.FieldOf chanvar "send_waitset"), 523 C.Ex $ C.Assignment (intf_bind_var `C.FieldOf` "bind_cont") (C.Variable intf_cont_var), 524 C.Ex $ C.Assignment (my_bindvar `C.DerefField` "iref") (C.Variable "iref"), 525 C.Ex $ C.Assignment (my_bindvar `C.DerefField` "inchanlen") (C.Variable "inchanlen"), 526 C.Ex $ C.Assignment (my_bindvar `C.DerefField` "outchanlen") (C.Variable "outchanlen"), 527 C.Ex $ C.Assignment (my_bindvar `C.DerefField` "no_cap_transfer") (C.Variable "0"), 528 C.Ex $ C.Assignment (C.FieldOf (common_field "tx_cont_chanstate") "trigger") (C.AddressOf $ C.FieldOf chanvar "send_waitset"), 529 C.StmtList $ (ump_binding_extra_fields_init p), 530 C.SBlank, 531 C.SComment "do we need a new monitor binding?", 532 C.If (C.Binary C.BitwiseAnd (C.Variable "flags") (C.Variable "IDC_BIND_FLAG_RPC_CAP_TRANSFER")) 533 [C.Ex $ C.Assignment errvar $ C.Call "monitor_client_new_binding" 534 [C.Variable (new_monitor_cont_fn_name p ifn), 535 my_bindvar, C.Variable "waitset", 536 C.Variable "DEFAULT_LMP_BUF_WORDS"] 537 ] 538 539 -- no monitor binding, but do we need to alloc notify state? 540 (if isJust (ump_bind_alloc_notify p) 541 then 542 [C.Ex $ C.Assignment (chanvar `C.FieldOf` "monitor_binding") 543 (C.Call "get_monitor_binding" []), 544 C.StmtList $ (fromJust $ ump_bind_alloc_notify p) ifn, 545 C.If (C.Call "err_is_fail" [errvar]) 546 [C.Ex $ C.Assignment errvar $ C.Call "err_push" 547 [errvar, C.Variable "FLOUNDER_ERR_UMP_ALLOC_NOTIFY"]] [] ] 548 else -- nothing special, just call bind 549 [C.Ex $ C.Assignment errvar $ C.Call "ump_chan_bind" 550 [C.AddressOf $ statevar `C.FieldOf` "chan", 551 C.StructConstant "ump_bind_continuation" 552 [("handler", C.Variable (bind_cont_fn_name p ifn)), 553 ("st", my_bindvar)], 554 C.AddressOf $ intf_bind_var `C.FieldOf` "event_qnode", 555 C.Variable "iref", C.Call "get_monitor_binding" [], 556 C.Variable "inchanlen", C.Variable "outchanlen", 557 C.Variable "NULL_CAP"]]), 558 C.SBlank, 559 C.If (C.Call "err_is_fail" [errvar]) 560 [C.Ex $ C.Call (destroy_fn_name p ifn) [my_bindvar]] [], 561 C.Return errvar 562 ] 563 where 564 statevar = C.DerefField my_bindvar "ump_state" 565 chanvar = statevar `C.FieldOf` "chan" 566 common_init = binding_struct_init (ump_drv p) ifn 567 (C.DerefField my_bindvar "b") 568 (C.Variable "waitset") 569 (C.Variable $ tx_vtbl_name p ifn) 570 params = bind_params p ifn 571 intf_bind_var = C.DerefField my_bindvar "b" 572 common_field f = intf_bind_var `C.FieldOf` f 573 receiving_chanstate = my_bindvar `C.DerefField` "b" `C.FieldOf` "receiving_chanstate" 574 575 576new_monitor_cont_fn :: UMPParams -> String -> C.Unit 577new_monitor_cont_fn p ifn = 578 C.FunctionDef C.Static C.Void (new_monitor_cont_fn_name p ifn) params [ 579 localvar (C.Ptr $ C.Struct $ intf_bind_type ifn) 580 intf_bind_var (Just $ C.Variable "st"), 581 localvar (C.Ptr $ C.Struct $ my_bind_type p ifn) 582 my_bind_var_name (Just $ C.Variable "st"), 583 C.SBlank, 584 585 C.If (C.Call "err_is_fail" [errvar]) 586 [C.Ex $ C.Assignment errvar $ 587 C.Call "err_push" [errvar, C.Variable "LIB_ERR_MONITOR_CLIENT_BIND"], 588 C.Goto "out"] [], 589 C.SBlank, 590 591 C.Ex $ C.Assignment (chanvar `C.FieldOf` "monitor_binding") (C.Variable "monitor_binding"), 592 C.StmtList $ if isJust (ump_bind_alloc_notify p) 593 then 594 [C.StmtList $ (fromJust $ ump_bind_alloc_notify p) ifn, 595 C.If (C.Call "err_is_fail" [errvar]) 596 [C.Ex $ C.Assignment errvar $ C.Call "err_push" 597 [errvar, C.Variable "FLOUNDER_ERR_UMP_ALLOC_NOTIFY"], 598 C.Goto "out"] [] ] 599 else 600 [C.SComment "start the bind on the new monitor binding", 601 C.Ex $ C.Assignment errvar $ C.Call "ump_chan_bind" 602 [C.AddressOf $ my_bindvar `C.DerefField` "ump_state" `C.FieldOf` "chan", 603 C.StructConstant "ump_bind_continuation" 604 [("handler", C.Variable (bind_cont_fn_name p ifn)), 605 ("st", my_bindvar)], 606 C.AddressOf $ bindvar `C.DerefField` "event_qnode", 607 my_bindvar `C.DerefField` "iref", 608 C.Variable "monitor_binding", 609 my_bindvar `C.DerefField` "inchanlen", 610 my_bindvar `C.DerefField` "outchanlen", 611 C.Variable "NULL_CAP"]], 612 C.SBlank, 613 614 C.Label "out", 615 C.If (C.Call "err_is_fail" [errvar]) 616 [C.Ex $ C.CallInd (bindvar `C.DerefField` "bind_cont") 617 [bindvar `C.DerefField` "st", errvar, bindvar], 618 C.Ex $ C.Call (destroy_fn_name p ifn) [my_bindvar]] [] 619 ] 620 where 621 params = [C.Param (C.Ptr C.Void) "st", 622 C.Param (C.TypeName "errval_t") "err", 623 C.Param (C.Ptr $ C.Struct "monitor_binding") "monitor_binding"] 624 chanvar = my_bindvar `C.DerefField` "ump_state" `C.FieldOf` "chan" 625 626 627bind_cont_fn :: UMPParams -> String -> C.Unit 628bind_cont_fn p ifn = 629 C.FunctionDef C.Static C.Void (bind_cont_fn_name p ifn) params [ 630 localvar (C.Ptr $ C.Struct $ intf_bind_type ifn) 631 intf_bind_var (Just $ C.Variable "st"), 632 localvar (C.Ptr $ C.Struct $ my_bind_type p ifn) 633 my_bind_var_name (Just $ C.Variable "st"), 634 C.SBlank, 635 636 C.If (C.Call "err_is_ok" [errvar]) 637 [C.StmtList $ ump_store_notify_cap p ifn (C.Variable "notify_cap"), 638 C.StmtList $ setup_cap_handlers p ifn, 639 C.StmtList $ register_recv p ifn] 640 [C.Ex $ C.Call (destroy_fn_name p ifn) [my_bindvar]], 641 C.SBlank, 642 643 C.Ex $ C.CallInd (bindvar `C.DerefField` "bind_cont") 644 [bindvar `C.DerefField` "st", errvar, bindvar]] 645 where 646 params = [C.Param (C.Ptr C.Void) "st", 647 C.Param (C.TypeName "errval_t") "err", 648 C.Param (C.Ptr $ C.Struct "ump_chan") "chan", 649 C.Param (C.Struct "capref") "notify_cap"] 650 errvar = C.Variable "err" 651 chanaddr = C.Variable "chan" 652 653connect_handler_fn :: UMPParams -> String -> C.Unit 654connect_handler_fn p ifn = C.FunctionDef C.NoScope (C.TypeName "errval_t") 655 (drv_connect_handler_name (ump_drv p) ifn) (connect_handler_params p) [ 656 localvar (C.Ptr $ C.Struct $ export_type ifn) "e" $ Just $ C.Variable "st", 657 localvar (C.TypeName "errval_t") "err" Nothing, 658 C.SBlank, 659 C.SComment "allocate storage for binding", 660 localvar (C.Ptr $ C.Struct $ my_bind_type p ifn) my_bind_var_name 661 $ Just $ C.Call "malloc" [C.SizeOfT $ C.Struct $ my_bind_type p ifn], 662 C.If (C.Binary C.Equals my_bindvar (C.Variable "NULL")) 663 [C.Return $ C.Variable "LIB_ERR_MALLOC_FAIL"] [], 664 C.SBlank, 665 666 localvar (C.Ptr $ C.Struct $ intf_bind_type ifn) 667 intf_bind_var (Just $ C.AddressOf $ my_bindvar `C.DerefField` "b"), 668 C.StmtList common_init, 669 C.Ex $ C.Call "flounder_stub_ump_state_init" [C.AddressOf statevar, my_bindvar], 670 C.Ex $ C.Assignment (common_field "change_waitset") (C.Variable $ change_waitset_fn_name p ifn), 671 C.Ex $ C.Assignment (common_field "control") (C.Variable $ generic_control_fn_name (ump_drv p) ifn), 672 C.Ex $ C.Assignment (common_field "receive_next") (C.Variable $ receive_next_fn_name p ifn), 673 C.Ex $ C.Assignment (common_field "get_receiving_chanstate") (C.Variable $ get_receiving_chanstate_fn_name p ifn), 674 C.Ex $ C.Assignment (my_bindvar `C.DerefField` "no_cap_transfer") (C.Variable "0"), 675 C.StmtList $ (ump_connect_extra_fields_init p), 676 C.Ex $ C.Assignment (C.FieldOf (common_field "tx_cont_chanstate") "trigger") (C.AddressOf $ C.FieldOf chanvar "send_waitset"), 677 C.SBlank, 678 679 C.SComment "run user's connect handler", 680 C.Ex $ C.Assignment errvar $ C.CallInd (C.DerefField exportvar "connect_cb") 681 [C.DerefField exportvar "st", bindvar], 682 C.If (C.Call "err_is_fail" [errvar]) 683 [C.SComment "connection refused", 684 C.Ex $ C.Call (destroy_fn_name p ifn) [my_bindvar], 685 C.Return $ errvar] [], 686 C.SBlank, 687 688 C.SComment "accept the connection and setup the channel", 689 C.Ex $ C.Assignment errvar $ C.Call "ump_chan_accept" 690 [chanaddr, C.Variable "mon_id", C.Variable "frame", 691 C.Variable "inchanlen", C.Variable "outchanlen"], 692 C.If (C.Call "err_is_fail" [errvar]) 693 [C.Ex $ C.Assignment errvar $ C.Call "err_push" 694 [errvar, C.Variable "LIB_ERR_UMP_CHAN_ACCEPT"], 695 report_user_err errvar, 696 C.Return $ errvar] [], 697 C.SBlank, 698 699 C.StmtList $ ump_store_notify_cap p ifn (C.Variable "notify_cap"), 700 C.StmtList $ setup_cap_handlers p ifn, 701 C.SBlank, 702 703 C.Ex $ C.Call (connect_handlers_fn_name ifn) [C.Variable intf_bind_var], 704 705 C.StmtList $ if isJust (ump_accept_alloc_notify p) 706 then 707 [C.StmtList $ (fromJust $ ump_accept_alloc_notify p) ifn, 708 C.If (C.Call "err_is_fail" [errvar]) 709 [C.Ex $ C.Assignment errvar $ C.Call "err_push" 710 [errvar, C.Variable "FLOUNDER_ERR_UMP_ALLOC_NOTIFY"], 711 report_user_err errvar, 712 C.Return $ errvar] [] ] 713 else 714 [C.StmtList $ register_recv p ifn, 715 C.SBlank, 716 C.SComment "send back bind reply", 717 C.Ex $ C.Call "ump_chan_send_bind_reply" 718 [C.Variable "mb", chanaddr, C.Variable "SYS_ERR_OK", 719 C.Variable "mon_id", C.Variable "NULL_CAP"], 720 C.SBlank], 721 722 C.Return $ C.Variable "SYS_ERR_OK"] 723 where 724 exportvar = C.Variable "e" 725 statevar = C.DerefField my_bindvar "ump_state" 726 chanvar = statevar `C.FieldOf` "chan" 727 chanaddr = C.AddressOf $ chanvar 728 common_init = binding_struct_init (ump_drv p) ifn 729 (C.DerefField my_bindvar "b") 730 (exportvar `C.DerefField` "waitset") 731 (C.Variable $ tx_vtbl_name p ifn) 732 common_field f = my_bindvar `C.DerefField` "b" `C.FieldOf` f 733 receiving_chanstate = my_bindvar `C.DerefField` "b" `C.FieldOf` "receiving_chanstate" 734 735change_waitset_fn_def :: UMPParams -> String -> C.Unit 736change_waitset_fn_def p ifn = 737 C.FunctionDef C.Static (C.TypeName "errval_t") (change_waitset_fn_name p ifn) params [ 738 localvar (C.Ptr $ C.Struct $ my_bind_type p ifn) 739 my_bind_var_name (Just $ C.Cast (C.Ptr C.Void) bindvar), 740 localvar (C.TypeName "errval_t") "err" Nothing, 741 C.SBlank, 742 743 C.SComment "change waitset on private monitor binding if we have one", 744 C.If (C.Binary C.NotEquals (chanvar `C.FieldOf` "monitor_binding") (C.Call "get_monitor_binding" [])) 745 [C.Ex $ C.Assignment errvar $ 746 C.Call "flounder_support_change_monitor_waitset" 747 [chanvar `C.FieldOf` "monitor_binding", C.Variable "ws"], 748 C.If (C.Call "err_is_fail" [errvar]) 749 [C.Return $ 750 C.Call "err_push" [errvar, C.Variable "FLOUNDER_ERR_CHANGE_MONITOR_WAITSET"]] 751 [] 752 ] [], 753 C.SBlank, 754 C.StmtList $ ump_deregister_recv p ifn, 755 C.If (C.Binary C.And 756 (C.Call "err_is_fail" [errvar]) 757 (C.Binary C.NotEquals (C.Call "err_no" [errvar]) 758 (C.Variable "LIB_ERR_CHAN_NOT_REGISTERED"))) 759 [C.Return $ 760 C.Call "err_push" [errvar, C.Variable "LIB_ERR_CHAN_DEREGISTER_RECV"]] 761 [], 762 C.Ex $ C.Call (disconnect_handlers_fn_name ifn) [bindvar], 763 764 C.SComment "change waitset on binding", 765 C.Ex $ C.Assignment 766 (bindvar `C.DerefField` "waitset") 767 (C.Variable "ws"), 768 C.SBlank, 769 770 C.Ex $ C.Call (connect_handlers_fn_name ifn) [bindvar], 771 C.SComment "re-register for receive (if previously registered)", 772 C.If (C.Call "err_is_ok" [errvar]) [ 773 C.StmtList $ ump_register_recv p ifn, 774 C.If (C.Call "err_is_fail" [errvar]) 775 [C.Return $ 776 C.Call "err_push" [errvar, C.Variable "LIB_ERR_CHAN_REGISTER_RECV"]] 777 [] 778 ] [], 779 C.Return $ C.Variable "SYS_ERR_OK" 780 ] 781 where 782 chanvar = my_bindvar `C.DerefField` "ump_state" `C.FieldOf` "chan" 783 chanaddr = C.AddressOf $ chanvar 784 params = [C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var, 785 C.Param (C.Ptr $ C.Struct "waitset") "ws"] 786 787receive_next_fn_def :: UMPParams -> String -> C.Unit 788receive_next_fn_def p ifn = 789 C.FunctionDef C.Static (C.TypeName "errval_t") (receive_next_fn_name p ifn) params [ 790 localvar (C.TypeName "errval_t") "err" Nothing, 791 localvar (C.Ptr $ C.Struct $ my_bind_type p ifn) 792 my_bind_var_name (Just $ C.Cast (C.Ptr C.Void) $ C.Variable intf_bind_var), 793 C.SBlank, 794 C.StmtList $ register_recv p ifn, 795 C.Return $ C.Variable "SYS_ERR_OK" 796 ] 797 where 798 params = [C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var] 799 800get_receiving_chanstate_fn_def :: UMPParams -> String -> C.Unit 801get_receiving_chanstate_fn_def p ifn = 802 C.FunctionDef C.Static (C.Ptr $ C.Struct "waitset_chanstate") (get_receiving_chanstate_fn_name p ifn) params [ 803 localvar (C.Ptr $ C.Struct $ my_bind_type p ifn) 804 my_bind_var_name (Just $ C.Cast (C.Ptr C.Void) bindvar), 805 C.SBlank, 806 C.Return $ C.Call "ump_chan_get_receiving_channel" [C.AddressOf $ C.FieldOf (C.DerefField my_bindvar "ump_state") "chan"] 807 ] 808 where 809 params = [C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var] 810 811handler_preamble :: UMPParams -> String -> C.Stmt 812handler_preamble p ifn = C.StmtList 813 [C.SComment "Get the binding state from our argument pointer", 814 localvar (C.Ptr $ C.Struct $ intf_bind_type ifn) 815 intf_bind_var (Just $ C.Variable "arg"), 816 localvar (C.Ptr $ C.Struct $ my_bind_type p ifn) 817 my_bind_var_name (Just $ C.Variable "arg"), 818 localvar (C.TypeName "errval_t") "err" Nothing, 819 C.Ex $ C.Assignment errvar (C.Variable "SYS_ERR_OK"), 820 C.SBlank] 821 822tx_cap_handler :: UMPParams -> String -> [MsgSpec] -> C.Unit 823tx_cap_handler p ifn msgspecs = 824 C.FunctionDef C.Static C.Void (tx_cap_handler_name p ifn) [C.Param (C.Ptr C.Void) "arg"] [ 825 handler_preamble p ifn, 826 827 C.Ex $ C.Call "assert" [capst `C.FieldOf` "rx_cap_ack"], 828 C.Ex $ C.Call "assert" [capst `C.FieldOf` "monitor_mutex_held"], 829 C.SBlank, 830 831 C.SComment "Switch on current outgoing message", 832 C.Switch (C.DerefField bindvar "tx_msgnum") cases 833 [C.Ex $ C.Call "assert" 834 [C.Unary C.Not $ C.StringConstant "invalid message number"], 835 report_user_err (C.Variable "FLOUNDER_ERR_INVALID_STATE")] 836 ] 837 where 838 umpst = C.DerefField my_bindvar "ump_state" 839 capst = umpst `C.FieldOf` "capst" 840 cases = [C.Case (C.Variable $ msg_enum_elem_name ifn mn) 841 (tx_cap_handler_case p ifn mn (length frags) caps) 842 | MsgSpec mn frags caps <- msgspecs, caps /= []] 843 844tx_cap_handler_case :: UMPParams -> String -> String -> Int -> [CapFieldTransfer] -> [C.Stmt] 845tx_cap_handler_case p ifn mn nfrags caps = [ 846 C.SComment "Switch on current outgoing cap", 847 C.Switch (capst `C.FieldOf` "tx_capnum") cases 848 [C.Ex $ C.Call "assert" 849 [C.Unary C.Not $ C.StringConstant "invalid cap number"], 850 report_user_err (C.Variable "FLOUNDER_ERR_INVALID_STATE")], 851 C.Break] 852 where 853 give_away_val :: CapTransferMode -> C.Expr 854 give_away_val Copied = C.Variable "false" 855 give_away_val GiveAway = C.Variable "true" 856 umpst = C.DerefField my_bindvar "ump_state" 857 capst = umpst `C.FieldOf` "capst" 858 chan = umpst `C.FieldOf` "chan" 859 cases = [C.Case (C.NumConstant $ toInteger i) $ subcase cap i 860 | (cap, i) <- zip caps [0..]] ++ 861 [C.Case (C.NumConstant $ toInteger $ length caps) last_case] 862 863 last_case = [ 864 -- release our lock on the monitor binding 865 C.Ex $ C.Call "flounder_support_monitor_mutex_unlock" 866 [chan `C.FieldOf` "monitor_binding"], 867 868 -- if we've sent the last cap, and we've sent all the other fragments, we're done 869 C.If (C.Binary C.Equals tx_msgfrag_field 870 (C.NumConstant $ toInteger nfrags)) 871 finished_send [], 872 C.Break] 873 tx_msgfrag_field = C.DerefField bindvar "tx_msg_fragment" 874 875 subcase :: CapFieldTransfer -> Int -> [C.Stmt] 876 subcase (CapFieldTransfer tm cap) ncap = [ 877 C.Ex $ C.Assignment errvar $ C.Call "flounder_stub_send_cap" 878 [C.AddressOf $ capst, chan `C.FieldOf` "monitor_binding", 879 chan `C.FieldOf` "monitor_id", argfield_expr TX mn cap, 880 give_away_val tm, C.Variable $ tx_cap_handler_name p ifn], 881 C.If (C.Call "err_is_fail" [errvar]) 882 [report_user_tx_err errvar, C.Break] [], 883 C.Break] 884 885 886tx_bind_msg :: UMPParams -> String -> C.Unit 887tx_bind_msg p ifn = 888 C.FunctionDef C.Static (C.TypeName "errval_t") (tx_bind_msg_fn_name p ifn) params [ 889 handler_preamble p ifn, 890 891 localvar (C.Volatile $ C.Ptr $ C.Struct "ump_message") "msg" Nothing, 892 localvar (C.Struct "ump_control") "ctrl" Nothing, 893 C.SBlank, 894 895 896 C.SComment "send the next fragment", 897 C.Ex $ C.Assignment ump_token (C.Variable "0"), 898 C.Ex $ C.Assignment msgvar $ C.Call "ump_chan_get_next" [chanaddr, ctrladdr], 899 C.SComment "check if we can send another message", 900 C.If (C.Unary C.Not msgvar) 901 [C.Return (C.Variable "FLOUNDER_ERR_TX_BUSY")] [], 902 C.SBlank, 903 C.Ex $ C.Call "flounder_stub_ump_control_fill" 904 [chanst, ctrladdr, C.Variable $ "FL_UMP_BIND" ], 905-- C.StmtList 906-- [C.Ex $ C.Assignment (msgword n) (fragment_word_to_expr (ump_arch p) ifn "___bind" (words !! n)) 907-- | n <- [0 .. length(words) - 1], words !! n /= []], 908 C.Ex $ C.Assignment (msgword 0) (C.Variable "0xcafebabe"), 909 C.Ex $ C.Call "flounder_stub_ump_barrier" [], 910 C.Ex $ C.Assignment msgheader ctrlvar, 911 C.StmtList finished_send, 912 C.Return (C.Variable "SYS_ERR_OK")] 913 where 914 params = [C.Param (C.Ptr C.Void) "arg"] 915 chanst = C.AddressOf umpst 916 chanaddr = C.AddressOf (C.DerefField chanst "chan") 917 ctrlvar = C.Variable "ctrl" 918 ctrladdr = C.AddressOf ctrlvar 919 umpst = C.DerefField my_bindvar "ump_state" 920 -- stateaddr = C.AddressOf umpst 921 msgvar = C.Variable "msg" 922 msgword n = C.DerefField msgvar "data" `C.SubscriptOf` (C.NumConstant $ toInteger n) 923 msgheader = C.DerefField msgvar "header" `C.FieldOf` "control" 924 ump_token = C.DerefField chanst "token" 925 926 927 928tx_bind_reply :: UMPParams -> String -> C.Unit 929tx_bind_reply p ifn = 930 C.FunctionDef C.Static (C.TypeName "errval_t") (tx_bind_reply_fn_name p ifn) params [ 931 handler_preamble p ifn, 932 933 localvar (C.Volatile $ C.Ptr $ C.Struct "ump_message") "msg" Nothing, 934 localvar (C.Struct "ump_control") "ctrl" Nothing, 935 C.SBlank, 936 937 C.SComment "send the next fragment", 938 C.Ex $ C.Assignment ump_token (C.Variable "0"), 939 C.Ex $ C.Assignment msgvar $ C.Call "ump_chan_get_next" [chanaddr, ctrladdr], 940 C.SComment "check if we can send another message", 941 C.If (C.Unary C.Not msgvar) 942 [C.Return (C.Variable "FLOUNDER_ERR_TX_BUSY")] [], 943 C.Ex $ C.Call "flounder_stub_ump_control_fill" 944 [chanst, ctrladdr, C.Variable $ "FL_UMP_BIND_REPLY" ], 945-- C.StmtList 946-- [C.Ex $ C.Assignment (msgword n) (fragment_word_to_expr (ump_arch p) ifn "___bind" (words !! n)) 947-- | n <- [0 .. length(words) - 1], words !! n /= []], 948 C.Ex $ C.Assignment (msgword 0) (C.Variable "0xcafebabe"), 949 C.Ex $ C.Call "flounder_stub_ump_barrier" [], 950 C.Ex $ C.Assignment msgheader ctrlvar, 951 C.StmtList finished_send, 952 C.Return (C.Variable "SYS_ERR_OK")] 953 where 954 params = [C.Param (C.Ptr C.Void) "arg"] 955 chanst = C.AddressOf umpst 956 chanaddr = C.AddressOf (C.DerefField chanst "chan") 957 umpst = C.DerefField my_bindvar "ump_state" 958 ctrlvar = C.Variable "ctrl" 959 ctrladdr = C.AddressOf ctrlvar 960 -- stateaddr = C.AddressOf umpst 961 msgvar = C.Variable "msg" 962 msgword n = C.DerefField msgvar "data" `C.SubscriptOf` (C.NumConstant $ toInteger n) 963 msgheader = C.DerefField msgvar "header" `C.FieldOf` "control" 964 ump_token = C.DerefField chanst "token" 965 966tx_handler :: UMPParams -> String -> [MsgSpec] -> C.Unit 967tx_handler p ifn msgs = 968 C.FunctionDef C.Static C.Void (tx_handler_name p ifn) [C.Param (C.Ptr C.Void) "arg"] [ 969 handler_preamble p ifn, 970 971 -- local variables (if needed) 972 C.StmtList $ if msgvars_will_be_used then 973 [localvar (C.Volatile $ C.Ptr $ C.Struct "ump_message") "msg" Nothing, 974 localvar (C.Struct "ump_control") "ctrl" Nothing] else [], 975 localvar (C.TypeName "bool") "tx_notify" (Just $ C.Variable "false"), 976 C.SBlank, 977 978 C.SComment "do we need to (and can we) send a cap ack?", 979 C.If (capst `C.FieldOf` "tx_cap_ack") 980 [C.Ex $ C.Call "flounder_stub_ump_send_cap_ack" [C.AddressOf umpst], 981 C.Ex $ C.Assignment (capst `C.FieldOf` "tx_cap_ack") (C.Variable "false")] [], 982 C.SBlank, 983 984 C.SComment "Switch on current outgoing message number", 985 C.Switch (C.DerefField bindvar "tx_msgnum") msgcases 986 [C.Ex $ C.Call "assert" [C.Unary C.Not $ C.StringConstant "invalid msgnum"], 987 report_user_err (C.Variable "FLOUNDER_ERR_INVALID_STATE")], 988 C.SBlank, 989 990 C.SComment "Retry send", 991 C.If (C.Variable "tx_notify") 992 [ 993 localvar (C.Struct "event_closure") "retry_closure" 994 (Just $ C.StructConstant "event_closure" [ 995 ("handler", C.Variable $ tx_handler_name p ifn), ("arg", C.Variable "arg")]), 996 C.Ex $ C.Assignment errvar (C.Call "ump_chan_register_send" [ 997 chanaddr, C.DerefField bindvar "waitset", C.Variable "retry_closure"]), 998 C.Ex $ C.Call "assert" [C.Call "err_is_ok" [errvar]] 999 ] [] 1000 ] 1001 where 1002 inc_fragnum = C.Ex $ C.PostInc $ C.DerefField bindvar "tx_msg_fragment" 1003 tx_msgnum_field = C.DerefField bindvar "tx_msgnum" 1004 umpst = C.DerefField my_bindvar "ump_state" 1005 capst = umpst `C.FieldOf` "capst" 1006 1007 -- variables will be needed only if there are non-string/buffer messages 1008 msgvars_will_be_used 1009 = or [or $ map isMsgFragment frags | MsgSpec _ frags _ <- msgs] 1010 where 1011 isMsgFragment (MsgFragment _) = True 1012 isMsgFragment _ = False 1013 1014 msgcases = (C.Case (C.NumConstant 0) [C.Break]): 1015 [C.Case (C.Variable $ msg_enum_elem_name ifn mn) 1016 $ gen_msgcase mn msgfrags caps 1017 | MsgSpec mn msgfrags caps <- msgs] 1018 1019 gen_msgcase mn msgfrags caps = [ 1020 C.SComment "Switch on current outgoing message fragment", 1021 C.Switch (C.DerefField bindvar "tx_msg_fragment") fragcases 1022 [C.Ex $ C.Call "assert" [C.Unary C.Not $ C.StringConstant "invalid fragment"], 1023 report_user_err (C.Variable "FLOUNDER_ERR_INVALID_STATE")], 1024 C.Break] 1025 1026 where 1027 fragcases = [C.Case (C.NumConstant $ toInteger i) 1028 $ (tx_handler_case p ifn mn frag) ++ gen_epilog i 1029 | (frag, i) <- zip msgfrags [0..]] 1030 ++ [C.Case (C.NumConstant $ toInteger $ length msgfrags) 1031 $ last_frag] 1032 1033 last_frag = [ 1034 C.SComment "we've sent all the fragments, we must just be waiting for caps", 1035 C.Ex $ C.Call "assert" 1036 [C.Binary C.LessThanEq (capst `C.FieldOf` "tx_capnum") 1037 (C.NumConstant $ toInteger $ length caps)], 1038 C.Break] 1039 1040 -- generate the code that runs after the send succeeds 1041 gen_epilog i 1042 | i + 1 == length msgfrags = 1043 [-- send a notification, now we've done a complete message 1044 C.StmtList $ ump_notify p, 1045 inc_fragnum, 1046 -- if the last fragment succeeds, and we've sent all the caps, we're done 1047 -- otherwise we'll need to wait to finish sending the caps 1048 if caps /= [] then 1049 C.If (C.Binary C.Equals (capst `C.FieldOf` "tx_capnum") 1050 (C.NumConstant $ toInteger $ length caps + 1)) 1051 finished_send [] 1052 else C.StmtList finished_send, 1053 C.ReturnVoid] 1054 1055 | otherwise = -- more fragments to go 1056 [inc_fragnum, C.SComment "fall through to next fragment"] 1057 statevar = C.DerefField my_bindvar "ump_state" 1058 chanaddr = C.AddressOf $ C.FieldOf statevar "chan" 1059 1060tx_handler_case :: UMPParams -> String -> String -> MsgFragment -> [C.Stmt] 1061tx_handler_case p ifn mn (MsgFragment words) = [ 1062 C.SComment "send the next fragment", 1063 C.Ex $ C.Assignment ump_token binding_outgoing_token, 1064 C.Ex $ C.Assignment msgvar $ C.Call "ump_chan_get_next" [chanaddr, ctrladdr], 1065 C.SComment "check if we can send another message", 1066 C.If (C.Unary C.Not msgvar) 1067 [C.Ex $ C.Assignment (C.Variable "tx_notify") (C.Variable "true"), 1068 C.Break] [], 1069 C.Ex $ C.Call "flounder_stub_ump_control_fill" 1070 [stateaddr, ctrladdr, C.Variable $ msg_enum_elem_name ifn mn], 1071 C.StmtList 1072 [C.Ex $ C.Assignment (msgword n) (fragment_word_to_expr (ump_arch p) ifn mn (words !! n)) 1073 | n <- [0 .. length(words) - 1], words !! n /= []], 1074 C.Ex $ C.Call "flounder_stub_ump_barrier" [], 1075 C.Ex $ C.Assignment msgheader ctrlvar] 1076 where 1077 ctrlvar = C.Variable "ctrl" 1078 ctrladdr = C.AddressOf ctrlvar 1079 statevar = C.DerefField my_bindvar "ump_state" 1080 stateaddr = C.AddressOf statevar 1081 msgvar = C.Variable "msg" 1082 msgword n = C.DerefField msgvar "data" `C.SubscriptOf` (C.NumConstant $ toInteger n) 1083 msgheader = C.DerefField msgvar "header" `C.FieldOf` "control" 1084 chanaddr = C.AddressOf $ C.FieldOf statevar "chan" 1085 ump_token = C.DerefField chanst "token" 1086 umpst = C.DerefField my_bindvar "ump_state" 1087 chanst = C.AddressOf umpst 1088 binding_outgoing_token = C.DerefField bindvar "outgoing_token" 1089 1090tx_handler_case p ifn mn (OverflowFragment (StringFragment af)) = 1091 [C.Ex $ C.Assignment ump_token binding_outgoing_token, 1092 C.Ex $ C.Assignment errvar (C.Call "flounder_stub_ump_send_string" args), 1093 C.If (C.Call "err_is_fail" [errvar]) [ 1094 -- have we run out of space in the buffer? 1095 C.If (C.Binary C.Equals (C.Call "err_no" [errvar]) 1096 (C.Variable "FLOUNDER_ERR_BUF_SEND_MORE")) 1097 -- yes, better send a notify 1098 [C.Ex $ C.Assignment (C.Variable "tx_notify") (C.Variable "true")] 1099 -- no, some other error happened 1100 [C.SComment "Permanent error, report to user", 1101 report_user_tx_err errvar], 1102 C.Break] []] 1103 where 1104 args = [chan_arg, msgnum_arg, string_arg, pos_arg, len_arg] 1105 chan_arg = C.AddressOf $ C.DerefField my_bindvar "ump_state" 1106 msgnum_arg = C.Variable $ msg_enum_elem_name ifn mn 1107 string_arg = argfield_expr TX mn af 1108 pos_arg = C.AddressOf $ C.DerefField bindvar "tx_str_pos" 1109 len_arg = C.AddressOf $ C.DerefField bindvar "tx_str_len" 1110 ump_token = C.DerefField chanst "token" 1111 umpst = C.DerefField my_bindvar "ump_state" 1112 chanst = C.AddressOf umpst 1113 binding_outgoing_token = C.DerefField bindvar "outgoing_token" 1114 1115tx_handler_case p ifn mn (OverflowFragment (BufferFragment _ afn afl)) = 1116 [C.Ex $ C.Assignment ump_token binding_outgoing_token, 1117 C.Ex $ C.Assignment errvar (C.Call "flounder_stub_ump_send_buf" args), 1118 C.If (C.Call "err_is_fail" [errvar]) [ 1119 -- have we run out of space in the buffer? 1120 C.If (C.Binary C.Equals (C.Call "err_no" [errvar]) 1121 (C.Variable "FLOUNDER_ERR_BUF_SEND_MORE")) 1122 -- yes, better send a notify 1123 [C.Ex $ C.Assignment (C.Variable "tx_notify") (C.Variable "true")] 1124 -- no, some other error happened 1125 [C.SComment "Permanent error, report to user", 1126 report_user_tx_err errvar], 1127 C.Break] []] 1128 where 1129 args = [chan_arg, msgnum_arg, buf_arg, len_arg, pos_arg] 1130 chan_arg = C.AddressOf $ C.DerefField my_bindvar "ump_state" 1131 msgnum_arg = C.Variable $ msg_enum_elem_name ifn mn 1132 buf_arg = argfield_expr TX mn afn 1133 len_arg = argfield_expr TX mn afl 1134 pos_arg = C.AddressOf $ C.DerefField bindvar "tx_str_pos" 1135 ump_token = C.DerefField chanst "token" 1136 umpst = C.DerefField my_bindvar "ump_state" 1137 chanst = C.AddressOf umpst 1138 binding_outgoing_token = C.DerefField bindvar "outgoing_token" 1139 1140tx_fn :: UMPParams -> String -> [TypeDef] -> MessageDef -> MsgSpec -> C.Unit 1141tx_fn p ifn typedefs msg@(Message mtype n args _) (MsgSpec _ _ caps) = 1142 C.FunctionDef C.Static (C.TypeName "errval_t") (tx_fn_name p ifn n) params body 1143 where 1144 params = [binding_param2 ifn, cont_param] ++ ( 1145 concat [ msg_argdecl TX ifn a | a <- args ]) 1146 cont_param = C.Param (C.Struct "event_closure") intf_cont_var 1147 body = [ 1148 localvar (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var (Just $ C.Variable (intf_bind_var ++ "_")), 1149 -- check message size does not exceed receive buffer 1150 C.StmtList [ tx_fn_arg_check_size ifn typedefs n a | a <- args ], 1151 C.Ex $ C.Call "thread_mutex_lock" [C.AddressOf $ C.DerefField bindvar "send_mutex"], 1152 C.Ex $ C.Assignment binding_error (C.Variable "SYS_ERR_OK"), 1153 C.SComment "check that we can accept an outgoing message", 1154 C.If (C.Binary C.NotEquals tx_msgnum_field (C.NumConstant 0)) 1155 [C.Ex $ C.Call "thread_mutex_unlock" [C.AddressOf $ C.DerefField bindvar "send_mutex"], 1156 C.Return $ C.Variable "FLOUNDER_ERR_TX_BUSY"] [], 1157 C.SBlank, 1158 C.SComment "register send continuation", 1159 C.StmtList $ register_txcont (C.Variable intf_cont_var), 1160 C.SBlank, 1161 C.SComment "store message number and arguments", 1162 C.Ex $ C.Assignment binding_outgoing_token (C.Binary C.BitwiseAnd binding_incoming_token (C.Variable "~1" )), 1163 C.Ex $ C.Call "thread_get_outgoing_token" [C.AddressOf binding_outgoing_token], 1164 C.Ex $ C.Assignment tx_msgnum_field (C.Variable $ msg_enum_elem_name ifn n), 1165 C.Ex $ C.Assignment tx_msgfrag_field (C.NumConstant 0), 1166 C.StmtList [ tx_arg_assignment ifn typedefs n a | a <- args ], 1167 C.StmtList $ start_send (ump_drv p) ifn n args, 1168 C.SBlank, 1169 -- if this message has caps, we need to acquire the monitor binding mutex 1170 C.StmtList $ if caps /= [] then 1171 [C.SComment "init cap send state", 1172 C.Ex $ C.Assignment (capst `C.FieldOf` "tx_capnum") (C.NumConstant 0), 1173 C.Ex $ C.Assignment (capst `C.FieldOf` "rx_cap_ack") (C.Variable "false"), 1174 C.Ex $ C.Assignment (capst `C.FieldOf` "monitor_mutex_held") (C.Variable "false"), 1175 C.SBlank, 1176 1177 C.SComment "wait to acquire the monitor binding mutex", 1178 C.Ex $ C.Call "flounder_support_monitor_mutex_enqueue" 1179 [umpst `C.FieldOf` "chan" `C.FieldOf` "monitor_binding", 1180 C.AddressOf $ bindvar `C.DerefField` "event_qnode", 1181 C.StructConstant "event_closure" [ 1182 ("handler", C.Variable $ monitor_mutex_cont_name p ifn), 1183 ("arg", bindvar)]], 1184 C.SBlank] 1185 else [], 1186 C.SComment "try to send!", 1187 C.Ex $ C.Call "thread_mutex_lock" [C.AddressOf $ C.DerefField bindvar "rxtx_mutex"], 1188 C.Ex $ C.Call (tx_handler_name p ifn) [bindvar], 1189 C.Ex $ C.Call "thread_mutex_unlock" [C.AddressOf $ C.DerefField bindvar "rxtx_mutex"], 1190 C.StmtList $ (if caps /= [] then block_sending_with_caps p ifn else block_sending) (C.Variable intf_cont_var), 1191 C.Ex $ C.Call "thread_mutex_unlock" [C.AddressOf $ C.DerefField bindvar "send_mutex"], 1192 C.SBlank, 1193 C.Return binding_error 1194 ] 1195 umpvar = C.Cast (C.Ptr $ C.Struct $ my_bind_type p ifn) bindvar 1196 umpst = C.DerefField umpvar "ump_state" 1197 capst = umpst `C.FieldOf` "capst" 1198 tx_msgnum_field = C.DerefField bindvar "tx_msgnum" 1199 tx_msgfrag_field = C.DerefField bindvar "tx_msg_fragment" 1200 binding_incoming_token = C.DerefField bindvar "incoming_token" 1201 binding_outgoing_token = C.DerefField bindvar "outgoing_token" 1202 1203block_sending_with_caps :: UMPParams -> String -> C.Expr -> [C.Stmt] 1204block_sending_with_caps p ifn cont_ex = [ 1205 C.If (C.Binary C.Equals (cont_ex `C.FieldOf` "handler") (C.Variable "blocking_cont")) 1206 [C.If (C.Binary C.Equals binding_error (C.Variable "SYS_ERR_OK")) [ 1207 localvar (C.Ptr $ C.Struct $ my_bind_type p ifn) 1208 my_bind_var_name (Just $ C.Cast (C.Ptr C.Void) $ bindvar), 1209 localvar (C.Ptr $ C.Struct "waitset") "ws" (Just $ C.Call "flounder_support_get_current_monitor_waitset" [monitor_binding]), 1210 1211 C.Ex $ C.Assignment binding_error $ C.Call "flounder_support_change_monitor_waitset" [monitor_binding, C.DerefField bindvar "waitset"], 1212 C.If (C.Binary C.Equals binding_error (C.Variable "SYS_ERR_OK")) [ 1213 C.Ex $ C.Assignment (C.DerefField tx_cont_chanstate "trigger") $ C.CallInd (bindvar `C.DerefField` "get_receiving_chanstate") [bindvar], 1214 C.Ex $ C.Assignment binding_error $ C.Call "wait_for_channel" [C.DerefField bindvar "waitset", tx_cont_chanstate, C.AddressOf binding_error]] [], 1215 C.If (C.Binary C.Equals binding_error (C.Variable "SYS_ERR_OK")) [ 1216 C.Ex $ C.Assignment binding_error $ C.Call "flounder_support_change_monitor_waitset" [monitor_binding, C.Variable "ws"]] [] 1217 ] [ 1218 C.Ex $ C.Call "flounder_support_deregister_chan" [tx_cont_chanstate] 1219 ] 1220 ] [] 1221 ] where 1222 errvar = C.Variable "_err" 1223 mask = C.CallInd (C.DerefField bindvar "get_receiving_chanstate") [bindvar] 1224 tx_cont_chanstate = C.AddressOf $ bindvar `C.DerefField` "tx_cont_chanstate" 1225 umpst = C.DerefField my_bindvar "ump_state" 1226 chan = umpst `C.FieldOf` "chan" 1227 monitor_binding = chan `C.FieldOf` "monitor_binding" 1228 1229tx_vtbl :: UMPParams -> String -> [MessageDef] -> C.Unit 1230tx_vtbl p ifn ml = 1231 C.StructDef C.Static (intf_vtbl_type ifn TX) (tx_vtbl_name p ifn) fields 1232 where 1233 fields = [let mn = msg_name m in (mn, tx_fn_name p ifn mn) | m <- ml] 1234 1235monitor_mutex_cont :: UMPParams -> String -> C.Unit 1236monitor_mutex_cont p ifn = 1237 C.FunctionDef C.Static C.Void (monitor_mutex_cont_name p ifn) [C.Param (C.Ptr C.Void) "arg"] [ 1238 localvar (C.Ptr $ C.Struct $ my_bind_type p ifn) my_bind_var_name (Just $ C.Variable "arg"), 1239 C.Ex $ C.Call "assert" [C.Unary C.Not (capst `C.FieldOf` "monitor_mutex_held")], 1240 C.Ex $ C.Assignment (capst `C.FieldOf` "monitor_mutex_held") (C.Variable "true"), 1241 C.If (capst `C.FieldOf` "rx_cap_ack") 1242 [C.Ex $ C.Call (tx_cap_handler_name p ifn) [my_bindvar]] [] 1243 ] 1244 where 1245 statevar = C.DerefField my_bindvar "ump_state" 1246 capst = statevar `C.FieldOf` "capst" 1247 1248rx_handler :: UMPParams -> String -> [TypeDef] -> [MessageDef] -> [MsgSpec] -> C.Unit 1249rx_handler p ifn typedefs msgdefs msgs = 1250 C.FunctionDef C.NoScope C.Void (rx_handler_name p ifn) [C.Param (C.Ptr C.Void) "arg"] [ 1251 handler_preamble p ifn, 1252 1253 -- local variables 1254 localvar (C.Volatile $ C.Ptr $ C.Struct "ump_message") "msg" Nothing, 1255 localvar (C.TypeName "int") "msgnum" Nothing, 1256 localvar (C.TypeName "int") "__attribute__ ((unused)) no_register" (Just $ C.NumConstant 0), 1257 localvar (C.TypeName "int") "call_msgnum" $ Just $ C.NumConstant 0, 1258 1259 C.Ex $ C.Call "thread_mutex_lock" [C.AddressOf $ C.DerefField bindvar "rxtx_mutex"], 1260 C.SBlank, 1261 1262 C.While (C.Variable "true") loopbody, 1263 C.SBlank, 1264 1265 C.Label "out", 1266 C.If (C.Unary C.Not (C.Variable "no_register")) 1267 [C.StmtList $ register_recv p ifn] [], 1268 C.SBlank, 1269 1270 -- XXX: hack around the AST to get an attribute on this label, which may not be used 1271 C.Label "out_no_reregister", 1272 C.Ex $ C.Variable "__attribute__((unused))", 1273 1274 C.If (C.Variable "call_msgnum") [C.Ex $ C.Assignment rx_msgnum_field (C.NumConstant 0)] [], 1275 C.Ex $ C.Call "thread_mutex_unlock" [C.AddressOf $ C.DerefField bindvar "rxtx_mutex"], 1276 C.Switch (C.Variable "call_msgnum") call_cases [C.Break] 1277 ] 1278 where 1279 loopbody = [ 1280 C.SComment "try to retrieve a message from the channel", 1281 C.Ex $ C.Assignment errvar 1282 $ C.Call "ump_chan_recv" [chanaddr, 1283 C.AddressOf $ C.Variable "msg"], 1284 1285 C.SComment "check if we succeeded", 1286 C.If (C.Call "err_is_fail" [errvar]) 1287 -- if err_is_fail, check err_no 1288 [C.If (C.Binary C.Equals (C.Call "err_no" [errvar]) 1289 (C.Variable "LIB_ERR_NO_UMP_MSG")) 1290 [C.SComment "no message", C.Break] 1291 [C.SComment "real error", 1292 report_user_err $ C.Call "err_push" 1293 [errvar, C.Variable "LIB_ERR_UMP_CHAN_RECV"], 1294 C.Ex $ C.Call "thread_mutex_unlock" [C.AddressOf $ C.DerefField bindvar "rxtx_mutex"], 1295 C.ReturnVoid] ] 1296 [], 1297 C.SBlank, 1298 1299 C.SComment "process control word", 1300 C.Ex $ C.Assignment (C.Variable "msgnum") 1301 $ C.Call "flounder_stub_ump_control_process" 1302 [stateaddr, 1303 C.Variable "msg" `C.DerefField` "header" `C.FieldOf` "control"], 1304 C.SBlank, 1305 1306 C.SComment "is this a binding message of connect/accept?", 1307 C.If (C.Binary C.Equals (C.Variable "msgnum") (C.Variable "FL_UMP_BIND")) [ 1308 C.Ex $ C.Call "ump_chan_free_message" [C.Variable "msg"], 1309 C.If ((C.Binary C.Equals (C.DerefField my_bindvar "is_client")) (C.Variable "1")) [ 1310 C.SComment "Client should not recv bind messages. Ignore.", 1311 C.Continue] [], 1312 C.SComment "handle bind reply: calling bind callback", 1313 C.Ex $ C.CallInd (bindvar `C.DerefField` "bind_cont") 1314 [bindvar `C.DerefField` "st", errvar, bindvar], 1315 C.Ex $ C.Call (tx_bind_reply_fn_name p ifn) [my_bindvar], 1316 C.Continue] [], 1317 C.SBlank, 1318 1319 C.SComment "is this a binding reply message of connect/accept?", 1320 C.If (C.Binary C.Equals (C.Variable "msgnum") (C.Variable "FL_UMP_BIND_REPLY")) [ 1321 C.Ex $ C.Call "ump_chan_free_message" [C.Variable "msg"], 1322 C.If ((C.Binary C.Equals (C.DerefField my_bindvar "is_client")) (C.Variable "0")) [ 1323 C.SComment "Server should not recv bind messages. Ignore.", 1324 C.Continue] [], 1325 C.SComment "handle bind: calling connect callback", 1326 C.Ex $ C.CallInd (bindvar `C.DerefField` "bind_cont") 1327 [bindvar `C.DerefField` "st", errvar, bindvar], 1328 C.Continue] [], 1329 C.SBlank, 1330 1331 C.SComment "is this a cap ack for a pending tx message", 1332 C.If (C.Binary C.Equals (C.Variable "msgnum") (C.Variable "FL_UMP_CAP_ACK")) 1333 [C.Ex $ C.Call "ump_chan_free_message" [C.Variable "msg"], 1334 C.Ex $ C.Call "assert" [C.Unary C.Not (capst `C.FieldOf` "rx_cap_ack")], 1335 C.Ex $ C.Assignment (capst `C.FieldOf` "rx_cap_ack") (C.Variable "true"), 1336 C.If (capst `C.FieldOf` "monitor_mutex_held") 1337 [C.Ex $ C.Call (tx_cap_handler_name p ifn) [my_bindvar]] [], 1338 C.Continue] 1339 [], 1340 C.SBlank, 1341 1342 C.SComment "is this the start of a new message?", 1343 C.If (C.Binary C.Equals rx_msgnum_field (C.NumConstant 0)) [ 1344 C.Ex $ C.Assignment rx_msgnum_field (C.Variable "msgnum"), 1345 C.Ex $ C.Assignment rx_msgfrag_field (C.NumConstant 0) 1346 ] [], 1347 C.SBlank, 1348 1349 C.SComment "switch on message number and fragment number", 1350 C.Switch rx_msgnum_field msgnum_cases bad_msgnum 1351 ] 1352 1353 tx_is_busy = C.Binary C.Or 1354 (capst `C.FieldOf` "tx_cap_ack") 1355 (C.Binary C.NotEquals 1356 (bindvar `C.DerefField` "tx_msgnum") 1357 (C.NumConstant 0)) 1358 run_tx = C.Ex $ C.Call (tx_handler_name p ifn) [my_bindvar] 1359 1360 statevar = C.DerefField my_bindvar "ump_state" 1361 stateaddr = C.AddressOf statevar 1362 capst = statevar `C.FieldOf` "capst" 1363 chanaddr = C.AddressOf $ statevar `C.FieldOf` "chan" 1364 msgdata = C.Variable "msg" `C.DerefField` "data" 1365 rx_msgnum_field = C.DerefField bindvar "rx_msgnum" 1366 rx_msgfrag_field = C.DerefField bindvar "rx_msg_fragment" 1367 1368 call_cases = [C.Case (C.Variable $ msg_enum_elem_name ifn mn) (call_msgnum_case msgdef msg) 1369 | (msgdef, msg@(MsgSpec mn _ caps)) <- zip msgdefs msgs, caps == []] 1370 1371 call_msgnum_case msgdef@(Message mtype mn msgargs _) (MsgSpec _ frags caps) = 1372 [C.StmtList $ call_handler (ump_drv p) ifn typedefs mtype mn msgargs, C.Break] 1373 1374 msgnum_cases = [C.Case (C.Variable $ msg_enum_elem_name ifn mn) (msgnum_case msgdef msg) 1375 | (msgdef, msg@(MsgSpec mn _ _)) <- zip msgdefs msgs] 1376 1377 msgnum_case msgdef@(Message _ _ msgargs _) (MsgSpec mn frags caps) = [ 1378 C.Switch rx_msgfrag_field 1379 [C.Case (C.NumConstant $ toInteger i) $ 1380 (if i == 0 then 1381 -- first fragment of a message 1382 start_recv (ump_drv p) ifn typedefs mn msgargs ++ 1383 (if caps /= [] then [ 1384 -- + with caps received 1385 C.Ex $ C.Call "flounder_stub_ump_send_cap_ack" [C.AddressOf umpst], 1386 -- C.Ex $ C.Assignment 1387 -- (capst `C.FieldOf` "tx_cap_ack") (C.Variable "true"), 1388 C.Ex $ C.Assignment 1389 (capst `C.FieldOf` "rx_capnum") (C.NumConstant 0) 1390 ] else []) 1391 else []) ++ 1392 (msgfrag_case msgdef frag caps (i == 0) (i == length frags - 1)) 1393 | (frag, i) <- zip frags [0..] ] 1394 bad_msgfrag, 1395 C.Break] 1396 where 1397 umpst = C.DerefField my_bindvar "ump_state" 1398 1399 bad_msgnum = [report_user_err $ C.Variable "FLOUNDER_ERR_RX_INVALID_MSGNUM", 1400 C.Goto "out"] 1401 1402 bad_msgfrag = [report_user_err $ C.Variable "FLOUNDER_ERR_INVALID_STATE", 1403 C.Goto "out"] 1404 1405 msgfrag_case :: MessageDef -> MsgFragment -> [CapFieldTransfer] -> Bool -> Bool -> [C.Stmt] 1406 msgfrag_case msg@(Message _ mn _ _) (MsgFragment wl) caps isFirst isLast = [ 1407 C.StmtList $ concat [store_arg_frags (ump_arch p) ifn mn msgdata word 0 afl 1408 | (afl, word) <- zip wl [0..]], 1409 (if isFirst then C.Ex $ C.Assignment binding_incoming_token ump_token else C.SBlank), 1410 C.SBlank, 1411 C.Ex $ C.Call "ump_chan_free_message" [C.Variable "msg"], 1412 C.StmtList $ msgfrag_case_prolog msg caps isLast, 1413 C.Goto "out"] 1414 where 1415 ump_token = C.Variable "msg" `C.DerefField` "header" `C.FieldOf` "control" `C.FieldOf` "token" 1416 umpst = C.DerefField my_bindvar "ump_state" 1417 chanst = C.AddressOf umpst 1418 binding_incoming_token = C.DerefField bindvar "incoming_token" 1419 1420 msgfrag_case msg@(Message _ mn _ _) (OverflowFragment (StringFragment af)) caps isFirst isLast = [ 1421 C.Ex $ C.Assignment errvar (C.Call "flounder_stub_ump_recv_string" args), 1422 (if isFirst then C.Ex $ C.Assignment binding_incoming_token ump_token else C.SBlank), 1423 C.Ex $ C.Call "ump_chan_free_message" [C.Variable "msg"], 1424 C.If (C.Call "err_is_ok" [errvar]) 1425 (msgfrag_case_prolog msg caps isLast) 1426 -- error from string receive code, check if it's permanent 1427 [C.If (C.Binary C.NotEquals 1428 (C.Call "err_no" [errvar]) 1429 (C.Variable "FLOUNDER_ERR_BUF_RECV_MORE")) 1430 [report_user_err errvar] -- real error 1431 [] -- will receive more next time 1432 ], 1433 C.Break] 1434 where 1435 args = [msg_arg, string_arg, pos_arg, len_arg, max_size] 1436 msg_arg = C.Variable "msg" 1437 string_arg = argfield_expr RX mn af 1438 pos_arg = C.AddressOf $ C.DerefField bindvar "rx_str_pos" 1439 len_arg = C.AddressOf $ C.DerefField bindvar "rx_str_len" 1440 ump_token = C.Variable "msg" `C.DerefField` "header" `C.FieldOf` "control" `C.FieldOf` "token" 1441 umpst = C.DerefField my_bindvar "ump_state" 1442 chanst = C.AddressOf umpst 1443 binding_incoming_token = C.DerefField bindvar "incoming_token" 1444 max_size = C.SizeOf $ string_arg 1445 1446 msgfrag_case msg@(Message _ mn _ _) (OverflowFragment (BufferFragment _ afn afl)) caps isFirst isLast = [ 1447 C.Ex $ C.Assignment errvar (C.Call "flounder_stub_ump_recv_buf" args), 1448 (if isFirst then C.Ex $ C.Assignment binding_incoming_token ump_token else C.SBlank), 1449 C.Ex $ C.Call "ump_chan_free_message" [C.Variable "msg"], 1450 C.If (C.Call "err_is_ok" [errvar]) 1451 (msgfrag_case_prolog msg caps isLast) 1452 -- error from receive code, check if it's permanent 1453 [C.If (C.Binary C.NotEquals 1454 (C.Call "err_no" [errvar]) 1455 (C.Variable "FLOUNDER_ERR_BUF_RECV_MORE")) 1456 [report_user_err errvar] -- real error 1457 [] -- will receive more next time 1458 ], 1459 C.Break] 1460 where 1461 args = [msg_arg, buf_arg, len_arg, pos_arg, max_size] 1462 msg_arg = C.Variable "msg" 1463 buf_arg = C.Cast (C.Ptr C.Void) $ argfield_expr RX mn afn 1464 len_arg = C.AddressOf $ argfield_expr RX mn afl 1465 pos_arg = C.AddressOf $ C.DerefField bindvar "rx_str_pos" 1466 ump_token = C.Variable "msg" `C.DerefField` "header" `C.FieldOf` "control" `C.FieldOf` "token" 1467 umpst = C.DerefField my_bindvar "ump_state" 1468 chanst = C.AddressOf umpst 1469 binding_incoming_token = C.DerefField bindvar "incoming_token" 1470 max_size = C.SizeOf $ argfield_expr RX mn afn 1471 1472 1473 msgfrag_case_prolog :: MessageDef -> [CapFieldTransfer] -> Bool -> [C.Stmt] 1474 -- intermediate fragment 1475 msgfrag_case_prolog _ _ False = [rx_fragment_increment] 1476 1477 -- last fragment: call handler and zero message number 1478 -- if we're expecting any caps, only do so if we've received them all 1479 msgfrag_case_prolog (Message mtype mn msgargs _) caps True 1480 | caps == [] = call_callback 1481 | otherwise = [ 1482 rx_fragment_increment, 1483 C.Ex $ C.Assignment (C.DerefField message_chanstate "trigger") $ C.Call "monitor_bind_get_receiving_chanstate" [ump_chan `C.DerefField` "monitor_binding"], 1484 C.Goto "out_no_reregister"] 1485 where 1486 call_callback = [C.StmtList $ finished_recv_nocall (ump_drv p) ifn typedefs mtype mn msgargs, C.Goto "out"] 1487 ump_chan = C.AddressOf $ statevar `C.FieldOf` "chan" 1488 message_chanstate = C.Binary C.Plus (C.DerefField bindvar "message_chanstate") (C.Variable $ msg_enum_elem_name ifn mn) 1489 1490 rx_fragment_increment 1491 = C.Ex $ C.PostInc $ C.DerefField bindvar "rx_msg_fragment" 1492 1493cap_rx_handler :: UMPParams -> String -> [TypeDef] -> [MessageDef] -> [MsgSpec] -> C.Unit 1494cap_rx_handler p ifn typedefs msgdefs msgspecs 1495 = C.FunctionDef C.Static C.Void (cap_rx_handler_name p ifn) 1496 [C.Param (C.Ptr C.Void) "arg", 1497 C.Param (C.TypeName "errval_t") "success", 1498 C.Param (C.Struct "capref") "cap", 1499 C.Param (C.TypeName "uint32_t") "capid"] 1500 [handler_preamble p ifn, 1501 localvar (C.TypeName "int") "call_msgnum" $ Just $ C.NumConstant 0, 1502 localvar (C.TypeName "int") "__attribute__ ((unused)) no_register" (Just $ C.NumConstant 0), 1503 1504 C.Ex $ C.Call "assert" [C.Binary C.Equals 1505 (C.Variable "capid") 1506 (capst `C.FieldOf` "rx_capnum")], 1507 C.SBlank, 1508 1509 C.Ex $ C.Call "thread_mutex_lock" [C.AddressOf $ C.DerefField bindvar "rxtx_mutex"], 1510 C.SComment "Check if there's an associated error", 1511 C.SComment "FIXME: how should we report this to the user? at present we just deliver a NULL capref", 1512 C.If (C.Call "err_is_fail" [C.Variable "success"]) 1513 [C.Ex $ C.Call "DEBUG_ERR" [C.Variable "success", 1514 C.StringConstant "error in cap transfer"]] 1515 [], 1516 C.SBlank, 1517 1518 C.SComment "Switch on current incoming message", 1519 C.Switch (C.DerefField bindvar "rx_msgnum") cases 1520 [C.Ex $ C.Call "assert" 1521 [C.Unary C.Not $ C.StringConstant "invalid message number"], 1522 report_user_err (C.Variable "FLOUNDER_ERR_INVALID_STATE")], 1523 C.If (C.Variable "call_msgnum") [C.Ex $ C.Assignment rx_msgnum_field (C.NumConstant 0)] [], 1524 C.Ex $ C.Call "thread_mutex_unlock" [C.AddressOf $ C.DerefField bindvar "rxtx_mutex"], 1525 C.Switch (C.Variable "call_msgnum") call_cases [C.Break] 1526 ] 1527 where 1528 umpst = C.DerefField my_bindvar "ump_state" 1529 capst = umpst `C.FieldOf` "capst" 1530 cases = [C.Case (C.Variable $ msg_enum_elem_name ifn mn) 1531 (cap_rx_handler_case p ifn typedefs mn msgdef (length frags) caps) 1532 | (MsgSpec mn frags caps, msgdef) <- zip msgspecs msgdefs, caps /= []] 1533 rx_msgnum_field = C.DerefField bindvar "rx_msgnum" 1534 call_cases = [C.Case (C.Variable $ msg_enum_elem_name ifn mn) (call_msgnum_case msgdef msg) 1535 | (msgdef, msg@(MsgSpec mn _ caps)) <- zip msgdefs msgspecs, caps /= []] 1536 1537 call_msgnum_case msgdef@(Message mtype mn msgargs _) (MsgSpec _ frags caps) = 1538 [C.StmtList $ call_handler (ump_drv p) ifn typedefs mtype mn msgargs, C.Break] 1539 1540cap_rx_handler_case :: UMPParams -> String -> [TypeDef] -> String -> MessageDef -> Int -> [CapFieldTransfer] -> [C.Stmt] 1541cap_rx_handler_case p ifn typedefs mn (Message mtype _ msgargs _) nfrags caps = [ 1542 C.SComment "Switch on current incoming cap", 1543 C.Switch (C.PostInc $ capst `C.FieldOf` "rx_capnum") cases 1544 [C.Ex $ C.Call "assert" 1545 [C.Unary C.Not $ C.StringConstant "invalid cap number"], 1546 report_user_err (C.Variable "FLOUNDER_ERR_INVALID_STATE")], 1547 C.Break] 1548 where 1549 umpst = C.DerefField my_bindvar "ump_state" 1550 capst = umpst `C.FieldOf` "capst" 1551 cases = [C.Case (C.NumConstant $ toInteger i) $ subcase cap i 1552 | (cap, i) <- zip caps [0..]] 1553 1554 subcase :: CapFieldTransfer -> Int -> [C.Stmt] 1555 subcase (CapFieldTransfer _ cap) ncap = [ 1556 C.Ex $ C.Assignment (argfield_expr RX mn cap) (C.Variable "cap"), 1557 if is_last then 1558 -- if this was the last cap, and we've received all the other fragments, we're done 1559 C.If (C.Binary C.Equals rx_msgfrag_field (C.NumConstant $ toInteger nfrags)) 1560 [ 1561 C.StmtList $ finished_recv_nocall (ump_drv p) ifn typedefs mtype mn msgargs, 1562 C.Ex $ C.Assignment (C.DerefField message_chanstate "trigger") $ C.CallInd (bindvar `C.DerefField` "get_receiving_chanstate") [bindvar], 1563 C.If (C.Unary C.Not (C.Variable "no_register")) 1564 [C.StmtList $ register_recv p ifn] [], 1565 C.SBlank 1566 ] [] 1567 else C.StmtList [], 1568 C.Break] 1569 where 1570 rx_msgfrag_field = C.DerefField bindvar "rx_msg_fragment" 1571 is_last = (ncap + 1 == length caps) 1572 statevar = C.DerefField my_bindvar "ump_state" 1573 ump_chan = C.AddressOf $ statevar `C.FieldOf` "chan" 1574 message_chanstate = C.Binary C.Plus (C.DerefField bindvar "message_chanstate") (C.Variable $ msg_enum_elem_name ifn mn) 1575 1576-- generate the code to register for receive notification 1577register_recv :: UMPParams -> String -> [C.Stmt] 1578register_recv p ifn = [ 1579 C.SComment "register for receive notification", 1580 C.StmtList $ ump_register_recv p ifn, 1581 C.If (C.Call "err_is_fail" [errvar]) 1582 [report_user_err $ C.Call "err_push" [errvar, C.Variable "LIB_ERR_CHAN_REGISTER_RECV"]] 1583 [] ] 1584 1585-- generate the code to set cap rx/tx handlers 1586setup_cap_handlers :: UMPParams -> String -> [C.Stmt] 1587setup_cap_handlers p ifn = [ 1588 C.SComment "setup cap handlers", 1589 C.Ex $ C.Assignment (C.FieldOf handlers "st") my_bindvar, 1590 C.Ex $ C.Assignment (C.FieldOf handlers "cap_receive_handler") 1591 (C.Variable $ cap_rx_handler_name p ifn) ] 1592 where 1593 chanvar = my_bindvar `C.DerefField` "ump_state" `C.FieldOf` "chan" 1594 handlers = chanvar `C.FieldOf` "cap_handlers" 1595