1{- 2 BackendCommon: Common code used by most backends 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 BackendCommon where 15 16import qualified CAbsSyntax as C 17import Syntax 18 19data Direction = TX | RX 20 deriving (Show, Eq) 21 22------------------------------------------------------------------------ 23-- Language mapping: C identifier names 24------------------------------------------------------------------------ 25 26-- Scope a list of strings 27ifscope :: String -> String -> String 28--ifscope ifn s = ifn ++ "$" ++ s 29ifscope ifn s = ifn ++ "_" ++ s 30 31idscope :: String -> String -> String -> String 32idscope ifn s suffix = ifscope ifn (s ++ "__" ++ suffix) 33 34drvscope :: String -> String -> String -> String 35drvscope drv ifn s = ifscope ifn (drv ++ "_" ++ s) 36 37-- Name of the binding struct for an interface type 38intf_bind_type :: String -> String 39intf_bind_type ifn = ifscope ifn "binding" 40 41-- Variable used to refer to a binding 42intf_bind_var = "_binding" 43 44-- Name of the binding struct for an interface type 45intf_frameinfo_type :: String -> String 46intf_frameinfo_type ifn = ifscope ifn "frameinfo" 47 48-- Variable used to refer to a continuation 49intf_frameinfo_var = "_frameinfo" 50 51-- name of the maximum message size define 52msg_arg_size_name :: String -> String 53msg_arg_size_name ifname = ifscope ifname "_MAX_MESSAGE_SIZE" 54 55arg_size_name :: String -> String -> String -> String 56arg_size_name ifname fname argn= ifscope ifname ("_" ++ fname ++ "_" ++ argn ++ "_MAX_ARGUMENT_SIZE") 57 58-- Name of the bind continuation function type for an interface type 59intf_bind_cont_type :: String -> String 60intf_bind_cont_type ifn = ifscope ifn "bind_continuation_fn" 61 62-- Variable used to refer to a continuation 63intf_cont_var = "_continuation" 64 65-- name of the export state struct 66export_type n = ifscope n "export" 67 68-- Name of the enumeration of message numbers 69msg_enum_name :: String -> String 70msg_enum_name ifn = ifscope ifn "msg_enum" 71 72-- Name of each element of the message number enumeration 73msg_enum_elem_name :: String -> String -> String 74msg_enum_elem_name ifn mn = idscope ifn mn "msgnum" 75 76-- Name of the type of a message function 77msg_sig_type :: String -> MessageDef -> Direction -> String 78msg_sig_type ifn m@(RPC _ _ _) TX = idscope ifn (msg_name m) "rpc_tx_method_fn" 79msg_sig_type ifn m@(RPC _ _ _) RX = idscope ifn (msg_name m) "rpc_rx_method_fn" 80msg_sig_type ifn m TX = idscope ifn (msg_name m) "tx_method_fn" 81msg_sig_type ifn m RX = idscope ifn (msg_name m) "rx_method_fn" 82 83-- Name of a given message definition 84msg_name :: MessageDef -> String 85msg_name (Message _ n _ _) = n 86msg_name (RPC n _ _) = n 87 88-- Name of the static inline wrapper for sending messages 89tx_wrapper_name :: String -> String -> String 90tx_wrapper_name ifn mn = idscope ifn mn "tx" 91 92-- Names of the underlying messages that are constructed from an RPC 93rpc_call_name n = n ++ "_call" 94rpc_resp_name n = n ++ "_response" 95 96-- Name of the struct holding message args for SAR 97msg_argstruct_name :: Direction -> String -> String -> String 98msg_argstruct_name TX ifn n = idscope ifn n "tx_args" 99msg_argstruct_name RX ifn n = idscope ifn n "rx_args" 100 101-- Name of the union type holding all the arguments for a message 102binding_arg_union_type :: Direction -> String -> String 103binding_arg_union_type TX ifn = ifscope ifn "tx_arg_union" 104binding_arg_union_type RX ifn = ifscope ifn "rx_arg_union" 105 106-- Name of the C type for a concrete flounder type, struct, or enum 107type_c_struct, type_c_enum :: String -> String -> String 108type_c_struct ifn n = "_" ++ idscope ifn n "struct" 109type_c_enum ifn e = ifscope ifn e 110 111type_c_name :: String -> TypeRef -> String 112type_c_name ifn (Builtin Cap) = undefined 113type_c_name ifn (Builtin GiveAwayCap) = undefined 114type_c_name ifn (Builtin String) = undefined 115type_c_name ifn (Builtin t) = (show t) ++ "_t" 116type_c_name ifn (TypeVar t) = type_c_name1 ifn t 117type_c_name ifn (TypeAlias t _) = type_c_name1 ifn t 118 119type_c_name1 :: String -> String -> String 120type_c_name1 ifn tn = (ifscope ifn tn) ++ "_t" 121 122type_c_type :: String -> TypeRef -> C.TypeSpec 123type_c_type ifn (Builtin Cap) = C.Struct "capref" 124type_c_type ifn (Builtin GiveAwayCap) = C.Struct "capref" 125type_c_type ifn (Builtin Char) = C.TypeName "char" 126type_c_type ifn (Builtin Bool) = C.TypeName "bool" 127type_c_type ifn (Builtin String) = C.Ptr $ C.TypeName "char" 128type_c_type ifn t = C.TypeName $ type_c_name ifn t 129 130-- pointers should be const 131type_c_type_dir :: Direction -> String -> TypeRef -> C.TypeSpec 132type_c_type_dir _ ifn tr = case type_c_type ifn tr of 133 C.Ptr t -> C.Ptr $ C.ConstT t 134 t -> t 135 136-- Array types in the msg args struct should only be pointers to the storage 137type_c_type_msgstruct :: Direction -> String -> [TypeDef] -> TypeRef -> C.TypeSpec 138type_c_type_msgstruct TX ifn typedefs t 139 = case lookup_typeref typedefs t of 140 TArray tr n _ -> C.Ptr $ type_c_type ifn t 141 _ -> type_c_type ifn t 142type_c_type_msgstruct RX ifn typedefs t 143 = case lookup_typeref typedefs t of 144 _ -> type_c_type ifn t 145 146-- Name of the struct type for the method vtable 147intf_vtbl_type :: String -> Direction -> String 148intf_vtbl_type ifn TX = ifscope ifn "tx_vtbl" 149intf_vtbl_type ifn RX = ifscope ifn "rx_vtbl" 150 151connect_callback_name n = ifscope n "connect_fn" 152drv_connect_handler_name drv n = drvscope drv n "connect_handler" 153drv_connect_fn_name drv n = drvscope drv n "connect" 154drv_accept_fn_name drv n = drvscope drv n "accept" 155can_send_fn_name drv n = drvscope drv n "can_send" 156register_send_fn_name drv n = drvscope drv n "register_send" 157default_error_handler_fn_name drv n = drvscope drv n "default_error_handler" 158generic_control_fn_name drv n = drvscope drv n "control" 159 160can_send_fn_type ifn = ifscope ifn "can_send_fn" 161register_send_fn_type ifn = ifscope ifn "register_send_fn" 162change_waitset_fn_type ifn = ifscope ifn "change_waitset_fn" 163control_fn_type ifn = ifscope ifn "control_fn" 164error_handler_fn_type ifn = ifscope ifn "error_handler_fn" 165receive_next_fn_type ifn = ifscope ifn "receive_next_fn" 166get_receiving_chanstate_fn_type ifn = ifscope ifn "get_receiving_chanstate_fn" 167 168-- Name of the type of a message handler 169msg_handler_fn_name :: String -> MessageDef -> String 170msg_handler_fn_name ifn m = idscope ifn (msg_name m) "handler_fn" 171 172 173 174------------------------------------------------------------------------ 175-- Code shared by backend implementations 176------------------------------------------------------------------------ 177 178intf_preamble :: String -> String -> Maybe String -> C.Unit 179intf_preamble infile name descr = 180 let dstr = case descr of 181 Nothing -> "not specified" 182 Just s -> s 183 in 184 C.MultiComment [ 185 "Copyright (c) 2010, ETH Zurich.", 186 "All rights reserved.", 187 "", 188 "INTERFACE NAME: " ++ name, 189 "INTEFACE FILE: " ++ infile, 190 "INTERFACE DESCRIPTION: " ++ dstr, 191 "", 192 "This file is distributed under the terms in the attached LICENSE", 193 "file. If you do not find this file, copies can be found by", 194 "writing to:", 195 "ETH Zurich D-INFK, Universitaetstr.6, CH-8092 Zurich.", 196 "Attn: Systems Group.", 197 "", 198 "THIS FILE IS AUTOMATICALLY GENERATED BY FLOUNDER: DO NOT EDIT!" ] 199 200-- 201-- Convert each RPC definition to a pair of underlying call/response messages 202-- 203rpcs_to_msgs :: [MessageDef] -> [MessageDef] 204rpcs_to_msgs ml = concat $ map rpc_to_msgs ml 205 206rpc_to_msgs :: MessageDef -> [MessageDef] 207rpc_to_msgs (RPC n rpcargs bckargs) = [Message MCall (rpc_call_name n) inargs bckargs, 208 Message MResponse (rpc_resp_name n) outargs bckargs] 209 where 210 (inargs, outargs) = partition_rpc_args rpcargs 211rpc_to_msgs m = [m] 212 213 214-- partition a list of RPC arguments to lists of input and output arguments 215partition_rpc_args :: [RPCArgument] -> ([MessageArgument], [MessageArgument]) 216partition_rpc_args [] = ([], []) 217partition_rpc_args (first:rest) = case first of 218 RPCArgIn t v -> ((Arg t v):restin, restout) 219 RPCArgOut t v -> (restin, (Arg t v):restout) 220 where 221 (restin, restout) = partition_rpc_args rest 222 223msg_argdecl :: Direction -> String -> MessageArgument -> [C.Param] 224msg_argdecl dir ifn (Arg tr (Name n)) = 225 [ C.Param (type_c_type_dir dir ifn tr) n ] 226msg_argdecl dir ifn (Arg tr (StringArray n l)) = 227 [ C.Param (type_c_type_dir dir ifn tr) n ] 228msg_argdecl dir ifn (Arg tr (DynamicArray n l _)) = 229 [ C.Param (C.Ptr $ C.ConstT $ type_c_type_dir dir ifn tr) n, 230 C.Param (type_c_type_dir RX ifn size) l ] 231 232 233msg_argstructdecl :: Direction -> String -> [TypeDef] -> MessageArgument -> [C.Param] 234msg_argstructdecl dir ifn typedefs (Arg tr (Name n)) = 235 [ C.Param (type_c_type_msgstruct dir ifn typedefs tr) n ] 236msg_argstructdecl RX ifn typedefs (Arg tr (StringArray n maxlen)) = 237 [ C.Param (C.Array maxlen $ C.TypeName "char") (n)] 238msg_argstructdecl TX ifn typedefs (Arg tr (StringArray n maxlen)) = 239 [ C.Param (type_c_type_dir TX ifn tr) n ] 240msg_argstructdecl RX ifn typedefs (Arg tr (DynamicArray n l maxlen)) = 241 [ C.Param (C.Array maxlen $ type_c_type ifn tr) (n), 242 C.Param (type_c_type ifn size) l ] 243msg_argstructdecl TX ifn typedefs (Arg tr (DynamicArray n l maxlen)) = 244 [ C.Param (C.Ptr $ C.ConstT $ type_c_type_dir TX ifn tr) n, 245 C.Param (type_c_type ifn size) l ] 246 247 248rpc_argdecl :: Direction -> String -> RPCArgument -> [C.Param] 249rpc_argdecl dir ifn (RPCArgIn tr v) = msg_argdecl dir ifn (Arg tr v) 250rpc_argdecl dir ifn (RPCArgOut tr (Name n)) = [ C.Param (C.Ptr $ type_c_type ifn tr) n ] 251rpc_argdecl dir ifn (RPCArgOut tr (StringArray n maxlen)) = [ C.Param (C.Array maxlen $ C.TypeName "char") n ] 252rpc_argdecl dir ifn (RPCArgOut tr (DynamicArray n l maxlen)) = 253 [ C.Param (C.Array maxlen $ type_c_type ifn tr) n, 254 C.Param (C.Ptr $ type_c_type ifn size) l ] 255 256-- XXX: kludge wrapper to pass array types by reference in RPC 257rpc_argdecl2 :: Direction -> String -> [TypeDef] -> RPCArgument -> [C.Param] 258rpc_argdecl2 dir ifn typedefs arg@(RPCArgOut tr (Name n)) 259 = case lookup_typeref typedefs tr of 260 TArray _ _ _ -> [ C.Param (type_c_type ifn tr) n ] 261 _ -> rpc_argdecl dir ifn arg 262rpc_argdecl2 dir ifn _ arg = rpc_argdecl dir ifn arg 263 264-- binding parameter for a function 265binding_param ifname = C.Param (C.Ptr $ C.Struct $ intf_bind_type ifname) intf_bind_var 266binding_param2 ifname = C.Param (C.Ptr $ C.Struct $ intf_bind_type ifname) (intf_bind_var ++ "_") 267 268 269-- 270-- Generate the code to initialise/destroy a binding structure instance 271-- 272binding_struct_init :: String -> String -> C.Expr -> C.Expr -> C.Expr -> [C.Stmt] 273binding_struct_init drv ifn binding_var waitset_ex tx_vtbl_ex = [ 274 C.Ex $ C.Assignment (C.FieldOf binding_var "st") (C.Variable "NULL"), 275 C.Ex $ C.Assignment (C.FieldOf binding_var "waitset") waitset_ex, 276 C.Ex $ C.Call "event_mutex_init" [C.AddressOf $ C.FieldOf binding_var "mutex", waitset_ex], 277 C.Ex $ C.Call "thread_mutex_init" [C.AddressOf $ C.FieldOf binding_var "rxtx_mutex"], 278 C.Ex $ C.Call "thread_mutex_init" [C.AddressOf $ C.FieldOf binding_var "send_mutex"], 279 C.Ex $ C.Assignment (C.FieldOf binding_var "can_send") 280 (C.Variable $ can_send_fn_name drv ifn), 281 C.Ex $ C.Assignment (C.FieldOf binding_var "register_send") 282 (C.Variable $ register_send_fn_name drv ifn), 283 C.Ex $ C.Assignment (C.FieldOf binding_var "error_handler") 284 (C.Variable $ default_error_handler_fn_name drv ifn), 285 C.Ex $ C.Assignment (C.FieldOf binding_var "tx_vtbl") tx_vtbl_ex, 286 C.Ex $ C.Call "memset" [C.AddressOf $ C.FieldOf binding_var "rx_vtbl", 287 C.NumConstant 0, 288 C.Call "sizeof" [C.FieldOf binding_var "rx_vtbl"]], 289 C.Ex $ C.Call "memset" [C.AddressOf $ C.FieldOf binding_var "message_rx_vtbl", 290 C.NumConstant 0, 291 C.Call "sizeof" [C.FieldOf binding_var "message_rx_vtbl"]], 292 C.Ex $ C.Call "memset" [C.AddressOf $ C.FieldOf binding_var "rpc_rx_vtbl", 293 C.NumConstant 0, 294 C.Call "sizeof" [C.FieldOf binding_var "rpc_rx_vtbl"]], 295 C.Ex $ C.Call "flounder_support_waitset_chanstate_init" 296 [C.AddressOf $ C.FieldOf binding_var "register_chanstate"], 297 C.Ex $ C.Call "flounder_support_waitset_chanstate_init" 298 [C.AddressOf $ C.FieldOf binding_var "tx_cont_chanstate"], 299 C.StmtList 300 [C.Ex $ C.Assignment (C.FieldOf binding_var f) (C.NumConstant 0) 301 | f <- ["tx_msgnum", "rx_msgnum", "tx_msg_fragment", "rx_msg_fragment", 302 "tx_str_pos", "rx_str_pos", "tx_str_len", "rx_str_len"]], 303 C.Ex $ C.Assignment (C.FieldOf binding_var "incoming_token") (C.NumConstant 0), 304 C.Ex $ C.Assignment (C.FieldOf binding_var "outgoing_token") (C.NumConstant 0), 305 C.Ex $ C.Assignment (C.FieldOf binding_var "local_binding") (C.Variable "NULL") ] 306 307binding_struct_destroy :: String -> C.Expr -> [C.Stmt] 308binding_struct_destroy ifn binding_var 309 = [C.Ex $ C.Call "flounder_support_waitset_chanstate_destroy" 310 [C.AddressOf $ C.FieldOf binding_var "register_chanstate"], 311 C.Ex $ C.Call "flounder_support_waitset_chanstate_destroy" 312 [C.AddressOf $ C.FieldOf binding_var "tx_cont_chanstate"]] 313 314-- 315-- Generate a generic can_send function 316-- 317can_send_fn_def :: String -> String -> C.Unit 318can_send_fn_def drv ifn = 319 C.FunctionDef C.Static (C.TypeName "bool") (can_send_fn_name drv ifn) params [ 320 C.Return $ C.Binary C.Equals (bindvar `C.DerefField` "tx_msgnum") (C.NumConstant 0) 321 ] 322 where 323 params = [ C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) "b" ] 324 bindvar = C.Variable "b" 325 326-- 327-- generate a generic register_send function 328-- 329register_send_fn_def :: String -> String -> C.Unit 330register_send_fn_def drv ifn = 331 C.FunctionDef C.Static (C.TypeName "errval_t") (register_send_fn_name drv ifn) params [ 332 C.Return $ C.Call "flounder_support_register" 333 [C.Variable "ws", 334 C.AddressOf $ bindvar `C.DerefField` "register_chanstate", 335 C.Variable intf_cont_var, 336 C.Call (can_send_fn_name drv ifn) [bindvar]] 337 ] 338 where 339 params = [ C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) "b", 340 C.Param (C.Ptr $ C.Struct "waitset") "ws", 341 C.Param (C.Struct "event_closure") intf_cont_var ] 342 bindvar = C.Variable "b" 343 344-- 345-- generate a default error handler (which the user should replace!) 346-- 347default_error_handler_fn_def :: String -> String -> C.Unit 348default_error_handler_fn_def drv ifn = 349 C.FunctionDef C.Static C.Void (default_error_handler_fn_name drv ifn) params [ 350 C.Ex $ C.Call "DEBUG_ERR" 351 [errvar, C.StringConstant $ 352 "asynchronous error in Flounder-generated " ++ 353 ifn ++ " " ++ drv ++ " binding (default handler)" ], 354 C.Ex $ C.Call "abort" [] 355 ] 356 where 357 params = [ C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) "b", 358 C.Param (C.TypeName "errval_t") "err" ] 359 360-- 361-- generate a generic control function that does nothing 362-- 363generic_control_fn_def :: String -> String -> C.Unit 364generic_control_fn_def drv ifn = 365 C.FunctionDef C.Static (C.TypeName "errval_t") (generic_control_fn_name drv ifn) params [ 366 C.SComment "no control flags are supported", 367 C.Return $ C.Variable "SYS_ERR_OK" 368 ] 369 where 370 params = [C.Param (C.Ptr $ C.Struct $ intf_bind_type ifn) intf_bind_var, 371 C.Param (C.TypeName "idc_control_t") "control"] 372 373-- register a transmit continuation 374register_txcont :: C.Expr -> [C.Stmt] 375register_txcont cont_ex = [ 376 C.If (C.Binary C.NotEquals (cont_ex `C.FieldOf` "handler") (C.Variable "NULL")) 377 [localvar (C.TypeName "errval_t") "_err" Nothing, 378 C.Ex $ C.Assignment errvar $ C.Call "flounder_support_register" 379 [C.DerefField bindvar "waitset", 380 C.AddressOf $ bindvar `C.DerefField` "tx_cont_chanstate", 381 cont_ex, 382 C.Variable "false"], 383 C.SComment "may fail if previous continuation hasn't fired yet", 384 C.If (C.Call "err_is_fail" [errvar]) 385 [C.If (C.Binary C.Equals (C.Call "err_no" [errvar]) 386 (C.Variable "LIB_ERR_CHAN_ALREADY_REGISTERED")) 387 [C.Ex $ C.Call "thread_mutex_unlock" [C.AddressOf $ C.DerefField bindvar "send_mutex"], 388 C.Ex $ C.Call "assert" [C.Binary C.NotEquals (cont_ex `C.FieldOf` "handler") (C.Variable "blocking_cont")], 389 C.Return $ C.Variable "FLOUNDER_ERR_TX_BUSY"] 390 [C.Ex $ C.Call "thread_mutex_unlock" [C.AddressOf $ C.DerefField bindvar "send_mutex"], 391 C.Ex $ C.Call "assert" [C.Unary C.Not $ C.StringConstant "shouldn't happen"], 392 C.Return $ errvar] ] [] 393 ] [] 394 ] where 395 errvar = C.Variable "_err" 396 397block_sending :: C.Expr -> [C.Stmt] 398block_sending cont_ex = [ 399 C.If (C.Binary C.Equals (cont_ex `C.FieldOf` "handler") (C.Variable "blocking_cont")) 400 [C.If (C.Binary C.Equals binding_error (C.Variable "SYS_ERR_OK")) [ 401 C.Ex $ C.Assignment binding_error $ C.Call "wait_for_channel" 402 [C.DerefField bindvar "waitset", tx_cont_chanstate, C.AddressOf binding_error] 403 ] [ 404 C.Ex $ C.Call "flounder_support_deregister_chan" [tx_cont_chanstate] 405 ] 406 ] [] 407 ] where 408 errvar = C.Variable "_err" 409 mask = C.CallInd (C.DerefField bindvar "get_receiving_chanstate") [bindvar] 410 tx_cont_chanstate = C.AddressOf $ bindvar `C.DerefField` "tx_cont_chanstate" 411 412-- starting a send: just a debug hook 413start_send :: String -> String -> String -> [MessageArgument] -> [C.Stmt] 414start_send drvn ifn mn msgargs 415 = [C.Ex $ C.Call "FL_DEBUG" [C.StringConstant $ 416 drvn ++ " TX " ++ ifn ++ "." ++ mn ++ "\n"]] 417 418-- finished a send: clear msgnum, trigger pending waitsets/events 419finished_send :: [C.Stmt] 420finished_send = [ 421 C.Ex $ C.Assignment tx_msgnum_field (C.NumConstant 0)] ++ 422 [C.Ex $ C.Call "flounder_support_trigger_chan" [wsaddr ws] 423 | ws <- ["tx_cont_chanstate", "register_chanstate"]] 424 where 425 tx_msgnum_field = C.DerefField bindvar "tx_msgnum" 426 wsaddr ws = C.AddressOf $ bindvar `C.DerefField` ws 427 428-- start receiving: allocate space for any static arrays in message 429start_recv :: String -> String -> [TypeDef] -> String -> [MessageArgument] -> [C.Stmt] 430start_recv drvn ifn typedefs mn msgargs 431 = concat [ 432 [C.Ex $ C.Assignment (field fn) 433 $ C.Call "malloc" [C.SizeOfT $ type_c_type ifn tr], 434 C.Ex $ C.Call "assert" [C.Binary C.NotEquals (field fn) (C.Variable "NULL")] 435 ] | Arg tr (Name fn) <- msgargs, is_array tr] 436 437 where 438 field fn = rx_union_elem mn fn 439 is_array tr = case lookup_typeref typedefs tr of 440 TArray _ _ _ -> True 441 _ -> False 442 443-- finished recv: debug, run handler and clean up 444finished_recv :: String -> String -> [TypeDef] -> MessageType -> String -> [MessageArgument] -> [C.Stmt] 445finished_recv drvn ifn typedefs mtype mn msgargs 446 = [ C.Ex $ C.Call "FL_DEBUG" [C.StringConstant $ 447 drvn ++ " RX " ++ ifn ++ "." ++ mn ++ "\n"], 448 C.If (C.Binary C.NotEquals handler (C.Variable "NULL")) 449 [C.Ex $ C.Assignment (C.FieldOf message_chanstate "token") binding_incoming_token, 450 C.Ex $ C.CallInd handler (bindvar:args)] 451 [C.Ex $ C.Assignment (C.FieldOf message_chanstate "token") binding_incoming_token, 452 C.Ex $ C.Call "flounder_support_trigger_chan" [C.AddressOf message_chanstate], 453 C.Ex $ C.Assignment (C.Variable "no_register") (C.NumConstant 1)], 454 C.Ex $ C.Assignment rx_msgnum_field (C.NumConstant 0)] 455 where 456 rx_msgnum_field = C.DerefField bindvar "rx_msgnum" 457 handler = C.DerefField bindvar "rx_vtbl" `C.FieldOf` mn 458 args = concat [mkargs tr a | Arg tr a <- msgargs] 459 mkargs tr (Name n) = case lookup_typeref typedefs tr of 460 TArray _ _ _ -> [C.DerefPtr $ rx_union_elem mn n] 461 _ -> [rx_union_elem mn n] 462 mkargs _ (StringArray n l) = [rx_union_elem mn n] 463 mkargs _ (DynamicArray n l _) = [rx_union_elem mn n, rx_union_elem mn l] 464 binding_incoming_token = C.DerefField bindvar "incoming_token" 465 message_chanstate = C.SubscriptOf (C.DerefField bindvar "message_chanstate") (C.Variable $ msg_enum_elem_name ifn mn) 466 467finished_recv_nocall :: String -> String -> [TypeDef] -> MessageType -> String -> [MessageArgument] -> [C.Stmt] 468finished_recv_nocall drvn ifn typedefs mtype mn msgargs 469 = [ C.Ex $ C.Call "FL_DEBUG" [C.StringConstant $ 470 drvn ++ " RX " ++ ifn ++ "." ++ mn ++ "\n"], 471 C.If (C.Binary C.NotEquals handler (C.Variable "NULL")) 472 [C.Ex $ C.Assignment (C.Variable "call_msgnum") (C.Variable $ msg_enum_elem_name ifn mn)] 473 [C.Ex $ C.Assignment (C.FieldOf message_chanstate "token") binding_incoming_token, 474 C.Ex $ C.Call "flounder_support_trigger_chan" [C.AddressOf message_chanstate], 475 C.Ex $ C.Assignment (C.Variable "no_register") (C.NumConstant 1)], 476 C.Ex $ C.Assignment rx_msgnum_field (C.NumConstant 0)] 477 where 478 rx_msgnum_field = C.DerefField bindvar "rx_msgnum" 479 handler = C.DerefField bindvar "rx_vtbl" `C.FieldOf` mn 480 binding_incoming_token = C.DerefField bindvar "incoming_token" 481 message_chanstate = C.SubscriptOf (C.DerefField bindvar "message_chanstate") (C.Variable $ msg_enum_elem_name ifn mn) 482 483-- call callback, directly from a receiving handler 484call_handler :: String -> String -> [TypeDef] -> MessageType -> String -> [MessageArgument] -> [C.Stmt] 485call_handler drvn ifn typedefs mtype mn msgargs 486 = [C.Ex $ C.CallInd handler (bindvar:args)] 487 where 488 handler = C.DerefField bindvar "rx_vtbl" `C.FieldOf` mn 489 args = concat [mkargs tr a | Arg tr a <- msgargs] 490 mkargs tr (Name n) = case lookup_typeref typedefs tr of 491 TArray _ _ _ -> [C.DerefPtr $ rx_union_elem mn n] 492 _ -> [rx_union_elem mn n] 493 mkargs _ (StringArray n l) = [rx_union_elem mn n] 494 mkargs _ (DynamicArray n l _) = [rx_union_elem mn n, rx_union_elem mn l] 495 496-- call callback, from a message handler 497call_message_handler_msgargs :: String -> String -> [TypeDef] -> [MessageArgument] -> [C.Stmt] 498call_message_handler_msgargs ifn mn typedefs msgargs 499 = [C.Ex $ C.CallInd handler (bindvar:args)] 500 where 501 handler = C.DerefField bindvar "message_rx_vtbl" `C.FieldOf` mn 502 args = concat [mkargs a | Arg tr a <- msgargs] 503 mkargs (Name n) = [local_rx_union_elem mn n] 504 mkargs (StringArray n l) = [local_rx_union_elem mn n] 505 mkargs (DynamicArray n l _) = [local_rx_union_elem mn n, local_rx_union_elem mn l] 506 507-- call callback, from a rpc handler 508call_message_handler_rpcargs :: String -> String -> [TypeDef] -> [RPCArgument] -> [C.Stmt] 509call_message_handler_rpcargs ifn mn typedefs msgargs 510 = [C.Ex $ C.Call "assert" [handler], 511 C.Ex $ C.CallInd handler (bindvar:args)] 512 where 513 handler = C.DerefField bindvar "message_rx_vtbl" `C.FieldOf` (rpc_call_name mn) 514 args = concat [mkargs a | RPCArgIn tr a <- msgargs] 515 mkargs (Name n) = [local_rx_union_elem mn n] 516 mkargs (StringArray n l) = [local_rx_union_elem mn n] 517 mkargs (DynamicArray n l _) = [local_rx_union_elem mn n, local_rx_union_elem mn l] 518 519-- call rpc callback 520call_rpc_handler :: String -> String -> [TypeDef] -> [RPCArgument] -> [C.Stmt] 521call_rpc_handler ifn mn typedefs msgargs 522 = [C.Ex $ C.CallInd handler (bindvar:args)] 523 where 524 handler = C.DerefField bindvar "rpc_rx_vtbl" `C.FieldOf` (rpc_call_name mn) 525 args = concat [mkargs a | a <- msgargs] 526 mkargs (RPCArgIn _ (Name n)) = [local_rx_union_elem mn n] 527 mkargs (RPCArgIn _ (StringArray n l)) = [local_rx_union_elem mn n] 528 mkargs (RPCArgIn _ (DynamicArray n l _)) = [local_rx_union_elem mn n, local_rx_union_elem mn l] 529 mkargs (RPCArgOut tr (Name n)) = case lookup_typeref typedefs tr of 530 TArray _ _ _ -> [C.DerefPtr $ local_tx_union_elem mn n] 531 _ -> [C.AddressOf $ local_tx_union_elem mn n] 532 mkargs (RPCArgOut _ (StringArray n l)) = [local_tx_union_elem mn n] 533 mkargs (RPCArgOut _ (DynamicArray n l _)) = [local_tx_union_elem mn n, C.AddressOf $ local_tx_union_elem mn l] 534 535-- send response 536send_response :: String -> String -> [TypeDef] -> [RPCArgument] -> [C.Stmt] 537send_response ifn mn typedefs msgargs 538 = [C.Ex $ C.Call "assert" [handler], 539 C.Ex $ C.Assignment errvar $ C.CallInd handler (bindvar:cont:args), 540 C.Ex $ C.Call "assert" [C.Call "err_is_ok" [errvar]]] 541 where 542 handler = C.DerefField bindvar "tx_vtbl" `C.FieldOf` (rpc_resp_name mn) 543 args = concat [mkargs tr a | RPCArgOut tr a <- msgargs] 544 mkargs tr (Name n) = case lookup_typeref typedefs tr of 545 TArray _ _ _ -> [C.DerefPtr $ local_tx_union_elem mn n] 546 _ -> [local_tx_union_elem mn n] 547 mkargs _ (StringArray n l) = [local_tx_union_elem mn n] 548 mkargs _ (DynamicArray n l _) = [local_tx_union_elem mn n, local_tx_union_elem mn l] 549 cont = C.Variable "BLOCKING_CONT" 550 551tx_arg_assignment :: String -> [TypeDef] -> String -> MessageArgument -> C.Stmt 552tx_arg_assignment ifn typedefs mn (Arg tr v) = case v of 553 Name an -> C.Ex $ C.Assignment (tx_union_elem mn an) (srcarg an) 554 StringArray an _ -> C.Ex $ C.Assignment (tx_union_elem mn an) ((C.Variable an)) 555 DynamicArray an len _ -> C.StmtList [ 556 C.Ex $ C.Assignment (tx_union_elem mn an) (C.Cast (C.Ptr typespec) (C.Variable an)), 557 C.Ex $ C.Assignment (tx_union_elem mn len) (C.Variable len)] 558 where 559 typespec = type_c_type ifn tr 560 srcarg an = 561 case lookup_typeref typedefs tr of 562 -- XXX: I have no idea why GCC requires a cast for the array type 563 TArray _ _ _ -> C.Cast (C.Ptr typespec) (C.Variable an) 564 _ -> case typespec of 565 -- we may need to cast away the const on a pointer 566 C.Ptr _ -> C.Cast typespec (C.Variable an) 567 _ -> C.Variable an 568 569 570-- extracts the size of the arguemnts of a message 571extract_msg_size :: MessageArgument -> Integer 572extract_msg_size (Arg tr (Name an)) = 0 573extract_msg_size (Arg tr (StringArray an maxlen)) = maxlen 574extract_msg_size (Arg tr (DynamicArray an len maxlen)) = maxlen 575 576-- extracts the size of the arguemnts of an RPC (in) 577extract_rpc_size_in :: RPCArgument -> Integer 578extract_rpc_size_in (RPCArgIn tr (Name an)) = 0 579extract_rpc_size_in (RPCArgIn tr (StringArray an maxlen)) = maxlen 580extract_rpc_size_in (RPCArgIn tr (DynamicArray an len maxlen)) = maxlen 581 582-- extracts the size of the arguemnts of an RPC (out) 583extract_rpc_size_out :: RPCArgument -> Integer 584extract_rpc_size_out (RPCArgOut tr (Name an)) = 0 585extract_rpc_size_out (RPCArgOut tr (StringArray an maxlen)) = maxlen 586extract_rpc_size_out (RPCArgOut tr (DynamicArray an len maxlen)) = maxlen 587 588-- extract the size of arguemnts 589msg_arg_extract_length :: MessageDef -> Integer 590msg_arg_extract_length (RPC n [] _) = 0 591msg_arg_extract_length (RPC n args _) = maximum [ sum $ [ extract_rpc_size_in arg | arg <- args], sum $ [ extract_rpc_size_out arg | arg <- args]] 592msg_arg_extract_length (Message mtype n [] _) = 0 593msg_arg_extract_length (Message mtype n args _) = sum $ [ extract_msg_size arg | arg <- args] 594 595 596 597-- checks the size of the MSG arguments 598tx_fn_arg_check_size :: String -> [TypeDef] -> String -> MessageArgument -> C.Stmt 599tx_fn_arg_check_size ifn typedefs mn (Arg tr v) = case v of 600 Name an -> C.SComment (an ++ " has a base type. no length check") 601 StringArray an maxlen -> C.StmtList [ 602 C.SComment ("checking datalength of " ++ an), 603 C.If (C.Binary C.And (C.Variable an) 604 (C.Binary C.GreaterThanEq (C.Call "strlen" [C.Variable an]) (C.NumConstant maxlen))) [ 605 C.Return (C.Variable "FLOUNDER_ERR_TX_MSG_SIZE") 606 ] [] 607 ] 608 DynamicArray an len maxlen -> C.StmtList [ 609 C.SComment ("checking datalength of " ++ an), 610 C.If (C.Binary C.GreaterThan (C.Variable len) (C.NumConstant maxlen)) [ 611 C.Return (C.Variable "FLOUNDER_ERR_TX_MSG_SIZE") 612 ] [] 613 ] 614 615-- checks the size of the RPC arguments 616tx_fn_arg_check_size_rpc :: String -> [TypeDef] -> String -> RPCArgument -> C.Stmt 617tx_fn_arg_check_size_rpc ifn typedefs mn (RPCArgIn tr v) = case v of 618 Name an -> C.SComment (an ++ " has a base type. no length check") 619 StringArray an maxlen -> C.StmtList [ 620 C.SComment ("checking datalength of " ++ an), 621 C.If (C.Binary C.And (C.Variable an) 622 (C.Binary C.GreaterThanEq (C.Call "strlen" [C.Variable an]) (C.NumConstant maxlen)))[ 623 C.Return (C.Variable "FLOUNDER_ERR_TX_MSG_SIZE") 624 ] [] 625 ] 626 DynamicArray an len maxlen -> C.StmtList [ 627 C.SComment ("checking datalength of " ++ an), 628 C.If (C.Binary C.GreaterThan (C.Variable len) (C.NumConstant maxlen)) [ 629 C.Return (C.Variable "FLOUNDER_ERR_TX_MSG_SIZE") 630 ] [] 631 ] 632tx_fn_arg_check_size_rpc ifn typedefs mn (RPCArgOut tr v) = C.SComment (" Is out arg") 633 634 635tx_union_elem :: String -> String -> C.Expr 636tx_union_elem mn fn 637 = bindvar `C.DerefField` "tx_union" `C.FieldOf` mn `C.FieldOf` fn 638 639rx_union_elem :: String -> String -> C.Expr 640rx_union_elem mn fn 641 = bindvar `C.DerefField` "rx_union" `C.FieldOf` mn `C.FieldOf` fn 642 643local_rx_union_elem :: String -> String -> C.Expr 644local_rx_union_elem mn fn 645 = (C.Variable "arguments") `C.FieldOf` fn 646 647local_tx_union_elem :: String -> String -> C.Expr 648local_tx_union_elem mn fn 649 = (C.Variable "result") `C.FieldOf` fn 650 651-- misc common bits of C 652localvar = C.VarDecl C.NoScope C.NonConst 653errvar = C.Variable "err" 654bindvar = C.Variable intf_bind_var 655binding_error = C.DerefField bindvar "error" 656clear_error = C.Ex $ C.Assignment binding_error (C.Variable "SYS_ERR_OK") 657report_user_err ex = C.StmtList [ 658 C.Ex $ C.Assignment (C.DerefField bindvar "error") ex, 659 C.If (C.DerefField bindvar "error_handler") [ 660 C.Ex $ C.CallInd (C.DerefField bindvar "error_handler") [bindvar, ex] 661 ] []] 662 663report_user_tx_err ex = C.StmtList [ 664 report_user_err ex, 665 C.Ex $ C.Assignment tx_msgnum_field (C.NumConstant 0), 666 C.Ex $ C.Call "flounder_support_trigger_chan" [wsaddr "register_chanstate"], 667 C.Ex $ C.Call "flounder_support_deregister_chan" [wsaddr "tx_cont_chanstate"] 668 ] where 669 tx_msgnum_field = C.DerefField bindvar "tx_msgnum" 670 wsaddr ws = C.AddressOf $ bindvar `C.DerefField` ws 671