1{- 2 LMP.hs: Flounder stub generator for local message passing. 3 4 Part of Flounder: a message passing IDL for Barrelfish 5 6 Copyright (c) 2007-2011, 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 LMP where 15 16import Data.Bits 17 18import qualified CAbsSyntax as C 19import qualified Backend 20import GHBackend 21import MsgFragments 22import Syntax 23import Arch 24import BackendCommon 25 26------------------------------------------------------------------------ 27-- Language mapping: C identifier names 28------------------------------------------------------------------------ 29 30drvname = "lmp" 31 32-- Name of the binding struct 33lmp_bind_type :: String -> String 34lmp_bind_type ifn = ifscope ifn "lmp_binding" 35 36-- Name of the local variable used for the LMP-specific binding type 37lmp_bind_var_name :: String 38lmp_bind_var_name = "b" 39lmp_bind_var = C.Variable lmp_bind_var_name 40 41-- Name of the bind function 42lmp_bind_fn_name n = ifscope n "lmp_bind" 43 44-- Name of the bind continuation function 45lmp_bind_cont_fn_name n = ifscope n "lmp_bind_continuation" 46 47-- Name of the init function 48lmp_init_fn_name n = ifscope n "lmp_init" 49 50-- Name of the destroy function 51lmp_destroy_fn_name n = ifscope n "lmp_destroy" 52 53-- Name of the transmit function 54tx_fn_name ifn mn = idscope ifn mn "lmp_send" 55 56-- Name of the transmit handler 57tx_handler_name ifn mn = idscope ifn mn "lmp_send_handler" 58 59-- Name of the transmit vtable 60lmp_vtbl_name ifn = ifscope ifn "lmp_tx_vtbl" 61 62-- Name of the receive handler 63rx_handler_name ifn = ifscope ifn "lmp_rx_handler" 64 65-- Names of the control functions 66change_waitset_fn_name ifn = ifscope ifn "lmp_change_waitset" 67control_fn_name ifn = ifscope ifn "lmp_control" 68receive_next_fn_name ifn = ifscope ifn "lmp_receive_next" 69get_receiving_chanstate_fn_name ifn = ifscope ifn "lmp_get_receiving_chanstate" 70 71------------------------------------------------------------------------ 72-- Language mapping: Create the header file for this interconnect driver 73------------------------------------------------------------------------ 74 75header :: String -> String -> Interface -> String 76header infile outfile intf = 77 unlines $ C.pp_unit $ header_file intf (lmp_header_body infile intf) 78 where 79 header_file :: Interface -> [C.Unit] -> C.Unit 80 header_file interface@(Interface name _ _) body = 81 let sym = "__" ++ name ++ "_LMP_H" 82 in C.IfNDef sym ([ C.Define sym [] "1"] ++ body) [] 83 84lmp_header_body :: String -> Interface -> [C.Unit] 85lmp_header_body infile interface@(Interface name descr decls) = [ 86 intf_preamble infile name descr, 87 C.Blank, 88 C.MultiComment [ "LMP interconnect driver" ], 89 C.Blank, 90 C.Include C.Standard "barrelfish/lmp_chan.h", 91 C.Blank, 92 lmp_binding_struct name, 93 C.Blank, 94 lmp_init_function_proto name, 95 lmp_destroy_function_proto name, 96 lmp_bind_function_proto name, 97 lmp_connect_handler_proto name, 98 lmp_rx_handler_proto name, 99 C.Blank 100 ] 101 102lmp_binding_struct :: String -> C.Unit 103lmp_binding_struct ifn = C.StructDecl (lmp_bind_type ifn) fields 104 where 105 fields = [ 106 C.Param (C.Struct $ intf_bind_type ifn) "b", 107 C.Param (C.Struct "lmp_chan") "chan", 108 C.Param (C.TypeName "lmp_send_flags_t") "flags" 109 ] 110 111lmp_init_function_proto :: String -> C.Unit 112lmp_init_function_proto n = 113 C.GVarDecl C.Extern C.NonConst 114 (C.Function C.NoScope C.Void params) name Nothing 115 where 116 name = lmp_init_fn_name n 117 params = [C.Param (C.Ptr $ C.Struct (lmp_bind_type n)) "b", 118 C.Param (C.Ptr $ C.Struct "waitset") "waitset"] 119 120lmp_destroy_function_proto :: String -> C.Unit 121lmp_destroy_function_proto n = 122 C.GVarDecl C.Extern C.NonConst 123 (C.Function C.NoScope C.Void params) name Nothing 124 where 125 name = lmp_destroy_fn_name n 126 params = [C.Param (C.Ptr $ C.Struct (lmp_bind_type n)) "b"] 127 128lmp_bind_function_proto :: String -> C.Unit 129lmp_bind_function_proto n = 130 C.GVarDecl C.Extern C.NonConst 131 (C.Function C.NoScope (C.TypeName "errval_t") params) name Nothing 132 where 133 name = lmp_bind_fn_name n 134 params = lmp_bind_params n 135 136lmp_bind_params n = [ C.Param (C.Ptr $ C.Struct (lmp_bind_type n)) "b", 137 C.Param (C.TypeName "iref_t") "iref", 138 C.Param (C.Ptr $ C.TypeName $ intf_bind_cont_type n) intf_cont_var, 139 C.Param (C.Ptr $ C.TypeName "void") "st", 140 C.Param (C.Ptr $ C.Struct "waitset") "waitset", 141 C.Param (C.TypeName "idc_bind_flags_t") "flags", 142 C.Param (C.TypeName "size_t") "lmp_buflen" ] 143 144lmp_rx_handler_proto ifn = C.GVarDecl C.Extern C.NonConst 145 (C.Function C.NoScope C.Void [C.Param (C.Ptr C.Void) "arg"]) 146 (rx_handler_name ifn) Nothing 147 148lmp_connect_handler_proto :: String -> C.Unit 149lmp_connect_handler_proto ifn = C.GVarDecl C.Extern C.NonConst 150 (C.Function C.NoScope (C.TypeName "errval_t") lmp_connect_handler_params) 151 (drv_connect_handler_name drvname ifn) Nothing 152 153lmp_connect_handler_params :: [C.Param] 154lmp_connect_handler_params 155 = [C.Param (C.Ptr $ C.Void) "st", 156 C.Param (C.TypeName "size_t") "buflen_words", 157 C.Param (C.Struct "capref") "endpoint", 158 C.Param (C.Ptr $ C.Ptr $ C.Struct "lmp_chan") "retchan"] 159 160 161------------------------------------------------------------------------ 162-- Language mapping: Create the stub (implementation) for this interconnect driver 163------------------------------------------------------------------------ 164 165stub :: Arch -> String -> String -> Interface -> String 166stub arch infile outfile intf = 167 unlines $ C.pp_unit $ lmp_stub_body arch infile intf 168 169lmp_stub_body :: Arch -> String -> Interface -> C.Unit 170lmp_stub_body arch infile intf@(Interface ifn descr decls) = C.UnitList [ 171 intf_preamble infile ifn descr, 172 C.Blank, 173 C.MultiComment [ "Generated Stub for LMP on " ++ archname arch ], 174 C.Blank, 175 176 C.Include C.Standard "string.h", 177 C.Include C.Standard "barrelfish/barrelfish.h", 178 C.Include C.Standard "flounder/flounder_support.h", 179 C.Include C.Standard "flounder/flounder_support_lmp.h", 180 C.Include C.Standard ("if/" ++ ifn ++ "_defs.h"), 181 C.Blank, 182 183 C.MultiComment [ "Send handler functions" ], 184 C.UnitList [ tx_handler arch ifn m | m <- msg_specs ], 185 C.Blank, 186 187 C.MultiComment [ "Message sender functions" ], 188 C.UnitList [ tx_fn ifn types m | m <- messages ], 189 C.Blank, 190 191 C.MultiComment [ "Send vtable" ], 192 tx_vtbl ifn messages, 193 194 C.MultiComment [ "Receive handler" ], 195 rx_handler arch ifn types messages msg_specs, 196 C.Blank, 197 198 C.MultiComment [ "Control functions" ], 199 can_send_fn_def drvname ifn, 200 register_send_fn_def drvname ifn, 201 default_error_handler_fn_def drvname ifn, 202 change_waitset_fn_def ifn, 203 control_fn_def ifn, 204 receive_next_fn_def ifn, 205 get_receiving_chanstate_fn_def ifn, 206 207 C.MultiComment [ "Functions to initialise/destroy the binding state" ], 208 lmp_init_fn ifn, 209 lmp_destroy_fn ifn, 210 C.Blank, 211 212 C.MultiComment [ "Bind function" ], 213 lmp_bind_cont_fn ifn, 214 lmp_bind_fn ifn, 215 C.Blank, 216 217 C.MultiComment [ "Connect callback for export" ], 218 lmp_connect_handler_fn ifn 219 ] 220 where 221 (types, messagedecls) = Backend.partitionTypesMessages decls 222 messages = rpcs_to_msgs messagedecls 223 msg_specs = [build_lmp_msg_spec arch types m | m <- messages] 224 225lmp_init_fn :: String -> C.Unit 226lmp_init_fn ifn = C.FunctionDef C.NoScope C.Void (lmp_init_fn_name ifn) params [ 227 C.StmtList common_init, 228 C.Ex $ C.Call "lmp_chan_init" [C.AddressOf $ C.DerefField lmp_bind_var "chan"], 229 C.Ex $ C.Assignment (C.FieldOf (common_field "tx_cont_chanstate") "trigger") (C.AddressOf $ C.FieldOf (C.DerefField lmp_bind_var "chan") "send_waitset"), 230 C.Ex $ C.Assignment (common_field "change_waitset") (C.Variable $ change_waitset_fn_name ifn), 231 C.Ex $ C.Assignment (common_field "control") (C.Variable $ control_fn_name ifn), 232 C.Ex $ C.Assignment (common_field "receive_next") (C.Variable $ receive_next_fn_name ifn), 233 C.Ex $ C.Assignment (common_field "get_receiving_chanstate") (C.Variable $ get_receiving_chanstate_fn_name ifn), 234 C.Ex $ C.Assignment 235 (C.DerefField lmp_bind_var "flags") 236 (C.Variable "LMP_SEND_FLAGS_DEFAULT")] 237 where 238 params = [C.Param (C.Ptr $ C.Struct (lmp_bind_type ifn)) lmp_bind_var_name, 239 C.Param (C.Ptr $ C.Struct "waitset") "waitset"] 240 common_field f = lmp_bind_var `C.DerefField` "b" `C.FieldOf` f 241 common_init = binding_struct_init drvname ifn 242 (C.DerefField lmp_bind_var "b") 243 (C.Variable "waitset") 244 (C.Variable $ lmp_vtbl_name ifn) 245 246lmp_destroy_fn :: String -> C.Unit 247lmp_destroy_fn ifn = C.FunctionDef C.NoScope C.Void (lmp_destroy_fn_name ifn) params [ 248 C.StmtList common_destroy, 249 C.Ex $ C.Call "lmp_chan_destroy" [C.AddressOf $ C.DerefField lmp_bind_var "chan"]] 250 where 251 params = [C.Param (C.Ptr $ C.Struct (lmp_bind_type ifn)) lmp_bind_var_name] 252 common_destroy = binding_struct_destroy ifn (C.DerefField lmp_bind_var "b") 253 254lmp_bind_fn :: String -> C.Unit 255lmp_bind_fn ifn = 256 C.FunctionDef C.NoScope (C.TypeName "errval_t") (lmp_bind_fn_name ifn) params [ 257 localvar (C.TypeName "errval_t") "err" Nothing, 258 C.Ex $ C.Call (lmp_init_fn_name ifn) [lmp_bind_var, C.Variable "waitset"], 259 C.Ex $ C.Assignment (intf_bind_field "st") (C.Variable "st"), 260 C.Ex $ C.Assignment (intf_bind_field "bind_cont") (C.Variable intf_cont_var), 261 C.Ex $ C.Assignment errvar $ C.Call "lmp_chan_bind" 262 [C.AddressOf $ lmp_bind_var `C.DerefField` "chan", 263 C.StructConstant "lmp_bind_continuation" 264 [("handler", C.Variable (lmp_bind_cont_fn_name ifn)), 265 ("st", lmp_bind_var)], 266 C.AddressOf $ intf_bind_field "event_qnode", 267 C.Variable "iref", 268 C.Variable "lmp_buflen"], 269 C.If (C.Call "err_is_fail" [errvar]) 270 [C.Ex $ C.Call (lmp_destroy_fn_name ifn) [lmp_bind_var]] [], 271 C.Return errvar 272 ] 273 where 274 params = lmp_bind_params ifn 275 intf_bind_field = C.FieldOf (C.DerefField lmp_bind_var "b") 276 277lmp_bind_cont_fn :: String -> C.Unit 278lmp_bind_cont_fn ifn = 279 C.FunctionDef C.Static C.Void (lmp_bind_cont_fn_name ifn) params [ 280 localvar (C.Ptr $ C.Struct $ lmp_bind_type ifn) 281 lmp_bind_var_name (Just $ C.Variable "st"), 282 localvar (C.Ptr $ C.Struct $ intf_bind_type ifn) 283 intf_bind_var (Just $ C.AddressOf $ lmp_bind_var `C.DerefField` "b"), 284 C.SBlank, 285 286 C.If (C.Call "err_is_ok" [errvar]) 287 [C.SComment "allocate a cap receive slot", 288 C.Ex $ C.Assignment errvar $ 289 C.Call "lmp_chan_alloc_recv_slot" [chanaddr], 290 C.If (C.Call "err_is_fail" [errvar]) 291 [C.Ex $ C.Assignment errvar $ 292 C.Call "err_push" 293 [errvar, C.Variable "LIB_ERR_LMP_ALLOC_RECV_SLOT"], 294 C.Goto "fail"] [], 295 C.SBlank, 296 297 C.SComment "register for receive", 298 C.Ex $ C.Assignment errvar $ C.Call "lmp_chan_register_recv" 299 [chanaddr, C.FieldOf intf_var "waitset", 300 C.StructConstant "event_closure" 301 [("handler", C.Variable $ rx_handler_name ifn), 302 ("arg", lmp_bind_var)]], 303 C.If (C.Call "err_is_fail" [errvar]) 304 [C.Ex $ C.Assignment errvar $ 305 C.Call "err_push" 306 [errvar, C.Variable "LIB_ERR_CHAN_REGISTER_RECV"], 307 C.Goto "fail"] [], 308 C.Ex $ C.Call (connect_handlers_fn_name ifn) [C.Variable intf_bind_var]] 309 [C.Label "fail", 310 C.Ex $ C.Call (lmp_destroy_fn_name ifn) [lmp_bind_var]], 311 C.SBlank, 312 313 C.Ex $ C.CallInd (intf_var `C.FieldOf` "bind_cont") 314 [intf_var `C.FieldOf` "st", errvar, C.AddressOf intf_var] 315 ] 316 where 317 params = [C.Param (C.Ptr C.Void) "st", 318 C.Param (C.TypeName "errval_t") "err", 319 C.Param (C.Ptr $ C.Struct "lmp_chan") "chan"] 320 intf_var = C.DerefField lmp_bind_var "b" 321 errvar = C.Variable "err" 322 chanaddr = C.Variable "chan" 323 324lmp_connect_handler_fn :: String -> C.Unit 325lmp_connect_handler_fn ifn = C.FunctionDef C.NoScope (C.TypeName "errval_t") 326 (drv_connect_handler_name "lmp" ifn) lmp_connect_handler_params [ 327 localvar (C.Ptr $ C.Struct $ export_type ifn) "e" $ Just $ C.Variable "st", 328 localvar (C.TypeName "errval_t") "err" Nothing, 329 C.SBlank, 330 C.SComment "allocate storage for binding", 331 localvar (C.Ptr $ C.Struct $ lmp_bind_type ifn) lmp_bind_var_name 332 $ Just $ C.Call "malloc" [C.SizeOfT $ C.Struct $ lmp_bind_type ifn], 333 C.If (C.Binary C.Equals lmp_bind_var (C.Variable "NULL")) 334 [C.Return $ C.Variable "LIB_ERR_MALLOC_FAIL"] [], 335 C.SBlank, 336 337 localvar (C.Ptr $ C.Struct $ intf_bind_type ifn) 338 intf_bind_var (Just $ C.AddressOf $ lmp_bind_var `C.DerefField` "b"), 339 C.Ex $ C.Call (lmp_init_fn_name ifn) [lmp_bind_var, 340 exportvar `C.DerefField` "waitset"], 341 C.SBlank, 342 343 C.SComment "run user's connect handler", 344 C.Ex $ C.Call "assert" [(C.DerefField exportvar "connect_cb")], 345 C.Ex $ C.Assignment errvar $ C.CallInd (C.DerefField exportvar "connect_cb") 346 [C.DerefField exportvar "st", bindvar], 347 C.If (C.Call "err_is_fail" [errvar]) 348 [C.SComment "connection refused", 349 C.Ex $ C.Call (lmp_destroy_fn_name ifn) [lmp_bind_var], 350 C.Return $ errvar] [], 351 C.SBlank, 352 353 C.SComment "accept the connection and setup the channel", 354 C.SComment "FIXME: user policy needed to decide on the size of the message buffer?", 355 C.Ex $ C.Assignment errvar $ C.Call "lmp_chan_accept" 356 [C.AddressOf $ C.DerefField lmp_bind_var "chan", 357 C.Variable "buflen_words", C.Variable "endpoint"], 358 C.If (C.Call "err_is_fail" [errvar]) 359 [C.Ex $ C.Assignment errvar $ C.Call "err_push" 360 [errvar, C.Variable "LIB_ERR_LMP_CHAN_ACCEPT"], 361 report_user_err errvar, 362 C.Return $ errvar] [], 363 C.SBlank, 364 365 C.SComment "allocate a cap receive slot", 366 C.Ex $ C.Assignment errvar $ 367 C.Call "lmp_chan_alloc_recv_slot" [chanaddr], 368 C.If (C.Call "err_is_fail" [errvar]) 369 [C.Ex $ C.Assignment errvar $ C.Call "err_push" 370 [errvar, C.Variable "LIB_ERR_LMP_ALLOC_RECV_SLOT"], 371 report_user_err errvar, 372 C.Return $ errvar] [], 373 C.SBlank, 374 375 C.Ex $ C.Call (connect_handlers_fn_name ifn) [C.Variable intf_bind_var], 376 C.SBlank, 377 378 C.SComment "register for receive", 379 C.Ex $ C.Assignment errvar $ C.Call "lmp_chan_register_recv" 380 [chanaddr, C.DerefField bindvar "waitset", 381 C.StructConstant "event_closure" 382 [("handler", C.Variable $ rx_handler_name ifn), 383 ("arg", lmp_bind_var)]], 384 C.If (C.Call "err_is_fail" [errvar]) 385 [C.Ex $ C.Assignment errvar $ C.Call "err_push" 386 [errvar, C.Variable "LIB_ERR_CHAN_REGISTER_RECV"], 387 report_user_err errvar, 388 C.Return $ errvar] [], 389 C.SBlank, 390 391 C.Ex $ C.Assignment (C.DerefPtr $ C.Variable "retchan") chanaddr, 392 C.SBlank, 393 C.Return $ C.Variable "SYS_ERR_OK"] 394 where 395 exportvar = C.Variable "e" 396 chanaddr = C.AddressOf $ C.DerefField lmp_bind_var "chan" 397 398change_waitset_fn_def :: String -> C.Unit 399change_waitset_fn_def ifn = 400 C.FunctionDef C.Static (C.TypeName "errval_t") (change_waitset_fn_name ifn) params [ 401 localvar (C.Ptr $ C.Struct $ lmp_bind_type ifn) 402 lmp_bind_var_name (Just $ C.Cast (C.Ptr C.Void) bindvar), 403 C.SBlank, 404 405 C.SComment "Migrate register and TX continuation notifications", 406 C.Ex $ C.Call "flounder_support_migrate_notify" [register_chanstate, C.Variable "ws"], 407 C.Ex $ C.Call "flounder_support_migrate_notify" [tx_cont_chanstate, C.Variable "ws"], 408 C.SBlank, 409 C.Ex $ C.Call (disconnect_handlers_fn_name ifn) [bindvar], 410 411 C.SComment "change waitset on binding", 412 C.Ex $ C.Assignment 413 (bindvar `C.DerefField` "waitset") 414 (C.Variable "ws"), 415 C.SBlank, 416 417 C.Ex $ C.Call (connect_handlers_fn_name ifn) [bindvar], 418 419 C.SComment "Migrate send and receive notifications", 420 C.Ex $ C.Call "lmp_chan_migrate_recv" [chanaddr, C.Variable "ws"], 421 C.Ex $ C.Call "lmp_chan_migrate_send" [chanaddr, C.Variable "ws"], 422 C.SBlank, 423 424 C.Return $ C.Variable "SYS_ERR_OK" 425 ] 426 where 427 register_chanstate = C.AddressOf $ C.DerefField bindvar "register_chanstate" 428 tx_cont_chanstate = C.AddressOf $ C.DerefField bindvar "tx_cont_chanstate" 429 chanaddr = C.AddressOf $ C.DerefField lmp_bind_var "chan" 430 params = [C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var, 431 C.Param (C.Ptr $ C.Struct "waitset") "ws"] 432 433control_fn_def :: String -> C.Unit 434control_fn_def ifn = 435 C.FunctionDef C.Static (C.TypeName "errval_t") (control_fn_name ifn) params [ 436 localvar (C.Ptr $ C.Struct $ lmp_bind_type ifn) 437 lmp_bind_var_name (Just $ C.Cast (C.Ptr C.Void) $ C.Variable intf_bind_var), 438 C.SBlank, 439 440 C.Ex $ C.Assignment 441 (C.DerefField lmp_bind_var "flags") 442 (C.Call "idc_control_to_lmp_flags" [C.Variable "control", C.DerefField lmp_bind_var "flags"]), 443 C.SBlank, 444 445 C.Return $ C.Variable "SYS_ERR_OK" 446 ] 447 where 448 params = [C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var, 449 C.Param (C.TypeName "idc_control_t") "control"] 450 451receive_next_fn_def :: String -> C.Unit 452receive_next_fn_def ifn = 453 C.FunctionDef C.Static (C.TypeName "errval_t") (receive_next_fn_name ifn) params [ 454 localvar (C.TypeName "errval_t") "err" Nothing, 455 localvar (C.Ptr $ C.Struct $ lmp_bind_type ifn) 456 lmp_bind_var_name (Just $ C.Cast (C.Ptr C.Void) $ C.Variable intf_bind_var), 457 localvar (C.Struct "event_closure") "recv_closure" 458 (Just $ C.StructConstant "event_closure" [ 459 ("handler", C.Variable $ rx_handler_name ifn), 460 ("arg", C.Variable intf_bind_var)]), 461 C.SBlank, 462 C.SComment "register for another receive notification", 463 C.Ex $ C.Assignment errvar $ C.Call "lmp_chan_register_recv" 464 [chanaddr, C.DerefField bindvar "waitset", C.Variable "recv_closure"], 465 C.Ex $ C.Call "assert" [C.Call "err_is_ok" [errvar]], 466 C.Return $ C.Variable "SYS_ERR_OK" 467 ] 468 where 469 params = [C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var] 470 chanaddr = C.AddressOf $ C.DerefField lmp_bind_var "chan" 471 472get_receiving_chanstate_fn_def :: String -> C.Unit 473get_receiving_chanstate_fn_def ifn = 474 C.FunctionDef C.Static (C.Ptr $ C.Struct "waitset_chanstate") (get_receiving_chanstate_fn_name ifn) params [ 475 localvar (C.Ptr $ C.Struct $ lmp_bind_type ifn) 476 lmp_bind_var_name (Just $ C.Cast (C.Ptr C.Void) $ C.Variable intf_bind_var), 477 C.SBlank, 478 C.Return $ C.Call "lmp_chan_get_receiving_channel" [C.AddressOf $ C.DerefField lmp_bind_var "chan"] 479 ] 480 where 481 params = [C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var] 482 483handler_preamble :: String -> C.Stmt 484handler_preamble ifn = C.StmtList 485 [C.SComment "Get the binding state from our argument pointer", 486 localvar (C.Ptr $ C.Struct $ intf_bind_type ifn) 487 intf_bind_var (Just $ C.Variable "arg"), 488 localvar (C.Ptr $ C.Struct $ lmp_bind_type ifn) 489 lmp_bind_var_name (Just $ C.Variable "arg"), 490 localvar (C.TypeName "errval_t") "err" Nothing, 491 C.SBlank] 492 493tx_handler :: Arch -> String -> LMPMsgSpec -> C.Unit 494tx_handler arch ifn (LMPMsgSpec mn msgfrags) = 495 C.FunctionDef C.Static C.Void (tx_handler_name ifn mn) [C.Param (C.Ptr C.Void) "arg"] [ 496 handler_preamble ifn, 497 C.Ex $ C.Call "thread_mutex_lock" [C.AddressOf $ C.DerefField bindvar "rxtx_mutex"], 498 C.SComment "Switch on current outgoing message fragment", 499 C.Switch (C.DerefField bindvar "tx_msg_fragment") cases bad, 500 C.SBlank, 501 C.If (C.Call "lmp_err_is_transient" [errvar]) 502 -- transient errors 503 [C.SComment "Construct retry closure and register it", 504 localvar (C.Struct "event_closure") "retry_closure" 505 (Just $ C.StructConstant "event_closure" [ 506 ("handler", C.Variable $ tx_handler_name ifn mn), 507 ("arg", C.Variable "arg")]), 508 C.Ex $ C.Assignment errvar 509 (C.Call "lmp_chan_register_send" [ 510 C.AddressOf $ C.DerefField lmp_bind_var "chan", 511 C.DerefField bindvar "waitset", 512 C.Variable "retry_closure"]), 513 C.Ex $ C.Call "assert" [C.Call "err_is_ok" [errvar]]] 514 -- permanent errors 515 [C.SComment "Report error to user", 516 report_user_tx_err errvar 517 ], 518 C.Ex $ C.Call "thread_mutex_unlock" [C.AddressOf $ C.DerefField bindvar "rxtx_mutex"] 519 ] 520 where 521 cases = [let isLast = (i == length msgfrags - 1) in 522 C.Case (C.NumConstant $ toInteger i) 523 $ (tx_handler_case arch ifn mn frag isLast) ++ [gentest isLast] 524 | (frag, i) <- zip msgfrags [0 ..]] 525 bad = [C.Ex $ C.Call "assert" [C.Unary C.Not $ C.StringConstant "invalid fragment"], 526 C.Ex $ C.Assignment errvar (C.Variable "FLOUNDER_ERR_INVALID_STATE")] 527 528 -- generate the if() that checks the result of sending 529 gentest isLast = C.If (C.Call "err_is_ok" [errvar]) 530 (if isLast then -- if the last fragment succeeds, we're done 531 finished_send ++ [ 532 C.Ex $ C.Call "thread_mutex_unlock" [C.AddressOf $ C.DerefField bindvar "rxtx_mutex"], 533 C.ReturnVoid] 534 else 535 [C.Ex $ C.PostInc $ C.DerefField bindvar "tx_msg_fragment", 536 C.SComment "fall through to next fragment"]) 537 -- else case is always the same 538 [C.Break] 539 tx_msgnum_field = C.DerefField bindvar "tx_msgnum" 540 541tx_handler_case :: Arch -> String -> String -> LMPMsgFragment -> Bool -> [C.Stmt] 542tx_handler_case arch ifn mn (LMPMsgFragment (MsgFragment words) cap) isLast = 543 [C.Ex $ C.Assignment errvar (C.Call send_fn_name args)] 544 where 545 send_fn_name = "lmp_chan_send" ++ show (length words) 546 args = [chan_arg, flag_arg, cap_arg] ++ (map (fragment_word_to_expr arch ifn mn) words) 547 chan_arg = C.AddressOf $ C.DerefField lmp_bind_var "chan" 548 lmp_sync_flag f -- only set the sync flag on the last fragment 549 | isLast = f 550 | otherwise = C.Binary C.BitwiseAnd f $ C.Unary C.BitwiseNot (C.Variable "LMP_FLAG_SYNC") 551 giveaway_flag f = case cap of 552 Just (CapFieldTransfer GiveAway _) -> C.Binary C.BitwiseOr f (C.Variable "LMP_FLAG_GIVEAWAY") 553 _ -> f 554 flag_arg = (lmp_sync_flag . giveaway_flag) flag_var 555 flag_var = C.DerefField lmp_bind_var "flags" 556 cap_arg = case cap of 557 Just (CapFieldTransfer _ af) -> argfield_expr TX mn af 558 Nothing -> C.Variable "NULL_CAP" 559 560tx_handler_case arch ifn mn (LMPMsgFragment (OverflowFragment _) (Just _)) _ = 561 error "cannot send caps in same fragment as strings/buffers: NYI" 562 563tx_handler_case arch ifn mn (LMPMsgFragment (OverflowFragment (StringFragment af)) Nothing) isLast = 564 [C.Ex $ C.Assignment errvar (C.Call "flounder_stub_lmp_send_string" args)] 565 where 566 args = [chan_arg, flag_arg, string_arg, pos_arg, len_arg] 567 chan_arg = C.AddressOf $ C.DerefField lmp_bind_var "chan" 568 flag_arg -- only set the sync flag on the last fragment 569 | isLast = flag_var 570 | otherwise = C.Binary C.BitwiseAnd flag_var $ C.Unary C.BitwiseNot (C.Variable "LMP_FLAG_SYNC") 571 flag_var = C.DerefField lmp_bind_var "flags" 572 string_arg = argfield_expr TX mn af 573 pos_arg = C.AddressOf $ C.DerefField bindvar "tx_str_pos" 574 len_arg = C.AddressOf $ C.DerefField bindvar "tx_str_len" 575 576tx_handler_case arch ifn mn (LMPMsgFragment (OverflowFragment (BufferFragment _ afn afl)) Nothing) isLast = 577 [C.Ex $ C.Assignment errvar (C.Call "flounder_stub_lmp_send_buf" args)] 578 where 579 args = [chan_arg, flag_arg, buf_arg, len_arg, pos_arg] 580 chan_arg = C.AddressOf $ C.DerefField lmp_bind_var "chan" 581 flag_arg -- only set the sync flag on the last fragment 582 | isLast = flag_var 583 | otherwise = C.Binary C.BitwiseAnd flag_var $ C.Unary C.BitwiseNot (C.Variable "LMP_FLAG_SYNC") 584 flag_var = C.DerefField lmp_bind_var "flags" 585 buf_arg = argfield_expr TX mn afn 586 len_arg = argfield_expr TX mn afl 587 pos_arg = C.AddressOf $ C.DerefField bindvar "tx_str_pos" 588 589tx_fn :: String -> [TypeDef] -> MessageDef -> C.Unit 590tx_fn ifn typedefs msg@(Message mtype n args _) = 591 C.FunctionDef C.Static (C.TypeName "errval_t") (tx_fn_name ifn n) params body 592 where 593 params = [binding_param ifn, cont_param] ++ ( 594 concat [ msg_argdecl TX ifn a | a <- args ]) 595 cont_param = C.Param (C.Struct "event_closure") intf_cont_var 596 body = [ 597 -- check size of message 598 C.StmtList [ tx_fn_arg_check_size ifn typedefs n a | a <- args ], 599 C.SComment "check that we can accept an outgoing message", 600 C.Ex $ C.Call "thread_mutex_lock" [C.AddressOf $ C.DerefField bindvar "send_mutex"], 601 C.Ex $ C.Assignment binding_error (C.Variable "SYS_ERR_OK"), 602 C.If (C.Binary C.NotEquals tx_msgnum_field (C.NumConstant 0)) 603 [C.Ex $ C.Call "thread_mutex_unlock" [C.AddressOf $ C.DerefField bindvar "send_mutex"], 604 C.Return $ C.Variable "FLOUNDER_ERR_TX_BUSY"] [], 605 C.SBlank, 606 C.SComment "register send continuation", 607 C.StmtList $ register_txcont (C.Variable intf_cont_var), 608 C.SBlank, 609 C.SComment "store message number and arguments", 610 C.Ex $ C.Assignment binding_outgoing_token (C.Binary C.BitwiseAnd binding_incoming_token (C.Variable "~1" )), 611 C.Ex $ C.Call "thread_get_outgoing_token" [C.AddressOf binding_outgoing_token], 612 C.Ex $ C.Assignment tx_msgnum_field (C.Variable $ msg_enum_elem_name ifn n), 613 C.Ex $ C.Assignment tx_msgfrag_field (C.NumConstant 0), 614 C.StmtList [ tx_arg_assignment ifn typedefs n a | a <- args ], 615 C.StmtList $ start_send drvname ifn n args, 616 C.SBlank, 617 C.SComment "try to send!", 618 C.Ex $ C.Call (tx_handler_name ifn n) [C.Variable intf_bind_var], 619 C.StmtList $ block_sending (C.Variable intf_cont_var), 620 C.Ex $ C.Call "thread_mutex_unlock" [C.AddressOf $ C.DerefField bindvar "send_mutex"], 621 C.SBlank, 622 C.Return binding_error 623 ] 624 tx_msgnum_field = C.DerefField bindvar "tx_msgnum" 625 tx_msgfrag_field = C.DerefField bindvar "tx_msg_fragment" 626 binding_incoming_token = C.DerefField bindvar "incoming_token" 627 binding_outgoing_token = C.DerefField bindvar "outgoing_token" 628 629tx_vtbl :: String -> [MessageDef] -> C.Unit 630tx_vtbl ifn ml = 631 C.StructDef C.Static (intf_vtbl_type ifn TX) (lmp_vtbl_name ifn) fields 632 where 633 fields = [let mn = msg_name m in (mn, tx_fn_name ifn mn) | m <- ml] 634 635rx_handler :: Arch -> String -> [TypeDef] -> [MessageDef] -> [LMPMsgSpec] -> C.Unit 636rx_handler arch ifn typedefs msgdefs msgs = 637 C.FunctionDef C.NoScope C.Void (rx_handler_name ifn) [C.Param (C.Ptr C.Void) "arg"] [ 638 handler_preamble ifn, 639 localvar (C.Struct "lmp_recv_msg") "msg" (Just $ C.Variable "LMP_RECV_MSG_INIT"), 640 localvar (C.Struct "capref") "cap" Nothing, 641 localvar (C.TypeName "int") "__attribute__ ((unused)) no_register" (Just $ C.NumConstant 0), 642 localvar (C.TypeName "int") "call_msgnum" $ Just $ C.NumConstant 0, 643 644 -- declare closure for retry 645 localvar (C.Struct "event_closure") "recv_closure" 646 (Just $ C.StructConstant "event_closure" [ 647 ("handler", C.Variable $ rx_handler_name ifn), 648 ("arg", C.Variable "arg")]), 649 C.SBlank, 650 651 C.Ex $ C.Call "thread_mutex_lock" [C.AddressOf $ C.DerefField bindvar "rxtx_mutex"], 652 653 C.DoWhile (C.Call "err_is_ok" [errvar]) [ 654 655 C.If (C.Unary C.Not $ C.Call "lmp_chan_can_recv" [chanaddr]) [C.Goto "out"] [], 656 657 C.SComment "try to retrieve a message from the channel", 658 C.Ex $ C.Assignment errvar 659 $ C.Call "lmp_chan_recv" [chanaddr, 660 C.AddressOf $ C.Variable "msg", 661 C.AddressOf $ C.Variable "cap"], 662 663 C.SComment "check if we succeeded", 664 C.If (C.Call "err_is_fail" [errvar]) 665 -- if err_is_fail, check err_no 666 [C.If (C.Binary C.Equals (C.Call "err_no" [errvar]) (C.Variable "LIB_ERR_NO_LMP_MSG")) 667 [C.SComment "no message", 668 C.Ex $ C.Assignment errvar $ C.Variable "SYS_ERR_OK", 669 C.Continue] 670 [C.SComment "real error", 671 report_user_err $ C.Call "err_push" [errvar, C.Variable "LIB_ERR_LMP_CHAN_RECV"], 672 C.ReturnVoid] 673 ] 674 [], 675 C.SBlank, 676 677 C.SComment "get or allocate a new receive slot if needed", 678 localvar (C.TypeName "struct capref") "nextslot" (Just ( 679 C.Call "thread_get_next_recv_slot" [] 680 )), 681 C.If (C.Unary C.Not $ C.Call "capref_is_null" [C.Variable "cap"]) 682 [ 683 C.If (C.Call "capref_is_null" [ C.Variable "nextslot" ]) [ 684 C.Ex $ C.Assignment errvar $ 685 C.Call "lmp_chan_alloc_recv_slot" [chanaddr], 686 C.If (C.Call "err_is_fail" [errvar]) 687 [report_user_err $ 688 C.Call "err_push" [errvar, C.Variable "LIB_ERR_LMP_ALLOC_RECV_SLOT"]] 689 [] 690 ] [ 691 C.Ex $ C.Call "lmp_chan_set_recv_slot" [chanaddr, C.Variable "nextslot" ] 692 ] 693 ] [ 694 -- Free popped recv slot if we didn't use it! 695 C.SComment "Free the popped receive slot, if we did not use it", 696 C.Ex $ C.Call "slot_free" [ C.Variable "nextslot" ] 697 ], 698 C.SBlank, 699 700 C.SComment "is this the start of a new message?", 701 C.If (C.Binary C.Equals rx_msgnum_field (C.NumConstant 0)) [ 702 C.SComment "check message length", 703 C.If (C.Binary C.Equals msglen (C.NumConstant 0)) [ 704 report_user_err $ C.Variable "FLOUNDER_ERR_RX_EMPTY_MSG", 705 C.Break] [], 706 707 C.SComment "unmarshall message number from first word, set fragment to 0", 708 C.Ex $ C.Assignment rx_msgnum_field $ 709 C.Binary C.BitwiseAnd (C.SubscriptOf msgwords $ C.NumConstant 0) msgnum_mask, 710 C.Ex $ C.Assignment rx_msgfrag_field (C.NumConstant 0) 711 ] [], 712 C.SBlank, 713 714 C.SComment "switch on message number and fragment number", 715 C.Switch rx_msgnum_field msgnum_cases bad_msgnum 716 ], -- end of the while(1) loop 717 718 C.Label "out", 719 C.If (C.Unary C.Not (C.Variable "no_register")) 720 [C.SComment "re-register for another receive notification", 721 C.Ex $ C.Assignment errvar $ C.Call "lmp_chan_register_recv" 722 [chanaddr, C.DerefField bindvar "waitset", C.Variable "recv_closure"], 723 C.Ex $ C.Call "assert" [C.Call "err_is_ok" [errvar]]] 724 [], 725 C.If (C.Variable "call_msgnum") [C.Ex $ C.Assignment rx_msgnum_field (C.NumConstant 0)] [], 726 C.Ex $ C.Call "thread_mutex_unlock" [C.AddressOf $ C.DerefField bindvar "rxtx_mutex"], 727 C.Switch (C.Variable "call_msgnum") call_cases [C.Break] 728 ] 729 where 730 chanaddr = C.AddressOf $ C.DerefField lmp_bind_var "chan" 731 msglen = C.Variable "msg" `C.FieldOf` "buf" `C.FieldOf` "msglen" 732 msgwords = C.Variable "msg" `C.FieldOf` "words" 733 msgnum_mask = C.HexConstant ((shift 1 msgnum_bits) - 1) 734 msgnum_bits = bitsizeof_argfieldfrag arch MsgCode 735 rx_msgnum_field = C.DerefField bindvar "rx_msgnum" 736 rx_msgfrag_field = C.DerefField bindvar "rx_msg_fragment" 737 binding_incoming_token = C.DerefField bindvar "incoming_token" 738 739 capref_is_null c = C.Call "capref_is_null" [C.Variable c] 740 in_rpc = (C.Call "thread_get_rpc_in_progress" []) 741 need_slot_alloc c = C.Binary C.And (C.Unary C.Not (capref_is_null c)) 742 (C.Unary C.Not in_rpc) 743 744 call_cases = [C.Case (C.Variable $ msg_enum_elem_name ifn mn) (call_msgnum_case msgdef msg) 745 | (msgdef, msg@(LMPMsgSpec mn _)) <- zip msgdefs msgs] 746 747 call_msgnum_case msgdef@(Message mtype mn msgargs _) (LMPMsgSpec _ frags) = 748 [C.StmtList $ call_handler drvname ifn typedefs mtype mn msgargs, C.Break] 749 750 msgnum_cases = [C.Case (C.Variable $ msg_enum_elem_name ifn mn) (msgnum_case msgdef msg) 751 | (msgdef, msg@(LMPMsgSpec mn _)) <- zip msgdefs msgs] 752 753 msgnum_case msgdef@(Message _ _ msgargs _) (LMPMsgSpec mn frags) = [ 754 C.Switch rx_msgfrag_field 755 [C.Case (C.NumConstant $ toInteger i) $ 756 (if i == 0 then start_recv drvname ifn typedefs mn msgargs 757 else []) 758 ++ msgfrag_case msgdef (frags !! i) (i == length frags - 1) 759 | i <- [0 .. length frags - 1]] 760 bad_msgfrag, 761 C.Break] 762 763 bad_msgnum = [report_user_err $ C.Variable "FLOUNDER_ERR_RX_INVALID_MSGNUM", 764 C.Goto "out"] 765 766 bad_msgfrag = [report_user_err $ C.Variable "FLOUNDER_ERR_INVALID_STATE", 767 C.Goto "out"] 768 769 msgfrag_case :: MessageDef -> LMPMsgFragment -> Bool -> [C.Stmt] 770 msgfrag_case msg@(Message _ mn _ _) (LMPMsgFragment (MsgFragment wl) cap) isLast = [ 771 C.SComment "check length", 772 -- XXX: LRPC always delivers a message of a fixed size 773 C.If (if (length wl < lrpc_words arch) 774 then C.Binary C.GreaterThan msglen 775 (C.NumConstant $ toInteger $ lrpc_words arch) 776 else C.Binary C.NotEquals msglen 777 (C.NumConstant $ toInteger $ length wl)) [ 778 report_user_err $ C.Variable "FLOUNDER_ERR_RX_INVALID_LENGTH", 779 C.Goto "out"] [], 780 C.SBlank, 781 782 C.StmtList $ concat [store_arg_frags arch ifn mn msgwords word 0 afl 783 | (afl, word) <- zip wl [0..]], 784 case cap of 785 Just (CapFieldTransfer _ af) -> C.StmtList [ 786 C.Ex $ C.Assignment (argfield_expr RX mn af) (C.Variable "cap") 787 ] 788 Nothing -> C.StmtList [], 789 C.SBlank, 790 791 msgfrag_case_prolog msg isLast, 792 C.Break] 793 794 msgfrag_case msg@(Message _ mn _ _) (LMPMsgFragment (OverflowFragment (StringFragment af)) _) isLast = [ 795 C.Ex $ C.Assignment errvar (C.Call "flounder_stub_lmp_recv_string" args), 796 C.If (C.Call "err_is_ok" [errvar]) 797 [msgfrag_case_prolog msg isLast] 798 -- error from string receive code, check if it's permanent 799 [C.If (C.Binary C.NotEquals 800 (C.Call "err_no" [errvar]) 801 (C.Variable "FLOUNDER_ERR_BUF_RECV_MORE")) 802 [report_user_err errvar] -- real error 803 [] -- will receive more next time 804 ], 805 C.Break] 806 where 807 args = [msg_arg, string_arg, pos_arg, len_arg, maxsize] 808 msg_arg = C.AddressOf $ C.Variable "msg" 809 string_arg = argfield_expr RX mn af 810 pos_arg = C.AddressOf $ C.DerefField bindvar "rx_str_pos" 811 len_arg = C.AddressOf $ C.DerefField bindvar "rx_str_len" 812 maxsize = C.SizeOf $ string_arg 813 814 msgfrag_case msg@(Message _ mn _ _) (LMPMsgFragment (OverflowFragment (BufferFragment _ afn afl)) _) isLast = [ 815 C.Ex $ C.Assignment errvar (C.Call "flounder_stub_lmp_recv_buf" args), 816 C.If (C.Call "err_is_ok" [errvar]) 817 [msgfrag_case_prolog msg isLast] 818 -- error from receive code, check if it's permanent 819 [C.If (C.Binary C.NotEquals 820 (C.Call "err_no" [errvar]) 821 (C.Variable "FLOUNDER_ERR_BUF_RECV_MORE")) 822 [report_user_err errvar] -- real error 823 [] -- will receive more next time 824 ], 825 C.Break] 826 where 827 args = [msg_arg, buf_arg, len_arg, pos_arg, maxsize] 828 msg_arg = C.AddressOf $ C.Variable "msg" 829 buf_arg = C.Cast (C.Ptr C.Void) $ argfield_expr RX mn afn 830 len_arg = C.AddressOf $ argfield_expr RX mn afl 831 pos_arg = C.AddressOf $ C.DerefField bindvar "rx_str_pos" 832 maxsize = C.SizeOf $ argfield_expr RX mn afn 833 834 msgfrag_case_prolog :: MessageDef -> Bool -> C.Stmt 835 -- intermediate fragment 836 msgfrag_case_prolog _ False 837 = C.Ex $ C.PostInc $ C.DerefField bindvar "rx_msg_fragment" 838 839 -- last fragment: call handler and zero message number 840 msgfrag_case_prolog (Message mtype mn msgargs _) True 841 = C.StmtList [ 842 C.StmtList $ (finished_recv_nocall drvname ifn typedefs mtype mn msgargs), 843 C.Goto "out" 844 ] 845 where 846 lmp_chan = C.AddressOf $ C.DerefField lmp_bind_var "chan" 847